Allocate location ids in descending order

This should typically lead to slightly improved performance as it is typical
that locations closer to the root of a data structure are allocated before
locations further from the root.  So, when a data structure is traversed
starting from the root, the resuling splay tree should be right leaning and
slightly faster to construct and traverse from left to right.

Author: polytypic

src/kcas.ml

@@ -20,10 +20,12 @@ let fenceless_set = Atomic.set
 module Backoff = Backoff
 
 module Id = struct
-  let neg_id = Atomic.make Int.min_int
-  let neg_id () = Atomic.fetch_and_add neg_id 1
-  let nat_id = Atomic.make 0
-  let nat_id () = Atomic.fetch_and_add nat_id 1
+  let neg_id = Atomic.make (-1)
+  let neg_ids n = Atomic.fetch_and_add neg_id (-n) [@@inline]
+  let neg_id () = neg_ids 1 [@@inline]
+  let nat_id = Atomic.make Int.max_int
+  let nat_ids n = Atomic.fetch_and_add nat_id (-n) [@@inline]
+  let nat_id () = nat_ids 1 [@@inline]
 end
 
 module Action : sig
@@ -376,6 +378,15 @@ module Loc = struct
     in
     make_loc state id
 
+  let make_array ?(mode = Mode.obstruction_free) n after =
+    assert (0 <= n);
+    let state = new_state after
+    and id =
+      (if mode == Mode.obstruction_free then Id.nat_ids n else Id.neg_ids n)
+      - (n - 1)
+    in
+    Array.init n @@ fun i -> make_loc state (id + i)
+
   let get_id loc = loc.id [@@inline]
   let get loc = eval (Atomic.get (as_atomic loc))
 

src/kcas.mli

@@ -69,6 +69,10 @@ module Loc : sig
       in rare cases where a location is updated frequently and obstruction-free
       read-only accesses would almost certainly suffer from interference. *)
 
+  val make_array : ?mode:Mode.t -> int -> 'a -> 'a t array
+  (** [make_array n initial] creates an array of [n] new shared memory locations
+      with the [initial] value. *)
+
   val get_mode : 'a t -> Mode.t
   (** [get_mode r] returns the operating mode of the shared memory location
       [r]. *)

src/kcas_data/accumulator.ml

@@ -11,7 +11,9 @@ let make ?n_way n =
     | None -> n_way_default
     | Some n_way -> n_way |> Int.min n_way_max |> Bits.ceil_pow_2
   in
-  Array.init n_way (fun i -> Loc.make (if i = 0 then n else 0))
+  let a = Loc.make_array ~mode:Mode.lock_free n_way 0 in
+  Loc.set (Array.unsafe_get a 0) n;
+  a
 
 let n_way_of = Array.length
 

src/kcas_data/hashtbl.ml

@@ -106,8 +106,6 @@ module HashedType = struct
     hash == HashedType.hash && equal == HashedType.equal
 end
 
-let make_bucket _ = Loc.make []
-
 let create ?hashed_type ?min_buckets ?max_buckets ?n_way () =
   let min_buckets =
     match min_buckets with
@@ -123,8 +121,9 @@ let create ?hashed_type ?min_buckets ?max_buckets ?n_way () =
     | None -> (Stdlib.Hashtbl.seeded_hash (Random.bits ()), ( = ))
     | Some hashed_type -> HashedType.unpack hashed_type
   and pending = Loc.make Nothing
-  and length = Accumulator.make ?n_way 0
-  and buckets = Loc.make @@ Array.init min_buckets make_bucket in
+  and buckets = Loc.make [||]
+  and length = Accumulator.make ?n_way 0 in
+  Loc.set buckets @@ Loc.make_array min_buckets [];
   { pending; length; buckets; hash; equal; min_buckets; max_buckets }
 
 let n_way_of t = Accumulator.n_way_of t.length
@@ -173,8 +172,7 @@ module Xt = struct
     | Nothing -> ()
     | Rehash { state; new_capacity; new_buckets } -> (
         let new_buckets =
-          get_or_alloc new_buckets @@ fun () ->
-          Array.init new_capacity make_bucket
+          get_or_alloc new_buckets @@ fun () -> Loc.make_array new_capacity []
         in
         let old_buckets = Xt.exchange ~xt t.buckets new_buckets in
         let hash = t.hash and mask = new_capacity - 1 in
@@ -244,8 +242,7 @@ module Xt = struct
         Retry.unless (0 <= Loc.fenceless_get state);
         let new_capacity = Array.length old_buckets in
         let new_buckets =
-          get_or_alloc new_buckets @@ fun () ->
-          Array.init new_capacity make_bucket
+          get_or_alloc new_buckets @@ fun () -> Loc.make_array new_capacity []
         in
         let filter_map_a_few_buckets ~xt =
           let i = Xt.fetch_and_add ~xt state (-batch_size) in
@@ -404,11 +401,12 @@ let rebuild ?hashed_type ?min_buckets ?max_buckets ?n_way t =
     | None -> true
     | Some hashed_type -> HashedType.is_same_as t.hash t.equal hashed_type
   and length = !length in
-  if is_same_hashed_type && min_buckets <= length && length <= max_buckets then
+  if is_same_hashed_type && min_buckets <= length && length <= max_buckets then (
     let pending = Loc.make Nothing
-    and length = Accumulator.make ~n_way length
-    and buckets = Loc.make @@ Array.map Loc.make snapshot in
-    { t with pending; length; buckets; min_buckets; max_buckets }
+    and buckets = Loc.make [||]
+    and length = Accumulator.make ~n_way length in
+    Loc.set buckets @@ Array.map Loc.make snapshot;
+    { t with pending; length; buckets; min_buckets; max_buckets })
   else
     let t = create ?hashed_type ~min_buckets ~max_buckets ~n_way () in
     snapshot

src/kcas_data/queue.ml

@@ -6,15 +6,15 @@ type 'a t = {
   front : 'a Elems.t Loc.t;
 }
 
-let alloc ~back ~middle ~front =
+let alloc ~front ~middle ~back =
   (* We allocate locations in specific order to make most efficient use of the
      splay-tree based transaction log. *)
-  let back = Loc.make back
+  let front = Loc.make front
   and middle = Loc.make middle
-  and front = Loc.make front in
+  and back = Loc.make back in
   { back; middle; front }
 
-let create () = alloc ~back:Elems.empty ~middle:Elems.empty ~front:Elems.empty
+let create () = alloc ~front:Elems.empty ~middle:Elems.empty ~back:Elems.empty
 
 let copy q =
   let tx ~xt = (Xt.get ~xt q.front, Xt.get ~xt q.middle, Xt.get ~xt q.back) in

test/benchmark.ml

@@ -16,7 +16,7 @@ let make_kCAS k =
     if k > 0 then
       let a = Loc.make 0 in
       loop (k - 1) (Op.make_cas a 0 1 :: out1) (Op.make_cas a 1 0 :: out2)
-    else (out1, out2)
+    else (List.rev out1, List.rev out2)
   in
 
   loop k [] []