From f2aa501688dc1384bc3832c40d77b950f6620db1 Mon Sep 17 00:00:00 2001 From: Vesa Karvonen Date: Sat, 30 Dec 2023 12:34:17 +0200 Subject: [PATCH] Expose that `'a Loc.t` does not float This allows slightly faster accesses of arrays of locations. --- README.md | 44 ++++++++++++++++++++++++++-------------- doc/scheduler-interop.md | 2 +- src/kcas/kcas.ml | 43 ++++++++++++++++++++++++--------------- src/kcas/kcas.mli | 12 +++++++---- 4 files changed, 65 insertions(+), 36 deletions(-) diff --git a/README.md b/README.md index 4fbff8d6..b8338749 100644 --- a/README.md +++ b/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 = -val b : int Loc.t = -val x : int Loc.t = +val a : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } +val b : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } +val x : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } ``` 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 = +val a_stack : int stack = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } # 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 = ; back = } +val a_queue : int queue = + {front = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }; + back = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }} # 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 = +val a_stack : int stack = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } # let a_queue : int queue = queue () -val a_queue : int queue = {front = ; back = } +val a_queue : int queue = + {front = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }; + back = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }} ``` 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 = +val a_heap : int leftist Loc.t = + Kcas.Loc.Loc {Kcas.Loc.state = ; id = } ``` 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 = ; table = ; order = } + {space = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }; + table = ; order = } # 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 = +val a_stack : int list Loc.t = + Kcas.Loc.Loc {Kcas.Loc.state = ; id = } # 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 = ; tail = } +val a_queue : int queue = + {head = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }; + tail = } # 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 = ; basic = {size = ; data = }} + {pending = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }; + basic = + {size = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }; + data = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }}} # 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 = ; tail = } +val a_queue : int queue = + {head = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }; + tail = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }} # 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 = -val b : int Loc.t = +val a : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } +val b : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } ``` And create a helper that spawns a domain that repeatedly increments `a` and diff --git a/doc/scheduler-interop.md b/doc/scheduler-interop.md index 827a4e96..39bb662b 100644 --- a/doc/scheduler-interop.md +++ b/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 = +val state : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } # let sync_to target = state |> Loc.get_as @@ fun current -> diff --git a/src/kcas/kcas.ml b/src/kcas/kcas.ml index e315f70d..99823828 100644 --- a/src/kcas/kcas.ml +++ b/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 diff --git a/src/kcas/kcas.mli b/src/kcas/kcas.mli index 23329767..b5928fbe 100644 --- a/src/kcas/kcas.mli +++ b/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 = - val b : int Loc.t = - val x : int Loc.t = + val a : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } + val b : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } + val x : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } ]} 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]