Add Picos_aux_htbl.copy

Author: polytypic

lib/picos_aux.htbl/picos_aux_htbl.ml

@@ -554,6 +554,43 @@ let rec try_dissoc : type v c r. (_, v) t -> _ -> c -> (v, c, r) op -> _ -> r =
 
 (* *)
 
+let rec copy t backoff =
+  let r = get t in
+  if try_resize t r (Atomic_array.length r.buckets) ~clear:false then begin
+    (* We need to create and count a new size as the previous one is being used
+       by the original. *)
+    let non_linearizable_size =
+      Array.init (Array.length r.non_linearizable_size) @@ fun _ ->
+      Atomic.make_contended 0
+    in
+    let buckets = r.buckets in
+    (* We need to copy the array, because other threads might actually still be
+       trying to resize it. *)
+    let buckets =
+      Atomic_array.init (Atomic_array.length buckets) @@ fun i ->
+      match Atomic_array.unsafe_fenceless_get buckets i with
+      | B (Resize spine_r) ->
+          let spine = spine_r.spine in
+          let rec count n = function
+            | Nil -> n
+            | Cons r -> count (n + 1) r.rest
+          in
+          let _ : int =
+            Atomic.fetch_and_add
+              (Array.unsafe_get non_linearizable_size 0)
+              (count 0 spine)
+          in
+          B spine
+      | B (Nil | Cons _) ->
+          (* After resize only [Resize] values should be left in the old
+           buckets. *)
+          assert false
+    in
+    let r = { r with non_linearizable_size; buckets } in
+    Atomic.make r |> Multicore_magic.copy_as_padded
+  end
+  else copy t (Backoff.once backoff)
+
 let rec snapshot t ~clear backoff =
   let r = get t in
   if try_resize t r (Atomic_array.length r.buckets) ~clear then begin
@@ -580,6 +617,7 @@ let rec snapshot t ~clear backoff =
   end
   else snapshot t ~clear (Backoff.once backoff)
 
+let copy t = copy t Backoff.default
 let to_seq t = snapshot t ~clear:false Backoff.default
 let remove_all t = snapshot t ~clear:true Backoff.default
 

lib/picos_aux.htbl/picos_aux_htbl.mli

@@ -54,6 +54,11 @@ val max_buckets_of : ('k, 'v) t -> int
 
     ℹ️ The returned value may not be the same as given to {!create}. *)
 
+val copy : ('k, 'v) t -> ('k, 'v) t
+(** [copy htbl] creates an independent copy of the hash table.
+
+    🐌 This is a linear time operation. *)
+
 (** {2 Looking up bindings} *)
 
 val find_exn : ('k, 'v) t -> 'k -> 'v

test/test_htbl.ml

@@ -8,20 +8,25 @@ let () =
   let t = Htbl.create () in
   assert (Htbl.try_add t "Basics" 101);
   assert (Htbl.try_add t "Answer" 42);
-  assert (Htbl.non_linearizable_length t = 2);
-  assert (101 = Htbl.remove_exn t "Basics");
-  assert (not (Htbl.try_remove t "Basics"));
-  assert (Htbl.non_linearizable_length t = 1);
-  assert (Htbl.remove_all t |> List.of_seq = [ ("Answer", 42) ]);
-  assert (Htbl.non_linearizable_length t = 0);
-  assert (Htbl.to_seq t |> List.of_seq = []);
-  [ "One"; "Two"; "Three" ]
-  |> List.iteri (fun v k -> assert (Htbl.try_add t k v));
-  assert (Htbl.non_linearizable_length t = 3);
-  assert (
-    Htbl.to_seq t |> List.of_seq
-    |> List.sort (fun l r -> String.compare (fst l) (fst r))
-    = [ ("One", 0); ("Three", 2); ("Two", 1) ])
+  let h = Htbl.copy t in
+  let test t =
+    assert (Htbl.non_linearizable_length t = 2);
+    assert (101 = Htbl.remove_exn t "Basics");
+    assert (not (Htbl.try_remove t "Basics"));
+    assert (Htbl.non_linearizable_length t = 1);
+    assert (Htbl.remove_all t |> List.of_seq = [ ("Answer", 42) ]);
+    assert (Htbl.non_linearizable_length t = 0);
+    assert (Htbl.to_seq t |> List.of_seq = []);
+    [ "One"; "Two"; "Three" ]
+    |> List.iteri (fun v k -> assert (Htbl.try_add t k v));
+    assert (Htbl.non_linearizable_length t = 3);
+    assert (
+      Htbl.to_seq t |> List.of_seq
+      |> List.sort (fun l r -> String.compare (fst l) (fst r))
+      = [ ("One", 0); ("Three", 2); ("Two", 1) ])
+  in
+  test t;
+  test h
 
 module Int = struct
   include Int