Expose that 'a Loc.t does not float

This allows slightly faster accesses of arrays of locations.

Author: polytypic

README.md

@@ -114,9 +114,9 @@ one first creates shared memory locations:
 # let a = Loc.make 0
   and b = Loc.make 0
   and x = Loc.make 0
-val a : int Loc.t = <abstr>
-val b : int Loc.t = <abstr>
-val x : int Loc.t = <abstr>
+val a : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
+val b : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
+val x : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
 ```
 
 One can then manipulate the locations individually:
@@ -300,7 +300,7 @@ transactions to `push` and `try_pop` elements:
 
 ```ocaml
 # let a_stack : int stack = stack ()
-val a_stack : int stack = <abstr>
+val a_stack : int stack = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
 
 # Xt.commit { tx = push a_stack 101 }
 - : unit = ()
@@ -418,7 +418,9 @@ transactions to `enqueue` and `try_dequeue` elements:
 
 ```ocaml
 # let a_queue : int queue = queue ()
-val a_queue : int queue = {front = <abstr>; back = <abstr>}
+val a_queue : int queue =
+  {front = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
+   back = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}}
 
 # Xt.commit { tx = enqueue a_queue 76 }
 - : unit = ()
@@ -533,10 +535,12 @@ To test them out, let's create a fresh stack and a queue
 
 ```ocaml
 # let a_stack : int stack = stack ()
-val a_stack : int stack = <abstr>
+val a_stack : int stack = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
 
 # let a_queue : int queue = queue ()
-val a_queue : int queue = {front = <abstr>; back = <abstr>}
+val a_queue : int queue =
+  {front = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
+   back = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}}
 ```
 
 and then spawn a domain that tries to atomically both pop and dequeue:
@@ -759,7 +763,8 @@ and create a leftist heap:
 
 ```ocaml
 # let a_heap : int leftist Loc.t = leftist ()
-val a_heap : int leftist Loc.t = <abstr>
+val a_heap : int leftist Loc.t =
+  Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
 ```
 
 To populate the heap we need to define a transaction passing function and pass
@@ -1018,7 +1023,8 @@ We can then test that the cache works as expected:
 ```ocaml
 # let a_cache : (int, string) cache = cache 2
 val a_cache : (int, string) cache =
-  {space = <abstr>; table = <abstr>; order = <abstr>}
+  {space = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
+   table = <abstr>; order = <abstr>}
 
 # Xt.commit { tx = set_blocking a_cache 101 "basics" }
 - : unit = ()
@@ -1266,7 +1272,8 @@ Consider the following example of computing the size of a stack:
 
 ```ocaml
 # let a_stack = Loc.make [2; 3]
-val a_stack : int list Loc.t = <abstr>
+val a_stack : int list Loc.t =
+  Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
 
 # let n_elems =
     let tx ~xt =
@@ -1432,7 +1439,9 @@ Using the Michael-Scott style queue is as easy as any other transactional queue:
 
 ```ocaml
 # let a_queue : int queue = queue ()
-val a_queue : int queue = {head = <abstr>; tail = <abstr>}
+val a_queue : int queue =
+  {head = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
+   tail = <abstr>}
 
 # Xt.commit { tx = enqueue a_queue 19 }
 - : unit = ()
@@ -1884,7 +1893,10 @@ for hash tables, we are ready to take it out for a spin:
 ```ocaml
 # let a_hashtbl : (string, int) hashtbl = hashtbl ()
 val a_hashtbl : (string, int) hashtbl =
-  {pending = <abstr>; basic = {size = <abstr>; data = <abstr>}}
+  {pending = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
+   basic =
+    {size = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
+     data = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}}}
 
 # let assoc = [
     ("Intro", 101);
@@ -1999,7 +2011,9 @@ in the earlier example:
 
 ```ocaml
 # let a_queue : int queue = queue ()
-val a_queue : int queue = {head = <abstr>; tail = <abstr>}
+val a_queue : int queue =
+  {head = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
+   tail = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}}
 
 # let counter = ref 1_000
 val counter : int ref = {contents = 1000}
@@ -2054,8 +2068,8 @@ locations. Let's just create two locations `a` and `b`:
 
 ```ocaml
 # let a = Loc.make 0 and b = Loc.make 0
-val a : int Loc.t = <abstr>
-val b : int Loc.t = <abstr>
+val a : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
+val b : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
 ```
 
 And create a helper that spawns a domain that repeatedly increments `a` and

doc/scheduler-interop.md

@@ -131,7 +131,7 @@ state in between, and then returns their sum:
 
 ```ocaml
 # let state = Loc.make 0
-val state : int Loc.t = <abstr>
+val state : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
 # let sync_to target =
     state
     |> Loc.get_as @@ fun current ->

src/kcas/kcas.ml

@@ -560,12 +560,15 @@ let inc x = x + 1
 let dec x = x - 1
 
 module Loc = struct
-  type 'a t = 'a loc
+  type !'a t = Loc : { state : 'state; id : 'id } -> 'a t
+
+  external of_loc : 'a loc -> 'a t = "%identity"
+  external to_loc : 'a t -> 'a loc = "%identity"
 
   let make ?(padded = false) ?(mode = `Obstruction_free) after =
     let state = new_state after
     and id = if mode == `Obstruction_free then Id.nat_id () else Id.neg_id () in
-    make_loc padded state id
+    make_loc padded state id |> of_loc
 
   let make_contended ?mode after = make ~padded:true ?mode after
 
@@ -576,10 +579,10 @@ module Loc = struct
       (if mode == `Obstruction_free then Id.nat_ids n else Id.neg_ids n)
       - (n - 1)
     in
-    Array.init n @@ fun i -> make_loc padded state (id + i)
+    Array.init n @@ fun i -> make_loc padded state (id + i) |> of_loc
 
-  let[@inline] get_id loc = loc.id
-  let get loc = eval (atomic_get (as_atomic loc))
+  let[@inline] get_id loc = (to_loc loc).id
+  let get loc = eval (atomic_get (as_atomic (to_loc loc)))
 
   let rec get_as timeout f loc state =
     let before = eval state in
@@ -588,40 +591,45 @@ module Loc = struct
         Timeout.cancel timeout;
         value
     | exception Retry.Later ->
-        block timeout loc before;
+        block timeout (to_loc loc) before;
         (* Fenceless is safe as there was already a fence before. *)
-        get_as timeout f loc (fenceless_get (as_atomic loc))
+        get_as timeout f loc (fenceless_get (as_atomic (to_loc loc)))
     | exception exn ->
         Timeout.cancel timeout;
         raise exn
 
   let[@inline] get_as ?timeoutf f loc =
-    get_as (Timeout.alloc_opt timeoutf) f loc (atomic_get (as_atomic loc))
+    get_as
+      (Timeout.alloc_opt timeoutf)
+      f loc
+      (atomic_get (as_atomic (to_loc loc)))
 
   let[@inline] get_mode loc =
-    if loc.id < 0 then `Lock_free else `Obstruction_free
+    if (to_loc loc).id < 0 then `Lock_free else `Obstruction_free
 
   let compare_and_set ?(backoff = Backoff.default) loc before after =
     let state = new_state after in
-    let state_old = atomic_get (as_atomic loc) in
-    cas_with_state backoff loc before state state_old
+    let state_old = atomic_get (as_atomic (to_loc loc)) in
+    cas_with_state backoff (to_loc loc) before state state_old
 
   let fenceless_update ?timeoutf ?(backoff = Backoff.default) loc f =
     let timeout = Timeout.alloc_opt timeoutf in
-    update_with_state timeout backoff loc f (fenceless_get (as_atomic loc))
+    update_with_state timeout backoff (to_loc loc) f
+      (fenceless_get (as_atomic (to_loc loc)))
 
   let[@inline] fenceless_modify ?timeoutf ?backoff loc f =
     fenceless_update ?timeoutf ?backoff loc f |> ignore
 
   let update ?timeoutf ?(backoff = Backoff.default) loc f =
     let timeout = Timeout.alloc_opt timeoutf in
-    update_with_state timeout backoff loc f (atomic_get (as_atomic loc))
+    update_with_state timeout backoff (to_loc loc) f
+      (atomic_get (as_atomic (to_loc loc)))
 
   let[@inline] modify ?timeoutf ?backoff loc f =
     update ?timeoutf ?backoff loc f |> ignore
 
   let exchange ?(backoff = Backoff.default) loc value =
-    exchange_no_alloc backoff loc (new_state value)
+    exchange_no_alloc backoff (to_loc loc) (new_state value)
 
   let set ?backoff loc value = exchange ?backoff loc value |> ignore
 
@@ -640,10 +648,10 @@ module Loc = struct
     fenceless_update ?backoff loc dec |> ignore
 
   let has_awaiters loc =
-    let state = atomic_get (as_atomic loc) in
+    let state = atomic_get (as_atomic (to_loc loc)) in
     state.awaiters != []
 
-  let fenceless_get loc = eval (fenceless_get (as_atomic loc))
+  let fenceless_get loc = eval (fenceless_get (as_atomic (to_loc loc)))
 end
 
 module Xt = struct
@@ -712,6 +720,7 @@ module Xt = struct
       current
 
   let[@inline] unsafe_update ~xt loc f =
+    let loc = Loc.to_loc loc in
     maybe_validate_log xt;
     let x = loc.id in
     match !(tree_as_ref xt) with
@@ -764,6 +773,7 @@ module Xt = struct
     xt_r.post_commit <- Action.append action xt_r.post_commit
 
   let validate ~xt loc =
+    let loc = Loc.to_loc loc in
     let x = loc.id in
     match !(tree_as_ref xt) with
     | T Leaf -> ()
@@ -781,6 +791,7 @@ module Xt = struct
       end
 
   let is_in_log ~xt loc =
+    let loc = Loc.to_loc loc in
     let x = loc.id in
     match !(tree_as_ref xt) with
     | T Leaf -> false

src/kcas/kcas.mli

@@ -45,9 +45,9 @@
       # let a = Loc.make 0
         and b = Loc.make 0
         and x = Loc.make 0
-      val a : int Loc.t = <abstr>
-      val b : int Loc.t = <abstr>
-      val x : int Loc.t = <abstr>
+      val a : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
+      val b : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
+      val x : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}
     ]}
 
     One can then manipulate the locations individually:
@@ -170,8 +170,12 @@ end
 
 (** Shared memory locations. *)
 module Loc : sig
-  type !'a t
   (** Type of shared memory locations. *)
+  type !'a t =
+    | Loc : { state : 'state; id : 'id } -> 'a t
+        (** The shape is transparent to allow the compiler to perform
+            optimizations on array accesses.  User code should treat this tyoe
+            as abstract. *)
 
   val make : ?padded:bool -> ?mode:Mode.t -> 'a -> 'a t
   (** [make initial] creates a new shared memory location with the [initial]