├── .dockerignore ├── .gitignore ├── test ├── kcas_data │ ├── empty.ocaml4.ml │ ├── empty.ocaml5.ml │ ├── stm_run │ │ ├── empty.ocaml4.ml │ │ ├── empty.ocaml5.ml │ │ ├── dune │ │ ├── stm_run.ocaml4.ml │ │ ├── util.ml │ │ ├── stm_run.ocaml5.ml │ │ └── intf.ml │ ├── util.ml │ ├── xt_stack.mli │ ├── xt_linked_queue.mli │ ├── xt_stack.ml │ ├── lru_cache_intf.ml │ ├── lru_cache.mli │ ├── dune │ ├── mvar_test.ml │ ├── stack_test.ml │ ├── queue_test.ml │ ├── xt_linked_queue.ml │ ├── xt_test.ml │ ├── accumulator_test_stm.ml │ ├── stack_test_stm.ml │ ├── lru_cache_example.ml │ ├── queue_test_stm.ml │ ├── hashtbl_test_stm.ml │ ├── lru_cache.ml │ ├── dllist_test.ml │ ├── dllist_test_stm.ml │ ├── hashtbl_test.ml │ └── linearizable_chaining_example.ml └── kcas │ ├── barrier.mli │ ├── util.ml │ ├── dune │ ├── barrier.ml │ ├── threads.ml │ ├── loc_modes.ml │ └── ms_queue_test.ml ├── bench ├── domain.ocaml4.ml ├── main.ml ├── dune ├── bench_xt.ml ├── bench_xt_ro.ml ├── bench_accumulator.ml ├── bench_parallel_cmp.ml ├── bench_hashtbl.ml ├── bench_dllist.ml ├── bench_mvar.ml ├── bench_stack.ml ├── bench_queue.ml └── bench_loc.ml ├── kcas.opam.template ├── .ocamlformat ├── .gitattributes ├── src ├── kcas_data │ ├── domain.ocaml4.ml │ ├── kcas_data.ml │ ├── bits.mli │ ├── magic_option.mli │ ├── dune │ ├── magic_option.ml │ ├── elems.mli │ ├── accumulator_intf.ml │ ├── accumulator.mli │ ├── bits.ml │ ├── mvar.mli │ ├── promise_intf.ml │ ├── mvar_intf.ml │ ├── mvar.ml │ ├── elems.ml │ ├── promise.mli │ ├── stack.ml │ ├── stack.mli │ ├── promise.ml │ ├── stack_intf.ml │ ├── hashtbl_intf.ml │ ├── queue.mli │ ├── queue_intf.ml │ ├── accumulator.ml │ ├── dllist.mli │ ├── dllist_intf.ml │ ├── kcas_data.mli │ ├── queue.ml │ ├── hashtbl.mli │ ├── dllist.ml │ └── hashtbl.ml └── kcas │ └── dune ├── Makefile ├── kcas_data.opam.template ├── dune ├── .prettierrc ├── doc ├── dune ├── kcas.svg ├── scheduler-interop.md └── gkmz-with-read-only-cmp-ops.md ├── bench.Dockerfile ├── CODE_OF_CONDUCT.md ├── HACKING.md ├── LICENSE.md ├── .github └── workflows │ └── workflow.yml ├── kcas_data.opam ├── kcas.opam ├── update-gh-pages-for-tag ├── dune-project └── CHANGES.md /.dockerignore: -------------------------------------------------------------------------------- 1 | _build 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install -------------------------------------------------------------------------------- /test/kcas_data/empty.ocaml4.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/kcas_data/empty.ocaml5.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/kcas_data/stm_run/empty.ocaml4.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/kcas_data/stm_run/empty.ocaml5.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /bench/domain.ocaml4.ml: -------------------------------------------------------------------------------- 1 | let recommended_domain_count () = 1 2 | -------------------------------------------------------------------------------- /kcas.opam.template: -------------------------------------------------------------------------------- 1 | doc: "https://ocaml-multicore.github.io/kcas/doc/kcas/Kcas/" 2 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | version = 0.27.0 3 | 4 | exp-grouping=preserve 5 | -------------------------------------------------------------------------------- /test/kcas/barrier.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val make : int -> t 4 | val await : t -> unit 5 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # To work around MDX issues 2 | *.md text eol=lf 3 | *.mli text eol=lf 4 | -------------------------------------------------------------------------------- /src/kcas_data/domain.ocaml4.ml: -------------------------------------------------------------------------------- 1 | let recommended_domain_count () = 1 2 | let self () = 0 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: bench 2 | 3 | bench: 4 | @dune exec --release -- bench/main.exe -budget 1 5 | -------------------------------------------------------------------------------- /kcas_data.opam.template: -------------------------------------------------------------------------------- 1 | doc: "https://ocaml-multicore.github.io/kcas/doc/kcas_data/Kcas_data/" 2 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package kcas_data) 3 | (deps 4 | (package kcas) 5 | (package kcas_data)) 6 | (libraries domain_shims) 7 | (files README.md)) 8 | -------------------------------------------------------------------------------- /.prettierrc: -------------------------------------------------------------------------------- 1 | { 2 | "arrowParens": "avoid", 3 | "bracketSpacing": false, 4 | "printWidth": 80, 5 | "semi": false, 6 | "singleQuote": true, 7 | "proseWrap": "always" 8 | } 9 | -------------------------------------------------------------------------------- /test/kcas/util.ml: -------------------------------------------------------------------------------- 1 | let iter_factor = 2 | let factor b = if b then 10 else 1 in 3 | factor (64 <= Sys.word_size) 4 | * factor (Sys.backend_type = Native) 5 | * factor (1 < Domain.recommended_domain_count ()) 6 | -------------------------------------------------------------------------------- /doc/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package kcas_data) 3 | (deps 4 | (package kcas) 5 | (package kcas_data)) 6 | (enabled_if 7 | (>= %{ocaml_version} 5.0.0)) 8 | (files gkmz-with-read-only-cmp-ops.md scheduler-interop.md)) 9 | -------------------------------------------------------------------------------- /src/kcas_data/kcas_data.ml: -------------------------------------------------------------------------------- 1 | module Hashtbl = Hashtbl 2 | module Queue = Queue 3 | module Stack = Stack 4 | module Mvar = Mvar 5 | module Promise = Promise 6 | module Dllist = Dllist 7 | module Accumulator = Accumulator 8 | -------------------------------------------------------------------------------- /test/kcas_data/util.ml: -------------------------------------------------------------------------------- 1 | let iter_factor = 2 | let factor b = if b then 10 else 1 in 3 | factor (64 <= Sys.word_size) 4 | * factor (Sys.backend_type = Native) 5 | * factor (1 < Domain.recommended_domain_count ()) 6 | -------------------------------------------------------------------------------- /test/kcas/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names test ms_queue_test threads loc_modes) 3 | (libraries 4 | alcotest 5 | kcas 6 | domain-local-timeout 7 | threads.posix 8 | unix 9 | domain_shims) 10 | (package kcas)) 11 | -------------------------------------------------------------------------------- /test/kcas_data/xt_stack.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type 'a t 4 | 5 | val create : unit -> 'a t 6 | val is_empty : xt:'x Xt.t -> 'a t -> bool 7 | val push : xt:'x Xt.t -> 'a t -> 'a -> unit 8 | val pop_opt : xt:'x Xt.t -> 'a t -> 'a option 9 | -------------------------------------------------------------------------------- /test/kcas/barrier.ml: -------------------------------------------------------------------------------- 1 | type t = { counter : int Atomic.t; total : int } 2 | 3 | let make total = { counter = Atomic.make 0; total } 4 | 5 | let await { counter; total } = 6 | Atomic.incr counter; 7 | while Atomic.get counter < total do 8 | Domain.cpu_relax () 9 | done 10 | -------------------------------------------------------------------------------- /src/kcas/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name kcas) 3 | (public_name kcas) 4 | (libraries domain-local-await domain-local-timeout backoff multicore-magic)) 5 | 6 | (mdx 7 | (package kcas) 8 | (deps 9 | (package kcas)) 10 | (libraries kcas backoff domain_shims) 11 | (files kcas.mli)) 12 | -------------------------------------------------------------------------------- /src/kcas_data/bits.mli: -------------------------------------------------------------------------------- 1 | val max_0 : int -> int 2 | (** [max_0 n] is equivalent to [Int.max 0 n]. *) 3 | 4 | val is_pow_2 : int -> bool 5 | (** [is_pow_2 n] determines [n] is zero or of the form [1 lsl i] for some [i]. 6 | *) 7 | 8 | val ceil_pow_2_minus_1 : int -> int 9 | val ceil_pow_2 : int -> int 10 | -------------------------------------------------------------------------------- /test/kcas_data/xt_linked_queue.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type 'a t 4 | 5 | val create : unit -> 'a t 6 | val is_empty : xt:'x Xt.t -> 'a t -> bool 7 | val push_front : xt:'x Xt.t -> 'a t -> 'a -> unit 8 | val push_back : xt:'x Xt.t -> 'a t -> 'a -> unit 9 | val pop_front : xt:'x Xt.t -> 'a t -> 'a option 10 | -------------------------------------------------------------------------------- /test/kcas_data/xt_stack.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type 'a t = 'a list Loc.t 4 | 5 | let create () = Loc.make [] 6 | let is_empty ~xt s = Xt.get ~xt s == [] 7 | let push ~xt s x = Xt.modify ~xt s @@ List.cons x 8 | 9 | let pop_opt ~xt s = 10 | match Xt.update ~xt s @@ function [] -> [] | _ :: xs -> xs with 11 | | x :: _ -> Some x 12 | | [] -> None 13 | -------------------------------------------------------------------------------- /bench.Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:debian-ocaml-5.3 2 | WORKDIR /bench-dir 3 | RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam 4 | RUN sudo chown opam . 5 | COPY *.opam ./ 6 | RUN opam remote add origin https://github.com/ocaml/opam-repository.git && \ 7 | opam update 8 | RUN opam pin -yn --with-version=dev . 9 | RUN opam install -y --deps-only --with-test . 10 | COPY . ./ 11 | RUN opam exec -- dune build --release bench/main.exe 12 | -------------------------------------------------------------------------------- /test/kcas_data/lru_cache_intf.ml: -------------------------------------------------------------------------------- 1 | module type Ops = sig 2 | type ('k, 'v) t 3 | type ('x, 'fn) fn 4 | type ('x, 'fn) blocking_fn 5 | 6 | val capacity_of : ('x, ('k, 'v) t -> int) fn 7 | val set_capacity : ('x, ('k, 'v) t -> int -> unit) fn 8 | val get_opt : ('x, ('k, 'v) t -> 'k -> 'v option) fn 9 | val set_blocking : ('x, ('k, 'v) t -> 'k -> 'v -> unit) blocking_fn 10 | val remove : ('x, ('k, 'v) t -> 'k -> unit) fn 11 | end 12 | -------------------------------------------------------------------------------- /src/kcas_data/magic_option.mli: -------------------------------------------------------------------------------- 1 | (** Unboxed option using a unique block to identify {!none}. *) 2 | 3 | type !'a t 4 | 5 | val none : 'a t 6 | val some : 'a -> 'a t 7 | val is_none : 'a t -> bool 8 | val is_some : 'a t -> bool 9 | val get_or_retry : 'a t -> 'a 10 | val put_or_retry : 'a -> 'a t -> 'a t 11 | val take_or_retry : 'a t -> 'a t 12 | val get_unsafe : 'a t -> 'a 13 | val to_option : 'a t -> 'a option 14 | val of_option : 'a option -> 'a t 15 | -------------------------------------------------------------------------------- /src/kcas_data/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name kcas_data) 3 | (public_name kcas_data) 4 | (libraries 5 | (re_export kcas) 6 | multicore-magic)) 7 | 8 | (rule 9 | (targets domain.ml) 10 | (deps domain.ocaml4.ml) 11 | (enabled_if 12 | (< %{ocaml_version} 5.0.0)) 13 | (action 14 | (progn 15 | (copy domain.ocaml4.ml domain.ml)))) 16 | 17 | (mdx 18 | (package kcas_data) 19 | (deps 20 | (package kcas) 21 | (package kcas_data)) 22 | (libraries kcas kcas_data) 23 | (files kcas_data.mli)) 24 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | This project has adopted the 4 | [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). 5 | 6 | # Enforcement 7 | 8 | This project follows the OCaml Code of Conduct 9 | [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). 10 | 11 | To report any violations, please contact: 12 | 13 | - Carine Morel 14 | - Sudha Parimala 15 | -------------------------------------------------------------------------------- /test/kcas_data/lru_cache.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | open Kcas_data 3 | 4 | type ('k, 'v) t 5 | 6 | val create : ?hashed_type:'k Hashtbl.hashed_type -> int -> ('k, 'v) t 7 | 8 | module Xt : 9 | Lru_cache_intf.Ops 10 | with type ('k, 'v) t := ('k, 'v) t 11 | with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn 12 | with type ('x, 'fn) blocking_fn := xt:'x Xt.t -> 'fn 13 | 14 | include 15 | Lru_cache_intf.Ops 16 | with type ('k, 'v) t := ('k, 'v) t 17 | with type ('x, 'fn) fn := 'fn 18 | with type ('x, 'fn) blocking_fn := ?timeoutf:float -> 'fn 19 | -------------------------------------------------------------------------------- /test/kcas_data/stm_run/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (enabled_if %{lib-available:qcheck-stm.domain}) 3 | (action 4 | (copy stm_run.ocaml5.ml stm_run.ml))) 5 | 6 | (rule 7 | (enabled_if 8 | (not %{lib-available:qcheck-stm.domain})) 9 | (action 10 | (copy stm_run.ocaml4.ml stm_run.ml))) 11 | 12 | (library 13 | (name stm_run) 14 | (libraries 15 | qcheck-core 16 | qcheck-core.runner 17 | qcheck-stm.stm 18 | qcheck-stm.sequential 19 | qcheck-stm.thread 20 | unix 21 | (select 22 | empty.ml 23 | from 24 | (qcheck-stm.domain -> empty.ocaml5.ml) 25 | (-> empty.ocaml4.ml)))) 26 | -------------------------------------------------------------------------------- /test/kcas_data/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names 3 | accumulator_test_stm 4 | dllist_test 5 | dllist_test_stm 6 | hashtbl_test 7 | hashtbl_test_stm 8 | linearizable_chaining_example 9 | lru_cache_example 10 | mvar_test 11 | queue_test 12 | queue_test_stm 13 | stack_test 14 | stack_test_stm 15 | xt_test) 16 | (libraries 17 | alcotest 18 | kcas 19 | kcas_data 20 | domain_shims 21 | qcheck-core 22 | qcheck-stm.stm 23 | stm_run 24 | (select 25 | empty.ml 26 | from 27 | (qcheck-stm.domain -> empty.ocaml5.ml) 28 | (-> empty.ocaml4.ml))) 29 | (package kcas_data)) 30 | -------------------------------------------------------------------------------- /bench/main.ml: -------------------------------------------------------------------------------- 1 | let benchmarks = 2 | [ 3 | ("Kcas Loc", Bench_loc.run_suite); 4 | ("Kcas Xt", Bench_xt.run_suite); 5 | ("Kcas Xt read-only", Bench_xt_ro.run_suite); 6 | ("Kcas parallel CMP", Bench_parallel_cmp.run_suite); 7 | ("Kcas_data Accumulator", Bench_accumulator.run_suite); 8 | ("Kcas_data Dllist", Bench_dllist.run_suite); 9 | ("Kcas_data Hashtbl", Bench_hashtbl.run_suite); 10 | ("Kcas_data Mvar", Bench_mvar.run_suite); 11 | ("Kcas_data Queue", Bench_queue.run_suite); 12 | ("Kcas_data Stack", Bench_stack.run_suite); 13 | ] 14 | 15 | let () = Multicore_bench.Cmd.run ~benchmarks () 16 | -------------------------------------------------------------------------------- /test/kcas/threads.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | let await_between_threads () = 4 | let x = Loc.make 0 in 5 | let y = Loc.make 0 in 6 | 7 | let a_thread = 8 | () 9 | |> Thread.create @@ fun () -> 10 | Loc.get_as (fun x -> Retry.unless (x <> 0)) x; 11 | Loc.set y 22 12 | in 13 | 14 | Loc.set x 20; 15 | Loc.get_as (fun y -> Retry.unless (y <> 0)) y; 16 | 17 | Thread.join a_thread; 18 | 19 | assert (Loc.get x + Loc.get y = 42) 20 | 21 | let () = 22 | Alcotest.run "Threads" 23 | [ 24 | ( "await between threads", 25 | [ Alcotest.test_case "" `Quick await_between_threads ] ); 26 | ] 27 | -------------------------------------------------------------------------------- /HACKING.md: -------------------------------------------------------------------------------- 1 | ### Formatting 2 | 3 | This project uses [ocamlformat](https://github.com/ocaml-ppx/ocamlformat) (for 4 | OCaml) and [prettier](https://prettier.io/) (for Markdown). 5 | 6 | ### To make a new release 7 | 8 | 1. Update [CHANGES.md](CHANGES.md). 9 | 2. Run `dune-release tag VERSION` to create a tag for the new `VERSION`. 10 | 3. Run `dune-release distrib` to create package locally. 11 | 4. Run `dune-release publish distrib` to create release on GitHub. 12 | 5. Run `opam publish --tag=VERSION` to create PR to 13 | [opam-repository](https://github.com/ocaml/opam-repository). 14 | 6. Run `./update-gh-pages-for-tag VERSION` to update the online documentation. 15 | -------------------------------------------------------------------------------- /src/kcas_data/magic_option.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type 'a t = 'a 4 | 5 | let none = ref () 6 | let none = Obj.magic none 7 | 8 | external some : 'a -> 'a t = "%identity" 9 | 10 | let[@inline] is_none x = x == none 11 | let[@inline] is_some x = x != none 12 | let[@inline] get_or_retry x = if is_none x then Retry.later () else x 13 | let[@inline] put_or_retry v x = if is_none x then some v else Retry.later () 14 | let[@inline] take_or_retry x = if is_none x then Retry.later () else none 15 | 16 | external get_unsafe : 'a t -> 'a = "%identity" 17 | 18 | let[@inline] to_option x = if is_none x then None else Some x 19 | let[@inline] of_option = function None -> none | Some x -> some x 20 | -------------------------------------------------------------------------------- /test/kcas_data/mvar_test.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | open Kcas_data 3 | 4 | let basics () = 5 | let mv = Mvar.create (Some 101) in 6 | assert (not (Mvar.is_empty mv)); 7 | assert (Mvar.take mv = 101); 8 | assert (Mvar.is_empty mv); 9 | assert (Mvar.take_opt mv = None); 10 | Mvar.put mv 42; 11 | let running = Mvar.create None in 12 | let d = 13 | Domain.spawn @@ fun () -> 14 | Mvar.put running (); 15 | Xt.commit { tx = Mvar.Xt.put mv 76 } 16 | in 17 | assert (Mvar.take running = ()); 18 | assert (Xt.commit { tx = Mvar.Xt.take mv } = 42); 19 | Domain.join d; 20 | assert (Mvar.take mv = 76) 21 | 22 | let () = 23 | Alcotest.run "Mvar" [ ("basics", [ Alcotest.test_case "" `Quick basics ]) ] 24 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (enabled_if 3 | (< %{ocaml_version} 5.0.0)) 4 | (action 5 | (copy domain.ocaml4.ml domain.ml))) 6 | 7 | (test 8 | (name main) 9 | (package kcas_data) 10 | (action 11 | (progn 12 | (run %{test} -brief "Kcas Loc") 13 | (run %{test} -brief "Kcas Xt") 14 | (run %{test} -brief "Kcas Xt read-only") 15 | (run %{test} -brief "Kcas parallel CMP") 16 | (run %{test} -brief "Kcas_data Accumulator") 17 | (run %{test} -brief "Kcas_data Dllist") 18 | (run %{test} -brief "Kcas_data Hashtbl") 19 | (run %{test} -brief "Kcas_data Mvar") 20 | (run %{test} -brief "Kcas_data Queue") 21 | (run %{test} -brief "Kcas_data Stack"))) 22 | (libraries kcas_data multicore-bench backoff multicore-magic)) 23 | -------------------------------------------------------------------------------- /src/kcas_data/elems.mli: -------------------------------------------------------------------------------- 1 | (** Basically a list where each node includes length, the empty list is a cyclic 2 | node, and conversions to sequences are performed lazily. *) 3 | 4 | type !'a t 5 | 6 | val empty : 'a t 7 | val tl_safe : 'a t -> 'a t 8 | val tl_or_retry : 'a t -> 'a t 9 | val length : 'a t -> int 10 | val cons : 'a -> 'a t -> 'a t 11 | val hd_opt : 'a t -> 'a option 12 | val hd_or_retry : 'a t -> 'a 13 | val hd_unsafe : 'a t -> 'a 14 | val iter : ('a -> unit) -> 'a t -> unit 15 | val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b 16 | val rev : 'a t -> 'a t 17 | val prepend_to_seq : 'a t -> 'a Seq.t -> 'a Seq.t 18 | val to_seq : 'a t -> 'a Seq.t 19 | val of_seq_rev : 'a Seq.t -> 'a t 20 | val rev_prepend_to_seq : 'a t -> 'a Seq.t -> 'a Seq.t 21 | -------------------------------------------------------------------------------- /test/kcas_data/stm_run/stm_run.ocaml4.ml: -------------------------------------------------------------------------------- 1 | include Intf 2 | 3 | let count = 4 | let factor b = if b then 10 else 1 in 5 | factor (64 <= Sys.word_size) * factor (Sys.backend_type = Native) * 10 6 | 7 | let run ?(verbose = true) ?(count = count) ?(budgetf = 60.0) ~name ?make_domain 8 | (module Spec : STM.Spec) = 9 | let module Seq = STM_sequential.Make (Spec) in 10 | let module Con = STM_thread.Make (Spec) [@alert "-experimental"] in 11 | Util.run_with_budget ~budgetf ~count @@ fun count -> 12 | [ 13 | [ Seq.agree_test ~count ~name:(name ^ " sequential") ]; 14 | (match make_domain with 15 | | None -> [ Con.agree_test_conc ~count ~name:(name ^ " concurrent") ] 16 | | Some _ -> []); 17 | ] 18 | |> List.concat 19 | |> QCheck_base_runner.run_tests ~verbose 20 | -------------------------------------------------------------------------------- /src/kcas_data/accumulator_intf.ml: -------------------------------------------------------------------------------- 1 | module type Ops = sig 2 | type t 3 | type ('x, 'fn) fn 4 | 5 | val add : ('x, t -> int -> unit) fn 6 | (** [add a n] increments the value of the accumulator [a] by [n]. [add] 7 | operations can be performed scalably in parallel. *) 8 | 9 | val incr : ('x, t -> unit) fn 10 | (** [incr a] is equivalent to [add a 1]. *) 11 | 12 | val decr : ('x, t -> unit) fn 13 | (** [decr a] is equivalent to [add a (-1)]. *) 14 | 15 | val get : ('x, t -> int) fn 16 | (** [get a] returns the current value of the accumulator. 17 | 18 | {b CAUTION}: Performing a [get] is expensive and can limit scalability. *) 19 | 20 | val set : ('x, t -> int -> unit) fn 21 | (** [set a n] sets the current value of the accumulator [a] to [n]. *) 22 | end 23 | -------------------------------------------------------------------------------- /src/kcas_data/accumulator.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | (** Scalable accumulator. 4 | 5 | A scalable accumulator can be used to scalably accumulate an integer value 6 | in parallel as long as the accumulated value is read infrequently. *) 7 | 8 | (** {1 Common interface} *) 9 | 10 | type t 11 | (** The type of a scalable accumulator. *) 12 | 13 | val make : int -> t 14 | (** [make n] returns a new accumulator whose initial value is [n]. *) 15 | 16 | (** {1 Compositional interface} *) 17 | 18 | module Xt : 19 | Accumulator_intf.Ops 20 | with type t := t 21 | with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn 22 | (** Explicit transaction log passing on accumulators. *) 23 | 24 | (** {1 Non-compositional interface} *) 25 | 26 | include Accumulator_intf.Ops with type t := t with type ('x, 'fn) fn := 'fn 27 | -------------------------------------------------------------------------------- /test/kcas_data/stack_test.ml: -------------------------------------------------------------------------------- 1 | open Kcas_data 2 | 3 | let basics () = 4 | let s = Stack.create () in 5 | assert (Stack.length s = 0); 6 | assert (Stack.is_empty s); 7 | Stack.push 101 s; 8 | assert (not (Stack.is_empty s)); 9 | assert (Stack.top_opt s = Some 101); 10 | assert (Stack.length s = 1); 11 | let t = Stack.copy s in 12 | assert (Stack.pop_opt t = Some 101); 13 | Stack.push 42 s; 14 | Stack.swap s t; 15 | assert (Stack.pop_opt s = None); 16 | assert (List.of_seq (Stack.to_seq t) = [ 42; 101 ]); 17 | assert (Stack.top_opt t = Some 42); 18 | assert (Stack.length t = 2); 19 | assert (Stack.pop_opt t = Some 42); 20 | assert (Stack.pop_opt t = Some 101); 21 | assert (Stack.pop_opt t = None) 22 | 23 | let () = 24 | Alcotest.run "Stack" [ ("basics", [ Alcotest.test_case "" `Quick basics ]) ] 25 | -------------------------------------------------------------------------------- /src/kcas_data/bits.ml: -------------------------------------------------------------------------------- 1 | let is_pow_2 n = n land (n - 1) = 0 2 | 3 | let max_0 n = 4 | let m = n asr (Sys.int_size - 1) in 5 | n land lnot m 6 | 7 | let ceil_pow_2_minus_1 n = 8 | let n = Nativeint.of_int n in 9 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 1) in 10 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 2) in 11 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 4) in 12 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 8) in 13 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 16) in 14 | Nativeint.to_int 15 | (if Sys.int_size > 32 then 16 | Nativeint.logor n (Nativeint.shift_right_logical n 32) 17 | else n) 18 | 19 | let ceil_pow_2 n = 20 | if n <= 1 then 1 21 | else 22 | let n = n - 1 in 23 | let n = ceil_pow_2_minus_1 n in 24 | n + 1 25 | -------------------------------------------------------------------------------- /test/kcas_data/stm_run/util.ml: -------------------------------------------------------------------------------- 1 | let run_with_budget ~budgetf ~count run = 2 | let state = Random.State.make_self_init () in 3 | let start = Unix.gettimeofday () in 4 | let rec loop ~total n = 5 | let current = Unix.gettimeofday () in 6 | if current -. start <= budgetf && total < count then begin 7 | let count = 8 | if total = 0 then n 9 | else 10 | let per_test = (current -. start) /. Float.of_int total in 11 | let max_count = 12 | Float.to_int ((start +. budgetf -. current) /. per_test) 13 | in 14 | Int.min (Int.min n (count - total)) max_count |> Int.max 32 15 | in 16 | let seed = Random.State.full_int state Int.max_int in 17 | QCheck_base_runner.set_seed seed; 18 | let error_code = run count in 19 | if error_code = 0 then loop ~total:(total + count) (n * 2) else error_code 20 | end 21 | else 0 22 | in 23 | loop ~total:0 32 24 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, KC Sivaramakrishnan 2 | Copyright (c) 2017, Nicolas ASSOUAD 3 | Copyright (c) 2018, Sadiq Jaffer 4 | Copyright (c) 2023, Vesa Karvonen 5 | 6 | Permission to use, copy, modify, and/or distribute this software for any 7 | purpose with or without fee is hereby granted, provided that the above 8 | copyright notice and this permission notice appear in all copies. 9 | 10 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | -------------------------------------------------------------------------------- /bench/bench_xt.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | open Multicore_bench 3 | 4 | let run_one ~budgetf ?(n_locs = 2) 5 | ?(n_iter = 15 * (9 - n_locs) * Util.iter_factor) () = 6 | let locs = Loc.make_array n_locs 0 in 7 | let rec loop ~xt i = 8 | Xt.incr ~xt (Array.unsafe_get locs i); 9 | let i = i - 1 in 10 | if 0 <= i then loop ~xt i 11 | in 12 | let tx ~xt = 13 | let i = n_locs - 1 in 14 | if 0 <= i then loop ~xt i 15 | in 16 | 17 | let init _ = () in 18 | let work _ () = 19 | let rec loop i = 20 | if i > 0 then begin 21 | Xt.commit { tx }; 22 | loop (i - 1) 23 | end 24 | in 25 | loop n_iter 26 | in 27 | 28 | let config = Printf.sprintf "%d loc tx" n_locs in 29 | 30 | Times.record ~budgetf ~n_domains:1 ~init ~work () 31 | |> Times.to_thruput_metrics ~n:n_iter ~singular:"transaction" ~config 32 | 33 | let run_suite ~budgetf = 34 | [ 0; 1; 2; 4; 8 ] 35 | |> List.concat_map @@ fun n_locs -> run_one ~budgetf ~n_locs () 36 | -------------------------------------------------------------------------------- /bench/bench_xt_ro.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | open Multicore_bench 3 | 4 | let run_one ~budgetf ?(n_locs = 2) 5 | ?(n_iter = 20 * (9 - n_locs) * Util.iter_factor) () = 6 | let locs = Loc.make_array n_locs 0 in 7 | let rec loop ~xt s i = 8 | let s = s + Xt.get ~xt (Array.unsafe_get locs i) in 9 | let i = i - 1 in 10 | if 0 <= i then loop ~xt s i else s 11 | in 12 | let tx ~xt = 13 | let i = n_locs - 1 in 14 | if 0 <= i then loop ~xt 0 i |> ignore 15 | in 16 | 17 | let init _ = () in 18 | let work _ () = 19 | let rec loop i = 20 | if i > 0 then begin 21 | Xt.commit { tx }; 22 | loop (i - 1) 23 | end 24 | in 25 | loop n_iter 26 | in 27 | 28 | let config = Printf.sprintf "%d loc tx" n_locs in 29 | 30 | Times.record ~budgetf ~n_domains:1 ~init ~work () 31 | |> Times.to_thruput_metrics ~n:n_iter ~singular:"transaction" ~config 32 | 33 | let run_suite ~budgetf = 34 | [ 0; 1; 2; 4; 8 ] 35 | |> List.concat_map @@ fun n_locs -> run_one ~budgetf ~n_locs () 36 | -------------------------------------------------------------------------------- /test/kcas_data/queue_test.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | open Kcas_data 3 | 4 | let basics () = 5 | let q = Queue.create () in 6 | Queue.add 101 q; 7 | let tx ~xt = 8 | Queue.Xt.add ~xt 42 q; 9 | assert (Queue.Xt.take_opt ~xt q = Some 101); 10 | assert (Queue.Xt.length ~xt q = 1); 11 | assert (Queue.Xt.take_opt ~xt q = Some 42); 12 | assert (Queue.Xt.take_opt ~xt q = None) 13 | in 14 | Xt.commit { tx }; 15 | let q = Queue.create () in 16 | assert (Queue.length q = 0); 17 | assert (Queue.is_empty q); 18 | Queue.add 101 q; 19 | assert (Queue.length q = 1); 20 | assert (not (Queue.is_empty q)); 21 | let r = Queue.copy q in 22 | assert (Queue.peek_opt q = Some 101); 23 | Queue.add 42 q; 24 | assert (List.of_seq (Queue.to_seq q) = [ 101; 42 ]); 25 | Queue.swap q r; 26 | assert (Queue.peek_opt q = Some 101); 27 | assert (Queue.take_opt q = Some 101); 28 | assert (Queue.take_opt q = None); 29 | assert (Queue.take_opt r = Some 101); 30 | assert (Queue.take_opt r = Some 42); 31 | assert (Queue.take_opt r = None) 32 | 33 | let () = 34 | Alcotest.run "Queue" [ ("basics", [ Alcotest.test_case "" `Quick basics ]) ] 35 | -------------------------------------------------------------------------------- /test/kcas_data/xt_linked_queue.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type 'a t = { front : 'a node Loc.t; back : 'a node Loc.t } 4 | and 'a node = Nil | Node of 'a node Loc.t * 'a 5 | 6 | let create () = { front = Loc.make Nil; back = Loc.make Nil } 7 | let is_empty ~xt queue = Xt.get ~xt queue.front == Nil 8 | 9 | let push_front ~xt queue value = 10 | let next = Loc.make Nil in 11 | let node = Node (next, value) in 12 | match Xt.exchange ~xt queue.front node with 13 | | Nil -> Xt.set ~xt queue.back node 14 | | succ -> Xt.set ~xt next succ 15 | 16 | let push_back ~xt queue value = 17 | let node = Node (Loc.make Nil, value) in 18 | match Xt.exchange ~xt queue.back node with 19 | | Nil -> Xt.set ~xt queue.front node 20 | | Node (next, _) -> Xt.set ~xt next node 21 | 22 | let pop_front ~xt queue = 23 | match Xt.get ~xt queue.front with 24 | | Nil -> None 25 | | Node (next, value) -> begin 26 | match Xt.get ~xt next with 27 | | Nil -> 28 | Xt.set ~xt queue.front Nil; 29 | Xt.set ~xt queue.back Nil; 30 | Some value 31 | | node -> 32 | Xt.set ~xt queue.front node; 33 | Some value 34 | end 35 | -------------------------------------------------------------------------------- /test/kcas_data/stm_run/stm_run.ocaml5.ml: -------------------------------------------------------------------------------- 1 | include Intf 2 | 3 | let count = 4 | let factor b = if b then 10 else 1 in 5 | factor (64 <= Sys.word_size) 6 | * factor (Sys.backend_type = Native) 7 | * factor (1 < Domain.recommended_domain_count ()) 8 | 9 | let run (type cmd state sut) ?(verbose = true) ?(count = count) 10 | ?(budgetf = 60.0) ~name ?make_domain 11 | (module Spec : STM.Spec 12 | with type cmd = cmd 13 | and type state = state 14 | and type sut = sut) = 15 | let module Seq = STM_sequential.Make (Spec) in 16 | let module Dom = struct 17 | module Spec = Spec 18 | include STM_domain.Make (Spec) 19 | end in 20 | Util.run_with_budget ~budgetf ~count @@ fun count -> 21 | [ 22 | [ Seq.agree_test ~count ~name:(name ^ " sequential") ]; 23 | (match make_domain with 24 | | None -> [ Dom.agree_test_par ~count ~name:(name ^ " parallel") ] 25 | | Some make_domain -> 26 | make_domain ~count ~name 27 | (module Dom : STM_domain 28 | with type Spec.cmd = cmd 29 | and type Spec.state = state 30 | and type Spec.sut = sut)); 31 | ] 32 | |> List.concat 33 | |> QCheck_base_runner.run_tests ~verbose 34 | -------------------------------------------------------------------------------- /bench/bench_accumulator.ml: -------------------------------------------------------------------------------- 1 | open Kcas_data 2 | open Multicore_bench 3 | 4 | let run_one ~budgetf ~n_domains ?(n_ops = 180 * Util.iter_factor) () = 5 | let n_ops = n_ops * n_domains in 6 | 7 | let t = Accumulator.make 0 in 8 | 9 | let n_ops_todo = Countdown.create ~n_domains () in 10 | 11 | let init _ = Countdown.non_atomic_set n_ops_todo n_ops in 12 | let work domain_index () = 13 | let rec work () = 14 | let n = Countdown.alloc n_ops_todo ~domain_index ~batch:1000 in 15 | if n <> 0 then 16 | let rec loop n = 17 | if 0 < n then begin 18 | Accumulator.incr t; 19 | Accumulator.decr t; 20 | loop (n - 2) 21 | end 22 | else work () 23 | in 24 | loop n 25 | in 26 | work () 27 | in 28 | 29 | let config = 30 | Printf.sprintf "%d worker%s, 0%% reads" n_domains 31 | (if n_domains = 1 then "" else "s") 32 | in 33 | 34 | Times.record ~budgetf ~n_domains ~init ~work () 35 | |> Times.to_thruput_metrics ~n:n_ops ~config ~singular:"operation" 36 | 37 | let run_suite ~budgetf = 38 | [ 1; 2; 4; 8 ] 39 | |> List.concat_map @@ fun n_domains -> 40 | if Domain.recommended_domain_count () < n_domains then [] 41 | else run_one ~n_domains ~budgetf () 42 | -------------------------------------------------------------------------------- /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | name: build-and-test 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: 7 | - main 8 | 9 | jobs: 10 | build-windows: 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | ocaml-compiler: 15 | - ocaml.5.0.0,ocaml-option-mingw 16 | - ocaml.5.1.1,ocaml-option-mingw 17 | - ocaml.5.2.1,ocaml-option-mingw 18 | - ocaml.5.3.0,ocaml-option-mingw 19 | 20 | runs-on: windows-latest 21 | 22 | env: 23 | QCHECK_MSG_INTERVAL: '60' 24 | 25 | steps: 26 | - name: Check out code 27 | uses: actions/checkout@v3 28 | 29 | - name: Set up OCaml 30 | uses: ocaml/setup-ocaml@v3 31 | with: 32 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 33 | opam-repositories: | 34 | dra27: https://github.com/dra27/opam-repository.git#windows-5.0 35 | default: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset 36 | standard: https://github.com/ocaml/opam-repository.git 37 | 38 | - name: Install dependencies 39 | run: opam install . --deps-only --with-test 40 | 41 | - name: Build 42 | run: opam exec -- dune build 43 | 44 | - name: Test 45 | run: opam exec -- dune runtest 46 | -------------------------------------------------------------------------------- /test/kcas_data/xt_test.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | module Q = Xt_linked_queue 3 | module P = Kcas_data.Queue 4 | module S = Xt_stack 5 | 6 | let basics () = 7 | let p = P.create () and q = Q.create () and s = S.create () in 8 | 9 | (* Populate [p] with two items atomically *) 10 | let tx ~xt = 11 | P.Xt.add ~xt 4 p; 12 | P.Xt.add ~xt 1 p 13 | in 14 | Xt.commit { tx }; 15 | 16 | Xt.commit { tx = P.Xt.add 3 p }; 17 | 18 | assert (not (Xt.commit { tx = P.Xt.is_empty p })); 19 | 20 | (* Transfer item from [p] queue to [q] queue atomically *) 21 | let tx ~xt = P.Xt.take_opt ~xt p |> Option.iter @@ Q.push_back ~xt q in 22 | Xt.commit { tx }; 23 | 24 | assert (Xt.commit { tx = Q.pop_front q } = Some 4); 25 | assert (Xt.commit { tx = Q.is_empty q }); 26 | 27 | (* Transfer item from queue [p] to stack [s] atomically *) 28 | let tx ~xt = P.Xt.take_opt ~xt p |> Option.iter @@ fun x -> S.push ~xt s x in 29 | Xt.commit { tx }; 30 | 31 | assert (Xt.commit { tx = S.pop_opt s } = Some 1); 32 | assert (Xt.commit { tx = P.Xt.take_opt p } = Some 3); 33 | assert (Xt.commit { tx = P.Xt.is_empty p }); 34 | 35 | Xt.commit { tx = Q.push_front q 101 }; 36 | assert (not (Xt.commit { tx = Q.is_empty q })) 37 | 38 | let () = 39 | Alcotest.run "Transactions" 40 | [ ("basics", [ Alcotest.test_case "" `Quick basics ]) ] 41 | -------------------------------------------------------------------------------- /src/kcas_data/mvar.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | (** Synchronizing variable. 4 | 5 | A synchronizing variable is essentially equivalent to a ['a option Loc.t] 6 | with blocking semantics on both {!take} and {!put}. 7 | 8 | {b NOTE}: The current implementation is not guaranteed to be fair or 9 | scalable. In other words, when multiple producers block on {!put} or 10 | multiple consumers block on {!take} the operations are not queued and it is 11 | possible for a particular producer or consumer to starve. *) 12 | 13 | (** {1 Common interface} *) 14 | 15 | type !'a t 16 | (** The type of a synchronizing variable that may contain a value of type ['a]. 17 | *) 18 | 19 | val create : 'a option -> 'a t 20 | (** [create x_opt] returns a new synchronizing variable that will either be 21 | empty when [x_opt] is [None] or full when [x_opt] is [Some x]. *) 22 | 23 | (** {1 Compositional interface} *) 24 | 25 | module Xt : 26 | Mvar_intf.Ops 27 | with type 'a t := 'a t 28 | with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn 29 | with type ('x, 'fn) blocking_fn := xt:'x Xt.t -> 'fn 30 | (** Explicit transaction passing on synchronizing variables. *) 31 | 32 | (** {1 Non-compositional interface} *) 33 | 34 | include 35 | Mvar_intf.Ops 36 | with type 'a t := 'a t 37 | with type ('x, 'fn) fn := 'fn 38 | with type ('x, 'fn) blocking_fn := ?timeoutf:float -> 'fn 39 | -------------------------------------------------------------------------------- /src/kcas_data/promise_intf.ml: -------------------------------------------------------------------------------- 1 | module type Ops = sig 2 | type !+'a t 3 | type !-'a u 4 | type 'a or_exn 5 | type ('x, 'fn) fn 6 | type ('x, 'fn) blocking_fn 7 | 8 | val resolve : ('x, 'a u -> 'a -> unit) fn 9 | (** [resolve u v] resolves the promise corresponding to the resolver [u] to 10 | the value [v]. Any awaiters of the corresponding promise are then 11 | unblocked. *) 12 | 13 | val await : ('x, 'a t -> 'a) blocking_fn 14 | (** [await t] either immediately returns the resolved value of the promise [t] 15 | or blocks until the promise [t] is resolved. *) 16 | 17 | val peek : ('x, 'a t -> 'a option) fn 18 | (** [peek t] immediately returns either the resolved value of the promise [t] 19 | or [None] in case the promise hasn't yet been resolved. *) 20 | 21 | val is_resolved : ('x, 'a t -> bool) fn 22 | (** [is_resolved t] determines whether the promise [t] has already been 23 | resolved. *) 24 | 25 | (** {2 Result promises} *) 26 | 27 | val await_exn : ('x, 'a or_exn -> 'a) blocking_fn 28 | (** [await_exn t] is equivalent to 29 | [match await t with v -> v | exception e -> raise e]. *) 30 | 31 | val resolve_ok : ('x, ('a, 'b) result u -> 'a -> unit) fn 32 | (** [resolve_ok u v] is equivalent to [resolve u (Ok v)]. *) 33 | 34 | val resolve_error : ('x, ('a, 'b) result u -> 'b -> unit) fn 35 | (** [resolve_error u e] is equivalent to [resolve u (Error e)]. *) 36 | end 37 | -------------------------------------------------------------------------------- /test/kcas_data/accumulator_test_stm.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open STM 3 | open Kcas_data 4 | 5 | module Spec = struct 6 | type cmd = Incr | Decr | Get | Set of int 7 | 8 | let show_cmd = function 9 | | Incr -> "Incr" 10 | | Decr -> "Decr" 11 | | Get -> "Get" 12 | | Set v -> "Set " ^ string_of_int v 13 | 14 | type state = int 15 | type sut = Accumulator.t 16 | 17 | let arb_cmd _s = 18 | [ 19 | Gen.return Incr; 20 | Gen.return Decr; 21 | Gen.return Get; 22 | Gen.map (fun i -> Set i) Gen.nat; 23 | ] 24 | |> Gen.oneof |> make ~print:show_cmd 25 | 26 | let init_state = 0 27 | let init_sut () = Accumulator.make 0 28 | let cleanup _ = () 29 | 30 | let next_state c s = 31 | match c with Incr -> s + 1 | Decr -> s - 1 | Get -> s | Set v -> v 32 | 33 | let precond _ _ = true 34 | 35 | let run c d = 36 | match c with 37 | | Incr -> Res (unit, Accumulator.incr d) 38 | | Decr -> Res (unit, Accumulator.decr d) 39 | | Get -> Res (int, Accumulator.get d) 40 | | Set v -> Res (unit, Accumulator.set d v) 41 | 42 | let postcond c (s : state) res = 43 | match (c, res) with 44 | | Incr, Res ((Unit, _), ()) -> true 45 | | Decr, Res ((Unit, _), ()) -> true 46 | | Set _, Res ((Unit, _), ()) -> true 47 | | Get, Res ((Int, _), res) -> res = s 48 | | _, _ -> false 49 | end 50 | 51 | let () = 52 | Stm_run.run ~count:1000 ~verbose:true ~name:"Accumulator" (module Spec) 53 | |> exit 54 | -------------------------------------------------------------------------------- /src/kcas_data/mvar_intf.ml: -------------------------------------------------------------------------------- 1 | module type Ops = sig 2 | type 'a t 3 | type ('x, 'fn) fn 4 | type ('x, 'fn) blocking_fn 5 | 6 | val is_empty : ('x, 'a t -> bool) fn 7 | (** [is_empty mv] determines whether the synchronizing variable [mv] contains 8 | a value or not. *) 9 | 10 | val put : ('x, 'a t -> 'a -> unit) blocking_fn 11 | (** [put mv x] fills the synchronizing variable [mv] with the value [v] or 12 | blocks until the variable becomes empty. *) 13 | 14 | val try_put : ('x, 'a t -> 'a -> bool) fn 15 | (** [try_put mv x] tries to fill the synchronizing variable [mv] with the 16 | value [v] and returns [true] on success or [false] in case the variable is 17 | full. *) 18 | 19 | val take : ('x, 'a t -> 'a) blocking_fn 20 | (** [take mv] removes and returns the current value of the synchronizing 21 | variable [mv] or blocks waiting until the variable is filled. *) 22 | 23 | val take_opt : ('x, 'a t -> 'a option) fn 24 | (** [take_opt mv] removes and returns the current value of the synchronizing 25 | variable [mv] or returns [None] in case the variable is empty. *) 26 | 27 | val peek : ('x, 'a t -> 'a) blocking_fn 28 | (** [peek mv] returns the current value of the synchronizing variable [mv] or 29 | blocks waiting until the variable is filled. *) 30 | 31 | val peek_opt : ('x, 'a t -> 'a option) fn 32 | (** [peek_opt mv] returns the current value of the synchronizing variable [mv] 33 | or returns [None] in case the variable is empty. *) 34 | end 35 | -------------------------------------------------------------------------------- /src/kcas_data/mvar.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type 'a t = 'a Magic_option.t Loc.t 4 | 5 | let create x_opt = Loc.make ~padded:true (Magic_option.of_option x_opt) 6 | 7 | module Xt = struct 8 | let is_empty ~xt mv = Magic_option.is_none (Xt.get ~xt mv) 9 | 10 | let try_put ~xt mv value = 11 | Magic_option.is_none 12 | (Xt.compare_and_swap ~xt mv Magic_option.none (Magic_option.some value)) 13 | 14 | let put ~xt mv value = Xt.modify ~xt mv (Magic_option.put_or_retry value) 15 | 16 | let take_opt ~xt mv = 17 | Magic_option.to_option (Xt.exchange ~xt mv Magic_option.none) 18 | 19 | let take ~xt mv = 20 | Magic_option.get_unsafe (Xt.update ~xt mv Magic_option.take_or_retry) 21 | 22 | let peek ~xt mv = Magic_option.get_or_retry (Xt.get ~xt mv) 23 | let peek_opt ~xt mv = Magic_option.to_option (Xt.get ~xt mv) 24 | end 25 | 26 | let is_empty mv = Magic_option.is_none (Loc.get mv) 27 | 28 | let put ?timeoutf mv value = 29 | (* Fenceless is safe as we always update. *) 30 | Loc.fenceless_modify ?timeoutf mv (Magic_option.put_or_retry value) 31 | 32 | let try_put mv value = 33 | Loc.compare_and_set mv Magic_option.none (Magic_option.some value) 34 | 35 | let take ?timeoutf mv = 36 | (* Fenceless is safe as we always update. *) 37 | Magic_option.get_unsafe 38 | (Loc.fenceless_update ?timeoutf mv Magic_option.take_or_retry) 39 | 40 | let take_opt mv = Magic_option.to_option (Loc.exchange mv Magic_option.none) 41 | let peek ?timeoutf mv = Loc.get_as ?timeoutf Magic_option.get_or_retry mv 42 | let peek_opt mv = Magic_option.to_option (Loc.get mv) 43 | -------------------------------------------------------------------------------- /bench/bench_parallel_cmp.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | open Multicore_bench 3 | 4 | let run_one ~budgetf ~n_domains ?(n_ops = 50 * Util.iter_factor) () = 5 | let n_ops = n_ops * n_domains in 6 | 7 | let a = Loc.make ~padded:true 10 in 8 | let b = Loc.make ~padded:true 52 in 9 | let xs = Loc.make_array ~padded:true n_domains 0 in 10 | 11 | let n_ops_todo = Countdown.create ~n_domains () in 12 | 13 | let init i = 14 | Countdown.non_atomic_set n_ops_todo n_ops; 15 | Array.unsafe_get xs i 16 | in 17 | let work domain_index x = 18 | let tx1 ~xt = 19 | let a = Xt.get ~xt a in 20 | let b = Xt.get ~xt b in 21 | Xt.set ~xt x (b - a) 22 | and tx2 ~xt = 23 | let a = Xt.get ~xt a in 24 | let b = Xt.get ~xt b in 25 | Xt.set ~xt x (a + b) 26 | in 27 | let rec work () = 28 | let n = Countdown.alloc n_ops_todo ~domain_index ~batch:1000 in 29 | if n <> 0 then begin 30 | for _ = 1 to n asr 1 do 31 | Xt.commit { tx = tx1 }; 32 | Xt.commit { tx = tx2 } 33 | done; 34 | work () 35 | end 36 | in 37 | work () 38 | in 39 | 40 | let config = 41 | Printf.sprintf "%d worker%s" n_domains (if n_domains = 1 then "" else "s") 42 | in 43 | 44 | Times.record ~budgetf ~n_domains ~init ~work () 45 | |> Times.to_thruput_metrics ~n:n_ops ~singular:"transaction" ~config 46 | 47 | let run_suite ~budgetf = 48 | [ 1; 2; 4 ] 49 | |> List.concat_map @@ fun n_domains -> 50 | if Domain.recommended_domain_count () < n_domains then [] 51 | else run_one ~budgetf ~n_domains () 52 | -------------------------------------------------------------------------------- /kcas_data.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: 4 | "Compositional lock-free data structures and primitives for communication and synchronization" 5 | description: 6 | "A library of compositional lock-free data structures and primitives for communication and synchronization implemented using kcas." 7 | maintainer: [ 8 | "Vesa Karvonen " 9 | "KC Sivaramakrishnan " 10 | ] 11 | authors: [ 12 | "KC Sivaramakrishnan " 13 | "Vesa Karvonen " 14 | ] 15 | license: "ISC" 16 | homepage: "https://github.com/ocaml-multicore/kcas" 17 | bug-reports: "https://github.com/ocaml-multicore/kcas/issues" 18 | depends: [ 19 | "dune" {>= "3.14"} 20 | "kcas" {= version} 21 | "multicore-magic" {>= "2.3.0"} 22 | "backoff" {>= "0.1.1" & with-test} 23 | "domain-local-await" {>= "1.0.1" & with-test} 24 | "domain_shims" {>= "0.1.0" & with-test} 25 | "multicore-bench" {>= "0.1.7" & with-test} 26 | "alcotest" {>= "1.8.0" & with-test} 27 | "qcheck-core" {>= "0.21.2" & with-test} 28 | "qcheck-stm" {>= "0.3" & with-test} 29 | "mdx" {>= "2.4.1" & with-test} 30 | "sherlodoc" {>= "0.2" & with-doc} 31 | "odoc" {>= "2.4.2" & with-doc} 32 | ] 33 | build: [ 34 | ["dune" "subst"] {dev} 35 | [ 36 | "dune" 37 | "build" 38 | "-p" 39 | name 40 | "-j" 41 | jobs 42 | "@install" 43 | "@runtest" {with-test} 44 | "@doc" {with-doc} 45 | ] 46 | ] 47 | dev-repo: "git+https://github.com/ocaml-multicore/kcas.git" 48 | doc: "https://ocaml-multicore.github.io/kcas/doc/kcas_data/Kcas_data/" 49 | -------------------------------------------------------------------------------- /test/kcas_data/stm_run/intf.ml: -------------------------------------------------------------------------------- 1 | module type STM_domain = sig 2 | module Spec : STM.Spec 3 | 4 | val check_obs : 5 | (Spec.cmd * STM.res) list -> 6 | (Spec.cmd * STM.res) list -> 7 | (Spec.cmd * STM.res) list -> 8 | Spec.state -> 9 | bool 10 | 11 | val all_interleavings_ok : 12 | Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool 13 | 14 | val arb_cmds_triple : 15 | int -> 16 | int -> 17 | (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary 18 | 19 | val arb_triple : 20 | int -> 21 | int -> 22 | (Spec.state -> Spec.cmd QCheck.arbitrary) -> 23 | (Spec.state -> Spec.cmd QCheck.arbitrary) -> 24 | (Spec.state -> Spec.cmd QCheck.arbitrary) -> 25 | (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary 26 | 27 | val arb_triple_asym : 28 | int -> 29 | int -> 30 | (Spec.state -> Spec.cmd QCheck.arbitrary) -> 31 | (Spec.state -> Spec.cmd QCheck.arbitrary) -> 32 | (Spec.state -> Spec.cmd QCheck.arbitrary) -> 33 | (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary 34 | 35 | val interp_sut_res : Spec.sut -> Spec.cmd list -> (Spec.cmd * STM.res) list 36 | val agree_prop_par : Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool 37 | 38 | val agree_prop_par_asym : 39 | Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool 40 | 41 | val agree_test_par : count:int -> name:string -> QCheck.Test.t 42 | val neg_agree_test_par : count:int -> name:string -> QCheck.Test.t 43 | val agree_test_par_asym : count:int -> name:string -> QCheck.Test.t 44 | val neg_agree_test_par_asym : count:int -> name:string -> QCheck.Test.t 45 | end 46 | -------------------------------------------------------------------------------- /kcas.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: 4 | "Software transactional memory based on lock-free multi-word compare-and-set" 5 | description: 6 | "A software transactional memory (STM) implementation based on an atomic lock-free multi-word compare-and-set (MCAS) algorithm enhanced with read-only compare operations and ability to block awaiting for changes." 7 | maintainer: [ 8 | "Vesa Karvonen " 9 | "KC Sivaramakrishnan " 10 | ] 11 | authors: [ 12 | "KC Sivaramakrishnan " 13 | "Vesa Karvonen " 14 | ] 15 | license: "ISC" 16 | homepage: "https://github.com/ocaml-multicore/kcas" 17 | bug-reports: "https://github.com/ocaml-multicore/kcas/issues" 18 | depends: [ 19 | "dune" {>= "3.14"} 20 | "ocaml" {>= "4.13.0"} 21 | "backoff" {>= "0.1.1"} 22 | "domain-local-await" {>= "1.0.1"} 23 | "domain-local-timeout" {>= "1.0.1"} 24 | "multicore-magic" {>= "2.3.0"} 25 | "domain_shims" {>= "0.1.0" & with-test} 26 | "alcotest" {>= "1.8.0" & with-test} 27 | "qcheck-core" {>= "0.21.2" & with-test} 28 | "qcheck-stm" {>= "0.3" & with-test} 29 | "mdx" {>= "2.4.1" & with-test} 30 | "sherlodoc" {>= "0.2" & with-doc} 31 | "odoc" {>= "2.4.2" & with-doc} 32 | ] 33 | build: [ 34 | ["dune" "subst"] {dev} 35 | [ 36 | "dune" 37 | "build" 38 | "-p" 39 | name 40 | "-j" 41 | jobs 42 | "@install" 43 | "@runtest" {with-test} 44 | "@doc" {with-doc} 45 | ] 46 | ] 47 | dev-repo: "git+https://github.com/ocaml-multicore/kcas.git" 48 | doc: "https://ocaml-multicore.github.io/kcas/doc/kcas/Kcas/" 49 | -------------------------------------------------------------------------------- /src/kcas_data/elems.ml: -------------------------------------------------------------------------------- 1 | type 'a t = { value : 'a; tl : 'a t; length : int } 2 | 3 | let rec empty = { value = Obj.magic (); tl = empty; length = 0 } 4 | let[@inline] singleton value = { value; tl = empty; length = 1 } 5 | let[@inline] tl_safe { tl; _ } = tl 6 | let[@inline] tl_or_retry t = if t != empty then t.tl else Kcas.Retry.later () 7 | let[@inline] length { length; _ } = length 8 | let[@inline] cons value tl = { value; tl; length = 1 + tl.length } 9 | let[@inline] hd_opt t = if t != empty then Some t.value else None 10 | let[@inline] hd_or_retry t = if t != empty then t.value else Kcas.Retry.later () 11 | let[@inline] hd_unsafe t = t.value 12 | let rec fold f a t = if t == empty then a else fold f (f a t.value) t.tl 13 | let[@inline] iter f t = fold (fun () x -> f x) () t 14 | 15 | let rec rev_append t tl = 16 | if t == empty then tl else rev_append t.tl @@ cons t.value tl 17 | 18 | let rev t = if t.length <= 1 then t else rev_append t.tl (singleton t.value) 19 | 20 | let rec prepend_to_seq t tl = 21 | if t == empty then tl else fun () -> Seq.Cons (t.value, prepend_to_seq t.tl tl) 22 | 23 | let to_seq t = prepend_to_seq t Seq.empty 24 | let of_seq_rev xs = Seq.fold_left (fun t x -> cons x t) empty xs 25 | 26 | let rev_prepend_to_seq t tl = 27 | if t.length <= 1 then prepend_to_seq t tl 28 | else 29 | let t = ref (Either.Left t) in 30 | fun () -> 31 | let t = 32 | match !t with 33 | | Left t' -> 34 | (* This is parallelism safe as the result is always equivalent. *) 35 | let t' = rev t' in 36 | t := Right t'; 37 | t' 38 | | Right t' -> t' 39 | in 40 | prepend_to_seq t tl () 41 | -------------------------------------------------------------------------------- /test/kcas_data/stack_test_stm.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open STM 3 | open Kcas_data 4 | 5 | module Spec = struct 6 | type cmd = Push of int | Pop_opt | Top_opt | Length 7 | 8 | let show_cmd = function 9 | | Push x -> "Push " ^ string_of_int x 10 | | Pop_opt -> "Pop_opt" 11 | | Top_opt -> "Top_opt" 12 | | Length -> "Length" 13 | 14 | type state = int list 15 | type sut = int Stack.t 16 | 17 | let arb_cmd _s = 18 | [ 19 | Gen.int |> Gen.map (fun x -> Push x); 20 | Gen.return Pop_opt; 21 | Gen.return Top_opt; 22 | Gen.return Length; 23 | ] 24 | |> Gen.oneof |> make ~print:show_cmd 25 | 26 | let init_state = [] 27 | let init_sut () = Stack.create () 28 | let cleanup _ = () 29 | 30 | let next_state c s = 31 | match c with 32 | | Push x -> x :: s 33 | | Pop_opt -> ( match s with [] -> [] | _ :: s -> s) 34 | | Top_opt -> s 35 | | Length -> s 36 | 37 | let precond _ _ = true 38 | 39 | let run c d = 40 | match c with 41 | | Push x -> Res (unit, Stack.push x d) 42 | | Pop_opt -> Res (option int, Stack.pop_opt d) 43 | | Top_opt -> Res (option int, Stack.top_opt d) 44 | | Length -> Res (int, Stack.length d) 45 | 46 | let postcond c (s : state) res = 47 | match (c, res) with 48 | | Push _x, Res ((Unit, _), ()) -> true 49 | | Pop_opt, Res ((Option Int, _), res) -> ( 50 | res = match s with [] -> None | x :: _ -> Some x) 51 | | Top_opt, Res ((Option Int, _), res) -> ( 52 | res = match s with [] -> None | x :: _ -> Some x) 53 | | Length, Res ((Int, _), res) -> res = List.length s 54 | | _, _ -> false 55 | end 56 | 57 | let () = 58 | Stm_run.run ~count:1000 ~verbose:true ~name:"Stack" (module Spec) |> exit 59 | -------------------------------------------------------------------------------- /update-gh-pages-for-tag: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -xeuo pipefail 4 | 5 | TMP=tmp 6 | NAME=kcas 7 | MAIN=doc 8 | GIT="git@github.com:ocaml-multicore/$NAME.git" 9 | DOC="_build/default/_doc/_html" 10 | GH_PAGES=gh-pages 11 | 12 | TAG="$1" 13 | 14 | if ! [ -e $NAME.opam ] || [ $# -ne 1 ] || \ 15 | { [ "$TAG" != main ] && ! [ "$(git tag -l "$TAG")" ]; }; then 16 | CMD="${0##*/}" 17 | cat << EOF 18 | Usage: $CMD tag-name-or-main 19 | 20 | This script 21 | - clones the repository into a temporary directory ($TMP/$NAME), 22 | - builds the documentation for the specified tag or main, 23 | - updates $GH_PAGES branch with the documentation in directory for the tag, 24 | - prompts whether to also update the main documentation in $MAIN directory, and 25 | - prompts whether to push changes to $GH_PAGES. 26 | 27 | EOF 28 | exit 1 29 | fi 30 | 31 | mkdir $TMP 32 | cd $TMP 33 | 34 | git clone $GIT 35 | cd $NAME 36 | 37 | git checkout "$TAG" 38 | dune build @doc --root=. 39 | 40 | git checkout $GH_PAGES 41 | if [ "$TAG" != main ]; then 42 | echo "Updating the $TAG doc." 43 | if [ -e "$TAG" ]; then 44 | git rm -rf "$TAG" 45 | fi 46 | cp -r $DOC "$TAG" 47 | git add "$TAG" 48 | fi 49 | 50 | read -p "Update the main doc? (y/N) " -n 1 -r 51 | echo 52 | if [[ $REPLY =~ ^[Yy]$ ]]; then 53 | if [ -e $MAIN ]; then 54 | git rm -rf $MAIN 55 | fi 56 | cp -r $DOC $MAIN 57 | git add $MAIN 58 | else 59 | echo "Skipped main doc update." 60 | fi 61 | 62 | git commit -m "Update $NAME doc for $TAG" 63 | 64 | read -p "Push changes to $GH_PAGES? (y/N) " -n 1 -r 65 | echo 66 | if ! [[ $REPLY =~ ^[Yy]$ ]]; then 67 | echo "Leaving $TMP for you to examine." 68 | exit 1 69 | fi 70 | 71 | git push 72 | 73 | cd .. 74 | cd .. 75 | rm -rf $TMP 76 | -------------------------------------------------------------------------------- /doc/kcas.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 14 | 17 | 20 | 21 | 22 | 32 | 35 | 38 | 39 | 40 | 50 | 53 | 56 | 57 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /src/kcas_data/promise.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | (** A promise of a value to be resolved at some point in the future. 4 | 5 | Example: 6 | 7 | {[ 8 | # let promise, resolver = Promise.create () in 9 | let domain = Domain.spawn @@ fun () -> 10 | Printf.printf "Got %d\n%!" (Promise.await promise) 11 | in 12 | Promise.resolve resolver 42; 13 | Domain.join domain 14 | Got 42 15 | - : unit = () 16 | ]} *) 17 | 18 | (** {1 Common interface} *) 19 | 20 | type !+'a t 21 | (** The type of a promise of a value of type ['a]. *) 22 | 23 | type !-'a u 24 | (** The type of a resolver of a value of type ['a]. *) 25 | 26 | type 'a or_exn = ('a, exn) Stdlib.result t 27 | (** The type of a promise of a result of type [('a, exn) result]. *) 28 | 29 | val create : unit -> 'a t * 'a u 30 | (** [create ()] returns a new unresolved pair of a promise and a resolver for 31 | the promise. *) 32 | 33 | val create_resolved : 'a -> 'a t 34 | (** [create_resolved x] returns a promise that is already resolved to the given 35 | value [x]. *) 36 | 37 | (** {1 Compositional interface} *) 38 | 39 | module Xt : 40 | Promise_intf.Ops 41 | with type 'a t := 'a t 42 | with type 'a or_exn := 'a or_exn 43 | with type 'a u := 'a u 44 | with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn 45 | with type ('x, 'fn) blocking_fn := xt:'x Xt.t -> 'fn 46 | (** Explicit transaction log passing on promises. *) 47 | 48 | (** {1 Non-compositional interface} *) 49 | 50 | include 51 | Promise_intf.Ops 52 | with type 'a t := 'a t 53 | with type 'a or_exn := 'a or_exn 54 | with type 'a u := 'a u 55 | with type ('x, 'fn) fn := 'fn 56 | with type ('x, 'fn) blocking_fn := ?timeoutf:float -> 'fn 57 | -------------------------------------------------------------------------------- /test/kcas_data/lru_cache_example.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | module Lru_cache = struct 4 | include Lru_cache 5 | 6 | module Xt = struct 7 | include Xt 8 | 9 | let get ~xt c key = Kcas.Xt.to_blocking ~xt (get_opt c key) 10 | 11 | let get_if ~xt c key predicate = 12 | let snap = Kcas.Xt.snapshot ~xt in 13 | let datum = get ~xt c key in 14 | if predicate datum then datum else Retry.later (Kcas.Xt.rollback ~xt snap) 15 | 16 | let try_set ~xt c key datum = 17 | match set_blocking ~xt c key datum with 18 | | () -> true 19 | | exception Retry.Later -> false 20 | end 21 | 22 | let get ?timeoutf c k = Kcas.Xt.commit ?timeoutf { tx = Xt.get c k } 23 | let get_if ?timeoutf c k p = Kcas.Xt.commit ?timeoutf { tx = Xt.get_if c k p } 24 | let try_set c k d = Kcas.Xt.commit { tx = Xt.try_set c k d } 25 | end 26 | 27 | let () = 28 | let c = Lru_cache.create 10 in 29 | let domain = 30 | Domain.spawn @@ fun () -> 31 | let tx ~xt = Lru_cache.Xt.get ~xt c "a" + Lru_cache.Xt.get ~xt c "b" in 32 | Xt.commit { tx } 33 | in 34 | Lru_cache.set_blocking c "b" 30; 35 | Lru_cache.set_blocking c "a" 12; 36 | assert (Domain.join domain = 42); 37 | () 38 | 39 | let () = 40 | let c = Lru_cache.create 10 in 41 | assert (Lru_cache.try_set c "a" 1); 42 | Lru_cache.set_blocking c "c" 2; 43 | assert (Lru_cache.capacity_of c = 10); 44 | assert (Lru_cache.get_opt c "b" = None); 45 | assert (Lru_cache.get c "a" = 1); 46 | Lru_cache.set_capacity c 3; 47 | assert (Lru_cache.get c "c" = 2); 48 | Lru_cache.set_capacity c 1; 49 | assert (Lru_cache.capacity_of c = 1); 50 | assert (Lru_cache.get_opt c "a" = None); 51 | assert (Lru_cache.get_if c "c" (( <> ) 0) = 2); 52 | Lru_cache.remove c "c"; 53 | assert (Lru_cache.get_opt c "c" = None); 54 | () 55 | 56 | let () = Printf.printf "LRU Cache OK!\n%!" 57 | -------------------------------------------------------------------------------- /src/kcas_data/stack.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type 'a t = 'a Elems.t Loc.t 4 | 5 | let create () = Loc.make ~padded:true Elems.empty 6 | let copy s = Loc.make ~padded:true @@ Loc.get s 7 | let of_seq xs = Loc.make ~padded:true (Elems.of_seq_rev xs) 8 | 9 | module Xt = struct 10 | let length ~xt s = Xt.get ~xt s |> Elems.length 11 | let is_empty ~xt s = Xt.get ~xt s == Elems.empty 12 | let push ~xt x s = Xt.modify ~xt s @@ Elems.cons x 13 | let pop_opt ~xt s = Xt.update ~xt s Elems.tl_safe |> Elems.hd_opt 14 | let pop_all ~xt s = Elems.to_seq @@ Xt.exchange ~xt s Elems.empty 15 | let pop_blocking ~xt s = Xt.update ~xt s Elems.tl_safe |> Elems.hd_or_retry 16 | let top_opt ~xt s = Xt.get ~xt s |> Elems.hd_opt 17 | let top_blocking ~xt s = Xt.get ~xt s |> Elems.hd_or_retry 18 | let clear ~xt s = Xt.set ~xt s Elems.empty 19 | let swap ~xt s1 s2 = Xt.swap ~xt s1 s2 20 | let to_seq ~xt s = Elems.to_seq @@ Xt.get ~xt s 21 | end 22 | 23 | let length s = Loc.get s |> Elems.length 24 | let is_empty s = Loc.get s == Elems.empty 25 | 26 | let push x s = 27 | (* Fenceless is safe as we always update. *) 28 | Loc.fenceless_modify s @@ Elems.cons x 29 | 30 | let pop_opt s = Loc.update s Elems.tl_safe |> Elems.hd_opt 31 | let pop_all s = Loc.exchange s Elems.empty |> Elems.to_seq 32 | 33 | let pop_blocking ?timeoutf s = 34 | (* Fenceless is safe as we always update. *) 35 | Loc.fenceless_update ?timeoutf s Elems.tl_or_retry |> Elems.hd_unsafe 36 | 37 | let top_opt s = Loc.get s |> Elems.hd_opt 38 | let top_blocking ?timeoutf s = Loc.get_as ?timeoutf Elems.hd_or_retry s 39 | let clear s = Loc.set s Elems.empty 40 | let swap s1 s2 = Kcas.Xt.commit { tx = Kcas.Xt.swap s1 s2 } 41 | let to_seq s = Elems.to_seq @@ Loc.get s 42 | let iter f s = Elems.iter f @@ Loc.get s 43 | let fold f a s = Elems.fold f a @@ Loc.get s 44 | 45 | exception Empty 46 | 47 | let[@inline] of_option = function None -> raise Empty | Some value -> value 48 | let top s = top_opt s |> of_option 49 | let pop s = pop_opt s |> of_option 50 | -------------------------------------------------------------------------------- /src/kcas_data/stack.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | (** Last-In First-Out (LIFO) stack. 4 | 5 | The interface provides a subset of the OCaml [Stdlib.Stack] module. 6 | [add_seq] is not provided at all. Compositional versions of {!iter}, 7 | {!fold}, {!pop}, and {!top} are not provided. 8 | 9 | The implementation is essentially a 10 | {{:https://en.wikipedia.org/wiki/Treiber_stack}Treiber stack} with 11 | randomized exponential backoff and support for constant time {!length}. *) 12 | 13 | (** {1 Common interface} *) 14 | 15 | type !'a t 16 | (** The type of stacks containing elements of type ['a]. *) 17 | 18 | exception Empty 19 | (** Raised when {!pop} or {!top} is applied to an empty stack. *) 20 | 21 | val create : unit -> 'a t 22 | (** [create ()] returns a new empty stack. *) 23 | 24 | val copy : 'a t -> 'a t 25 | (** [copy s] returns a copy of the stack [s]. *) 26 | 27 | val of_seq : 'a Seq.t -> 'a t 28 | (** [of_seq xs] creates a stack from the sequence [xs]. *) 29 | 30 | (** {1 Compositional interface} *) 31 | 32 | module Xt : 33 | Stack_intf.Ops 34 | with type 'a t := 'a t 35 | with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn 36 | with type ('x, 'fn) blocking_fn := xt:'x Xt.t -> 'fn 37 | (** Explicit transaction log passing on stacks. *) 38 | 39 | (** {1 Non-compositional interface} *) 40 | 41 | include 42 | Stack_intf.Ops 43 | with type 'a t := 'a t 44 | with type ('x, 'fn) fn := 'fn 45 | with type ('x, 'fn) blocking_fn := ?timeoutf:float -> 'fn 46 | 47 | val pop : 'a t -> 'a 48 | (** [pop s] removes and returns the topmost element in stack [s], or raises 49 | {!Empty} if the stack is empty. *) 50 | 51 | val top : 'a t -> 'a 52 | (** [top s] returns the topmost element in stack [s], or raises {!Empty} if the 53 | stack is empty. *) 54 | 55 | val iter : ('a -> unit) -> 'a t -> unit 56 | (** [iter f s] is equivalent to [Seq.iter f (to_seq s)]. *) 57 | 58 | val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b 59 | (** [fold f s] is equivalent to [Seq.fold_left f a (to_seq s)]. *) 60 | -------------------------------------------------------------------------------- /src/kcas_data/promise.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type 'a internal = 'a Magic_option.t Loc.t 4 | type !+'a t 5 | type !-'a u 6 | type 'a or_exn = ('a, exn) Stdlib.result t 7 | 8 | external to_promise : 'a internal -> 'a t = "%identity" 9 | external to_resolver : 'a internal -> 'a u = "%identity" 10 | external of_promise : 'a t -> 'a internal = "%identity" 11 | external of_resolver : 'a u -> 'a internal = "%identity" 12 | 13 | let create () = 14 | let p = Loc.make Magic_option.none in 15 | (to_promise p, to_resolver p) 16 | 17 | let create_resolved v = to_promise (Loc.make (Magic_option.some v)) 18 | 19 | let[@inline never] already_resolved () = 20 | invalid_arg "Can't resolve already-resolved promise" 21 | 22 | module Xt = struct 23 | let resolve ~xt u v = 24 | if 25 | Magic_option.is_some 26 | (Xt.compare_and_swap ~xt (of_resolver u) Magic_option.none 27 | (Magic_option.some v)) 28 | then already_resolved () 29 | 30 | let await ~xt t = Magic_option.get_or_retry (Xt.get ~xt (of_promise t)) 31 | let peek ~xt t = Magic_option.to_option (Xt.get ~xt (of_promise t)) 32 | let is_resolved ~xt t = Magic_option.is_some (Xt.get ~xt (of_promise t)) 33 | 34 | let await_exn ~xt t = 35 | match await ~xt t with Ok value -> value | Error exn -> raise exn 36 | 37 | let resolve_ok ~xt u v = resolve ~xt u (Ok v) 38 | let resolve_error ~xt u e = resolve ~xt u (Error e) 39 | end 40 | 41 | let await ?timeoutf t = 42 | Loc.get_as ?timeoutf Magic_option.get_or_retry (of_promise t) 43 | 44 | let resolve u v = 45 | if 46 | not 47 | (Loc.compare_and_set (of_resolver u) Magic_option.none 48 | (Magic_option.some v)) 49 | then already_resolved () 50 | 51 | let peek t = Magic_option.to_option (Loc.get (of_promise t)) 52 | let is_resolved t = Magic_option.is_some (Loc.get (of_promise t)) 53 | 54 | let await_exn ?timeoutf t = 55 | match await ?timeoutf t with Ok value -> value | Error exn -> raise exn 56 | 57 | let resolve_ok u v = resolve u (Ok v) 58 | let resolve_error u e = resolve u (Error e) 59 | -------------------------------------------------------------------------------- /bench/bench_hashtbl.ml: -------------------------------------------------------------------------------- 1 | open Kcas_data 2 | open Multicore_bench 3 | 4 | module Int = struct 5 | include Int 6 | 7 | let hash = Fun.id 8 | end 9 | 10 | let run_one ~budgetf ~n_domains ?(n_ops = 40 * Util.iter_factor) 11 | ?(n_keys = 1000) ~percent_read () = 12 | let t = Hashtbl.create ~hashed_type:(module Int) () in 13 | 14 | let n_ops = (100 + percent_read) * n_ops / 100 in 15 | let n_ops = n_ops * n_domains in 16 | 17 | for i = 0 to n_keys - 1 do 18 | Hashtbl.replace t i i 19 | done; 20 | 21 | let n_ops_todo = Countdown.create ~n_domains () in 22 | 23 | let init _ = 24 | Countdown.non_atomic_set n_ops_todo n_ops; 25 | Random.State.make_self_init () 26 | in 27 | 28 | let work domain_index state = 29 | let rec work () = 30 | let n = Countdown.alloc n_ops_todo ~domain_index ~batch:1000 in 31 | if n <> 0 then 32 | let rec loop n = 33 | if 0 < n then 34 | let value = Random.State.bits state in 35 | let op = (value asr 20) mod 100 in 36 | let key = value mod n_keys in 37 | if op < percent_read then begin 38 | Hashtbl.find_opt t key |> ignore; 39 | loop (n - 1) 40 | end 41 | else begin 42 | Hashtbl.remove t key; 43 | Hashtbl.add t key value; 44 | loop (n - 2) 45 | end 46 | else work () 47 | in 48 | loop n 49 | in 50 | work () 51 | in 52 | 53 | let config = 54 | Printf.sprintf "%d worker%s, %d%% reads" n_domains 55 | (if n_domains = 1 then "" else "s") 56 | percent_read 57 | in 58 | 59 | Times.record ~budgetf ~n_domains ~init ~work () 60 | |> Times.to_thruput_metrics ~n:n_ops ~singular:"operation" ~config 61 | 62 | let run_suite ~budgetf = 63 | Util.cross [ 90; 50; 10 ] [ 1; 2; 4; 8 ] 64 | |> List.concat_map @@ fun (percent_read, n_domains) -> 65 | if Domain.recommended_domain_count () < n_domains then [] 66 | else run_one ~budgetf ~n_domains ~percent_read () 67 | -------------------------------------------------------------------------------- /src/kcas_data/stack_intf.ml: -------------------------------------------------------------------------------- 1 | module type Ops = sig 2 | type 'a t 3 | type ('x, 'fn) fn 4 | type ('x, 'fn) blocking_fn 5 | 6 | val is_empty : ('x, 'a t -> bool) fn 7 | (** [is_empty s] determines whether the stack [s] is empty. *) 8 | 9 | val length : ('x, 'a t -> int) fn 10 | (** [length s] returns the length of the stack [s]. *) 11 | 12 | val clear : ('x, 'a t -> unit) fn 13 | (** [clear s] removes all elements from the stack [s]. *) 14 | 15 | val swap : ('x, 'a t -> 'a t -> unit) fn 16 | (** [swap s1 s2] exchanges the contents of the stacks [s1] and [s2]. *) 17 | 18 | val to_seq : ('x, 'a t -> 'a Seq.t) fn 19 | (** [to_seq s] returns a concurrency and parallelism safe sequence for 20 | iterating through the elements of the stack top to bottom. 21 | 22 | The sequence is based on a constant time, [O(1)], snapshot of the stack 23 | and modifications of the stack have no effect on the sequence. *) 24 | 25 | val push : ('x, 'a -> 'a t -> unit) fn 26 | (** [push x s] adds the element [x] to the top of the stack [s]. *) 27 | 28 | val pop_opt : ('x, 'a t -> 'a option) fn 29 | (** [pop_opt s] removes and returns the topmost element of the stack [s], or 30 | [None] if the stack is empty. *) 31 | 32 | val pop_all : ('x, 'a t -> 'a Seq.t) fn 33 | (** [pop_all s] removes and returns a concurrency and parallelism safe 34 | sequence for iterating through all the elements that were in the stack top 35 | to bottom. *) 36 | 37 | val pop_blocking : ('x, 'a t -> 'a) blocking_fn 38 | (** [pop_blocking s] removes and returns the topmost element of the stack [s], 39 | or blocks waiting for the queue to become non-empty. *) 40 | 41 | val top_opt : ('x, 'a t -> 'a option) fn 42 | (** [top_opt s] returns the topmost element in stack [s], or [None] if the 43 | stack is empty. *) 44 | 45 | val top_blocking : ('x, 'a t -> 'a) blocking_fn 46 | (** [top_blocking s] returns the topmost element in stack [s], or blocks 47 | waiting for the queue to become non-empty. *) 48 | end 49 | -------------------------------------------------------------------------------- /src/kcas_data/hashtbl_intf.ml: -------------------------------------------------------------------------------- 1 | module type Ops = sig 2 | type ('k, 'v) t 3 | type ('x, 'fn) fn 4 | 5 | val length : ('x, ('k, 'v) t -> int) fn 6 | (** [length t] returns the number of {i bindings} in the hash table [t]. 7 | 8 | ⚠️ The returned value may be greater than the number of {i distinct keys} 9 | in the hash table. *) 10 | 11 | val reset : ('x, ('k, 'v) t -> unit) fn 12 | (** [reset t] remove all bindings from the hash table [t] and shrinks the 13 | capacity of the table back to the minimum. *) 14 | 15 | val clear : ('x, ('k, 'v) t -> unit) fn 16 | (** [clear] is a synonym for {!reset}. *) 17 | 18 | val swap : ('x, ('k, 'v) t -> ('k, 'v) t -> unit) fn 19 | (** [swap t1 t2] exchanges the contents of the hash tables [t1] and [t2]. *) 20 | 21 | val remove : ('x, ('k, 'v) t -> 'k -> unit) fn 22 | (** [remove t k] removes the most recent existing binding of key [k], if any, 23 | from the hash table [t] thereby revealing the earlier binding of [k], if 24 | any. *) 25 | 26 | val add : ('x, ('k, 'v) t -> 'k -> 'v -> unit) fn 27 | (** [add t k v] adds a binding of key [k] to value [v] to the hash table 28 | shadowing the previous binding of the key [k], if any. 29 | 30 | ⚠️ Consider using {!replace} instead of [add]. *) 31 | 32 | val replace : ('x, ('k, 'v) t -> 'k -> 'v -> unit) fn 33 | (** [replace t k v] adds a binding of key [k] to value [v] or replaces the 34 | most recent existing binding of key [k] in the hash table [t]. *) 35 | 36 | val mem : ('x, ('k, 'v) t -> 'k -> bool) fn 37 | (** [mem t k] is equivalent to [Option.is_some (find_opt t k)]. *) 38 | 39 | val find_opt : ('x, ('k, 'v) t -> 'k -> 'v option) fn 40 | (** [find_opt t k] returns the current binding of key [k] in the hash table 41 | [t], or [None] if no such binding exists. *) 42 | 43 | val find_all : ('x, ('k, 'v) t -> 'k -> 'v list) fn 44 | (** [find_all t k] returns a list of all the bindings of the key [k] in the 45 | hash table in reverse order of their introduction. *) 46 | end 47 | -------------------------------------------------------------------------------- /test/kcas_data/queue_test_stm.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open STM 3 | open Kcas_data 4 | 5 | module Spec = struct 6 | type cmd = Push of int | Take_opt | Peek_opt | Length 7 | 8 | let show_cmd = function 9 | | Push x -> "Push " ^ string_of_int x 10 | | Take_opt -> "Take_opt" 11 | | Peek_opt -> "Peek_opt" 12 | | Length -> "Length" 13 | 14 | module State = struct 15 | type t = int list * int list 16 | 17 | let push x (h, t) = if h == [] then ([ x ], []) else (h, x :: t) 18 | let peek_opt (h, _) = match h with x :: _ -> Some x | [] -> None 19 | 20 | let drop ((h, t) as s) = 21 | match h with [] -> s | [ _ ] -> (List.rev t, []) | _ :: h -> (h, t) 22 | 23 | let length (h, t) = List.length h + List.length t 24 | end 25 | 26 | type state = State.t 27 | type sut = int Queue.t 28 | 29 | let arb_cmd _s = 30 | [ 31 | Gen.int |> Gen.map (fun x -> Push x); 32 | Gen.return Take_opt; 33 | Gen.return Peek_opt; 34 | Gen.return Length; 35 | ] 36 | |> Gen.oneof |> make ~print:show_cmd 37 | 38 | let init_state = ([], []) 39 | let init_sut () = Queue.create () 40 | let cleanup _ = () 41 | 42 | let next_state c s = 43 | match c with 44 | | Push x -> State.push x s 45 | | Take_opt -> State.drop s 46 | | Peek_opt -> s 47 | | Length -> s 48 | 49 | let precond _ _ = true 50 | 51 | let run c d = 52 | match c with 53 | | Push x -> Res (unit, Queue.push x d) 54 | | Take_opt -> Res (option int, Queue.take_opt d) 55 | | Peek_opt -> Res (option int, Queue.peek_opt d) 56 | | Length -> Res (int, Queue.length d) 57 | 58 | let postcond c (s : state) res = 59 | match (c, res) with 60 | | Push _x, Res ((Unit, _), ()) -> true 61 | | Take_opt, Res ((Option Int, _), res) -> res = State.peek_opt s 62 | | Peek_opt, Res ((Option Int, _), res) -> res = State.peek_opt s 63 | | Length, Res ((Int, _), res) -> res = State.length s 64 | | _, _ -> false 65 | end 66 | 67 | let () = 68 | Stm_run.run ~count:1000 ~verbose:true ~name:"Queue" (module Spec) |> exit 69 | -------------------------------------------------------------------------------- /test/kcas_data/hashtbl_test_stm.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open STM 3 | open Kcas_data 4 | 5 | module Spec = struct 6 | type cmd = Add of int | Mem of int | Remove of int | Clear | Length 7 | 8 | let show_cmd = function 9 | | Add x -> "Add " ^ string_of_int x 10 | | Mem x -> "Mem " ^ string_of_int x 11 | | Remove x -> "Remove " ^ string_of_int x 12 | | Clear -> "Clear" 13 | | Length -> "Length" 14 | 15 | type state = int list 16 | type sut = (int, unit) Hashtbl.t 17 | 18 | let arb_cmd _s = 19 | [ 20 | Gen.int_bound 10 |> Gen.map (fun x -> Add x); 21 | Gen.int_bound 10 |> Gen.map (fun x -> Mem x); 22 | Gen.int_bound 10 |> Gen.map (fun x -> Remove x); 23 | Gen.return Clear; 24 | Gen.return Length; 25 | ] 26 | |> Gen.oneof |> make ~print:show_cmd 27 | 28 | let init_state = [] 29 | let init_sut () = Hashtbl.create () 30 | let cleanup _ = () 31 | 32 | let next_state c s = 33 | match c with 34 | | Add x -> x :: s 35 | | Mem _ -> s 36 | | Remove x -> 37 | let[@tail_mod_cons] rec drop_first = function 38 | | [] -> [] 39 | | x' :: xs -> if x = x' then xs else x' :: drop_first xs 40 | in 41 | drop_first s 42 | | Clear -> [] 43 | | Length -> s 44 | 45 | let precond _ _ = true 46 | 47 | let run c d = 48 | match c with 49 | | Add x -> Res (unit, Hashtbl.add d x ()) 50 | | Mem x -> Res (bool, Hashtbl.mem d x) 51 | | Remove x -> Res (unit, Hashtbl.remove d x) 52 | | Clear -> Res (unit, Hashtbl.clear d) 53 | | Length -> Res (int, Hashtbl.length d) 54 | 55 | let postcond c (s : state) res = 56 | match (c, res) with 57 | | Add _x, Res ((Unit, _), ()) -> true 58 | | Mem x, Res ((Bool, _), res) -> res = List.exists (( = ) x) s 59 | | Remove _x, Res ((Unit, _), ()) -> true 60 | | Clear, Res ((Unit, _), ()) -> true 61 | | Length, Res ((Int, _), res) -> res = List.length s 62 | | _, _ -> false 63 | end 64 | 65 | let () = 66 | Stm_run.run ~count:1000 ~verbose:true ~name:"Hashtbl" (module Spec) |> exit 67 | -------------------------------------------------------------------------------- /src/kcas_data/queue.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | (** First-In First-Out (FIFO) queue. 4 | 5 | The interface provides a subset of the OCaml [Stdlib.Queue] module. 6 | [transfer] and [add_seq] are not provided at all. Compositional versions of 7 | {!iter}, {!fold}, {!peek}, {!top}, and {!take} are not provided. 8 | 9 | The queue implementation is designed to avoid contention between a producer 10 | and a consumer operating concurrently. The implementation is also designed 11 | to avoid starvation. Performance in most concurrent use cases should be 12 | superior to what can be achieved with one or two locks. *) 13 | 14 | (** {1 Common interface} *) 15 | 16 | type !'a t 17 | (** The type of queues containing elements of type ['a]. *) 18 | 19 | exception Empty 20 | (** Raised when {!take} or {!peek} is applied to an empty queue. *) 21 | 22 | val create : unit -> 'a t 23 | (** [create ()] returns a new empty queue. *) 24 | 25 | val copy : 'a t -> 'a t 26 | (** [copy q] returns a copy of the queue [q]. *) 27 | 28 | (** {1 Compositional interface} *) 29 | 30 | module Xt : 31 | Queue_intf.Ops 32 | with type 'a t := 'a t 33 | with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn 34 | with type ('x, 'fn) blocking_fn := xt:'x Xt.t -> 'fn 35 | (** Explicit transaction log passing on queues. *) 36 | 37 | (** {1 Non-compositional interface} *) 38 | 39 | include 40 | Queue_intf.Ops 41 | with type 'a t := 'a t 42 | with type ('x, 'fn) fn := 'fn 43 | with type ('x, 'fn) blocking_fn := ?timeoutf:float -> 'fn 44 | 45 | val peek : 'a t -> 'a 46 | (** [peek q] returns the first element in queue [s], or raises {!Empty} if the 47 | queue is empty. *) 48 | 49 | val top : 'a t -> 'a 50 | (** [top] is a synonym for {!peek}. *) 51 | 52 | val take : 'a t -> 'a 53 | (** [take s] removes and returns the first element in queue [q], or raises 54 | {!Empty} if the queue is empty. *) 55 | 56 | val iter : ('a -> unit) -> 'a t -> unit 57 | (** [iter f s] is equivalent to [Seq.iter f (to_seq s)]. *) 58 | 59 | val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b 60 | (** [fold f s] is equivalent to [Seq.fold_left f a (to_seq s)]. *) 61 | -------------------------------------------------------------------------------- /src/kcas_data/queue_intf.ml: -------------------------------------------------------------------------------- 1 | module type Ops = sig 2 | type 'a t 3 | type ('x, 'fn) fn 4 | type ('x, 'fn) blocking_fn 5 | 6 | val is_empty : ('x, 'a t -> bool) fn 7 | (** [is_empty s] determines whether the queue [q] is empty. *) 8 | 9 | val length : ('x, 'a t -> int) fn 10 | (** [length q] returns the length of the queue [q]. *) 11 | 12 | val clear : ('x, 'a t -> unit) fn 13 | (** [clear q] removes all elements from the queue [q]. *) 14 | 15 | val swap : ('x, 'a t -> 'a t -> unit) fn 16 | (** [swap q1 q2] exchanges the contents of the queues [q1] and [q2]. *) 17 | 18 | val to_seq : ('x, 'a t -> 'a Seq.t) fn 19 | (** [to_seq s] returns a concurrency and parallelism safe sequence for 20 | iterating through the elements of the queue front to back. 21 | 22 | The sequence is based on a constant time, [O(1)], snapshot of the queue 23 | and modifications of the queue have no effect on the sequence. *) 24 | 25 | val add : ('x, 'a -> 'a t -> unit) fn 26 | (** [add x q] adds the element [x] at the end of the queue [q]. *) 27 | 28 | val push : ('x, 'a -> 'a t -> unit) fn 29 | (** [push] is a synonym for {!add}. *) 30 | 31 | val peek_opt : ('x, 'a t -> 'a option) fn 32 | (** [peek_opt q] returns the first element in queue [q], without removing it 33 | from the queue, or returns [None] if the queue is empty. *) 34 | 35 | val peek_blocking : ('x, 'a t -> 'a) blocking_fn 36 | (** [peek_blocking q] returns the first element in queue [q], without removing 37 | it from the queue, or blocks waiting for the queue to become non-empty. *) 38 | 39 | val take_blocking : ('x, 'a t -> 'a) blocking_fn 40 | (** [take_blocking q] removes and returns the first element in queue [q], or 41 | blocks waiting for the queue to become non-empty. *) 42 | 43 | val take_opt : ('x, 'a t -> 'a option) fn 44 | (** [take_opt q] removes and returns the first element in queue [q], or 45 | returns [None] if the queue is empty. *) 46 | 47 | val take_all : ('x, 'a t -> 'a Seq.t) fn 48 | (** [take_all q] removes and returns a concurrency and parallelism safe 49 | sequence for iterating through all the elements that were in the queue 50 | front to back. *) 51 | end 52 | -------------------------------------------------------------------------------- /src/kcas_data/accumulator.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type t = { mutable cache : int Loc.t array; truth : int Loc.t array Loc.t } 4 | 5 | let make n = 6 | let cs = Loc.make_array ~padded:true ~mode:`Lock_free 1 0 in 7 | Loc.set (Array.unsafe_get cs 0) n; 8 | let truth = Loc.make ~padded:true cs in 9 | Multicore_magic.copy_as_padded { cache = cs; truth } 10 | 11 | let[@inline never] rec get_self a i cs n = 12 | let add_cs = Loc.make_array ~padded:true ~mode:`Lock_free (n + 1) 0 in 13 | let new_cs = 14 | (* The length of [new_cs] will be a power of two minus 1, which means the 15 | whole heap block will have a power of two number of words, which may help 16 | to keep it cache line aligned. *) 17 | Array.init ((n * 2) + 1) @@ fun i -> 18 | if i <= n then Array.unsafe_get add_cs i else Array.unsafe_get cs (i - n - 1) 19 | in 20 | if Loc.compare_and_set a.truth cs new_cs then a.cache <- new_cs; 21 | let cs = a.cache in 22 | let n = Array.length cs in 23 | if i < n then Array.unsafe_get cs i else get_self a i cs n 24 | 25 | let[@inline] get_self a = 26 | let i = Multicore_magic.instantaneous_domain_index () in 27 | let cs = a.cache in 28 | let n = Array.length cs in 29 | if i < n then Array.unsafe_get cs i else get_self a i cs n 30 | 31 | module Xt = struct 32 | let add ~xt a n = if n <> 0 then Xt.fetch_and_add ~xt (get_self a) n |> ignore 33 | let incr ~xt a = Xt.incr ~xt (get_self a) 34 | let decr ~xt a = Xt.decr ~xt (get_self a) 35 | 36 | let rec get_rec ~xt cs s i = 37 | let s = s + Xt.get ~xt (Array.unsafe_get cs i) in 38 | if i = 0 then s else get_rec ~xt cs s (i - 1) 39 | 40 | let get ~xt a = 41 | let cs = Xt.get ~xt a.truth in 42 | let cs_old = a.cache in 43 | if cs != cs_old then a.cache <- cs; 44 | let i = Array.length cs - 1 in 45 | let s = Xt.get ~xt (Array.unsafe_get cs i) in 46 | if i = 0 then s else get_rec ~xt cs s (i - 1) 47 | 48 | let set ~xt a n = 49 | let delta = n - get ~xt a in 50 | if delta <> 0 then 51 | Xt.fetch_and_add ~xt (Array.unsafe_get a.cache 0) delta |> ignore 52 | end 53 | 54 | let add a n = if n <> 0 then Loc.fetch_and_add (get_self a) n |> ignore 55 | let incr a = Loc.incr (get_self a) 56 | let decr a = Loc.decr (get_self a) 57 | let get a = Kcas.Xt.commit { tx = Xt.get a } 58 | let set a n = Kcas.Xt.commit { tx = Xt.set a n } 59 | -------------------------------------------------------------------------------- /test/kcas_data/lru_cache.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | open Kcas_data 3 | 4 | type ('k, 'v) t = { 5 | space : int Loc.t; 6 | table : ('k, 'k Dllist.node * 'v) Hashtbl.t; 7 | order : 'k Dllist.t; 8 | } 9 | 10 | let check_capacity capacity = 11 | if capacity < 0 then invalid_arg "Lru_cache: capacity must be non-negative" 12 | 13 | let create ?hashed_type capacity = 14 | check_capacity capacity; 15 | { 16 | space = Loc.make capacity; 17 | table = Hashtbl.create ?hashed_type (); 18 | order = Dllist.create (); 19 | } 20 | 21 | module Xt = struct 22 | let capacity_of ~xt c = Xt.get ~xt c.space + Hashtbl.Xt.length ~xt c.table 23 | 24 | let set_capacity ~xt c new_capacity = 25 | check_capacity new_capacity; 26 | let old_length = Hashtbl.Xt.length ~xt c.table in 27 | let old_space = Xt.get ~xt c.space in 28 | let old_capacity = old_space + old_length in 29 | for _ = 1 to old_length - new_capacity do 30 | Dllist.Xt.take_blocking_r ~xt c.order |> Hashtbl.Xt.remove ~xt c.table 31 | done; 32 | Xt.set ~xt c.space (Int.max 0 (old_space + new_capacity - old_capacity)) 33 | 34 | let get_opt ~xt c key = 35 | Hashtbl.Xt.find_opt ~xt c.table key 36 | |> Option.map @@ fun (node, datum) -> 37 | Dllist.Xt.move_l ~xt node c.order; 38 | datum 39 | 40 | let set_blocking ~xt c key datum = 41 | let node = 42 | match Hashtbl.Xt.find_opt ~xt c.table key with 43 | | None -> 44 | if 0 = Xt.update ~xt c.space (fun n -> Int.max 0 (n - 1)) then 45 | Dllist.Xt.take_blocking_r ~xt c.order 46 | |> Hashtbl.Xt.remove ~xt c.table; 47 | Dllist.Xt.add_l ~xt key c.order 48 | | Some (node, _) -> 49 | Dllist.Xt.move_l ~xt node c.order; 50 | node 51 | in 52 | Hashtbl.Xt.replace ~xt c.table key (node, datum) 53 | 54 | let remove ~xt c key = 55 | Hashtbl.Xt.find_opt ~xt c.table key 56 | |> Option.iter @@ fun (node, _) -> 57 | Hashtbl.Xt.remove ~xt c.table key; 58 | Dllist.Xt.remove ~xt node; 59 | Xt.incr ~xt c.space 60 | end 61 | 62 | let capacity_of c = Kcas.Xt.commit { tx = Xt.capacity_of c } 63 | let set_capacity c n = Kcas.Xt.commit { tx = Xt.set_capacity c n } 64 | let get_opt c k = Kcas.Xt.commit { tx = Xt.get_opt c k } 65 | 66 | let set_blocking ?timeoutf c k v = 67 | Kcas.Xt.commit ?timeoutf { tx = Xt.set_blocking c k v } 68 | 69 | let remove c k = Kcas.Xt.commit { tx = Xt.remove c k } 70 | -------------------------------------------------------------------------------- /test/kcas_data/dllist_test.ml: -------------------------------------------------------------------------------- 1 | open Kcas_data 2 | 3 | let[@tail_mod_cons] rec take_as_list take l = 4 | match take l with None -> [] | Some x -> x :: take_as_list take l 5 | 6 | let basics () = 7 | let t1 = Dllist.create () in 8 | let t1' = Dllist.take_all t1 in 9 | assert (Dllist.to_list_r t1 = [] && Dllist.to_list_l t1' = []); 10 | Dllist.transfer_r t1' t1'; 11 | Dllist.add_r 2 t1' |> ignore; 12 | Dllist.move_r (Dllist.create_node 3) t1'; 13 | Dllist.swap t1' t1'; 14 | Dllist.add_l 1 t1' |> ignore; 15 | Dllist.transfer_r t1' t1'; 16 | let t1 = Dllist.take_all t1' in 17 | assert (Dllist.to_list_l t1' = [] && Dllist.to_list_r t1 = [ 3; 2; 1 ]); 18 | let t2 = Dllist.create () in 19 | Dllist.transfer_r t2 t1; 20 | Dllist.transfer_l t2 t1; 21 | Dllist.swap t1 t2; 22 | Dllist.swap t1 t2; 23 | Dllist.transfer_l t2 t2; 24 | Dllist.add_r 4 t2 |> ignore; 25 | Dllist.swap t1 t2; 26 | Dllist.swap t1 t2; 27 | Dllist.transfer_l t2 t2; 28 | Dllist.transfer_l t1 t2; 29 | Dllist.transfer_l t1 t2; 30 | Dllist.swap t1 t2; 31 | assert (Dllist.take_opt_l t2 = None); 32 | assert (Dllist.take_opt_l t2 = None); 33 | assert (take_as_list Dllist.take_opt_r t1 = [ 4; 3; 2; 1 ]) 34 | 35 | let add () = 36 | let l = Dllist.create () in 37 | Dllist.add_l 1 l |> ignore; 38 | Dllist.add_l 3 l |> ignore; 39 | Dllist.add_r 4 l |> ignore; 40 | assert (take_as_list Dllist.take_opt_l l = [ 3; 1; 4 ]) 41 | 42 | let move () = 43 | let t1 = Dllist.create () in 44 | let n1 = Dllist.add_l 5.3 t1 in 45 | Dllist.move_l n1 t1; 46 | assert (Dllist.to_list_l t1 = [ 5.3 ]); 47 | Dllist.move_r n1 t1; 48 | assert (Dllist.to_list_l t1 = [ 5.3 ]); 49 | let n2 = Dllist.add_l 5.2 t1 in 50 | assert (Dllist.to_list_l t1 = [ 5.2; 5.3 ]); 51 | Dllist.move_r n2 t1; 52 | assert (Dllist.to_list_l t1 = [ 5.3; 5.2 ]); 53 | Dllist.move_l n2 t1; 54 | assert (Dllist.to_list_l t1 = [ 5.2; 5.3 ]); 55 | let t2 = Dllist.create () in 56 | Dllist.move_l n1 t2; 57 | assert (Dllist.to_list_l t1 = [ 5.2 ]); 58 | assert (Dllist.to_list_l t2 = [ 5.3 ]); 59 | Dllist.move_r n2 t2; 60 | assert (Dllist.to_list_l t2 = [ 5.3; 5.2 ]); 61 | Dllist.move_l n1 t1; 62 | assert (Dllist.to_list_l t2 = [ 5.2 ]); 63 | assert (Dllist.to_list_l t1 = [ 5.3 ]) 64 | 65 | let () = 66 | Alcotest.run "Dllist" 67 | [ 68 | ("basics", [ Alcotest.test_case "" `Quick basics ]); 69 | ("add", [ Alcotest.test_case "" `Quick add ]); 70 | ("move", [ Alcotest.test_case "" `Quick move ]); 71 | ] 72 | -------------------------------------------------------------------------------- /test/kcas_data/dllist_test_stm.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open STM 3 | open Kcas_data 4 | 5 | module Spec = struct 6 | type cmd = Add_l of int | Take_opt_l | Add_r of int | Take_opt_r 7 | 8 | let show_cmd = function 9 | | Add_l x -> "Add_l " ^ string_of_int x 10 | | Take_opt_l -> "Take_opt_l" 11 | | Add_r x -> "Add_r " ^ string_of_int x 12 | | Take_opt_r -> "Take_opt_r" 13 | 14 | module State = struct 15 | type t = int list * int list 16 | 17 | let push_l x (l, r) = (x :: l, r) 18 | let push_r x (l, r) = (l, x :: r) 19 | 20 | let drop_l (l, r) = 21 | match l with 22 | | _ :: l -> (l, r) 23 | | [] -> begin 24 | match List.rev r with [] -> ([], []) | _ :: l -> (l, []) 25 | end 26 | 27 | let drop_r (l, r) = 28 | match r with 29 | | _ :: r -> (l, r) 30 | | [] -> begin 31 | match List.rev l with [] -> ([], []) | _ :: r -> ([], r) 32 | end 33 | 34 | let peek_opt_l (l, r) = 35 | match l with 36 | | x :: _ -> Some x 37 | | [] -> begin match List.rev r with x :: _ -> Some x | [] -> None end 38 | 39 | let peek_opt_r (l, r) = 40 | match r with 41 | | x :: _ -> Some x 42 | | [] -> begin match List.rev l with x :: _ -> Some x | [] -> None end 43 | end 44 | 45 | type state = State.t 46 | type sut = int Dllist.t 47 | 48 | let arb_cmd _s = 49 | [ 50 | Gen.int |> Gen.map (fun x -> Add_l x); 51 | Gen.return Take_opt_l; 52 | Gen.int |> Gen.map (fun x -> Add_r x); 53 | Gen.return Take_opt_r; 54 | ] 55 | |> Gen.oneof |> make ~print:show_cmd 56 | 57 | let init_state = ([], []) 58 | let init_sut () = Dllist.create () 59 | let cleanup _ = () 60 | 61 | let next_state c s = 62 | match c with 63 | | Add_l x -> State.push_l x s 64 | | Take_opt_l -> State.drop_l s 65 | | Add_r x -> State.push_r x s 66 | | Take_opt_r -> State.drop_r s 67 | 68 | let precond _ _ = true 69 | 70 | let run c d = 71 | match c with 72 | | Add_l x -> Res (unit, Dllist.add_l x d |> ignore) 73 | | Take_opt_l -> Res (option int, Dllist.take_opt_l d) 74 | | Add_r x -> Res (unit, Dllist.add_r x d |> ignore) 75 | | Take_opt_r -> Res (option int, Dllist.take_opt_r d) 76 | 77 | let postcond c (s : state) res = 78 | match (c, res) with 79 | | Add_l _x, Res ((Unit, _), ()) -> true 80 | | Take_opt_l, Res ((Option Int, _), res) -> res = State.peek_opt_l s 81 | | Add_r _x, Res ((Unit, _), ()) -> true 82 | | Take_opt_r, Res ((Option Int, _), res) -> res = State.peek_opt_r s 83 | | _, _ -> false 84 | end 85 | 86 | let () = 87 | Stm_run.run ~count:1000 ~verbose:true ~name:"Dllist" (module Spec) |> exit 88 | -------------------------------------------------------------------------------- /test/kcas/loc_modes.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | let loop_count = try int_of_string Sys.argv.(1) with _ -> Util.iter_factor 4 | 5 | let mode = 6 | Some 7 | (try 8 | if Sys.argv.(2) = "obstruction-free" then `Obstruction_free 9 | else `Lock_free 10 | with _ -> `Lock_free) 11 | 12 | (* Number of shared counters being used to try to cause interference *) 13 | 14 | (* Number of private accumulators used for extra work *) 15 | let n_counters = try int_of_string Sys.argv.(3) with _ -> 2 16 | let n_accumulators = try int_of_string Sys.argv.(4) with _ -> 2 17 | let sleep_time = try int_of_string Sys.argv.(5) with _ -> 85 18 | 19 | (* Set to true when the accumulator work is done and counter threads may exit. 20 | This way we ensure that the counter threads are causing interference for the 21 | whole duration of the test. *) 22 | let exit = ref false 23 | 24 | (* Counters are first initialized with a dummy location *) 25 | let counters = 26 | let dummy_location_to_be_replaced = Loc.make 0 in 27 | Array.make n_counters dummy_location_to_be_replaced 28 | 29 | (* Barrier used to synchronize counter threads and the accumulator thread *) 30 | let barrier = Barrier.make (n_counters + 1) 31 | 32 | let counter_thread i () = 33 | (* We allocate actual counter locations within the domain to avoid false 34 | sharing *) 35 | let counter = Loc.make ?mode 0 in 36 | counters.(i) <- counter; 37 | 38 | let tx ~xt = Xt.incr ~xt counter in 39 | 40 | Barrier.await barrier; 41 | 42 | while not !exit do 43 | (* Increment the accumulator to cause interference *) 44 | Xt.commit { tx }; 45 | 46 | (* Delay for a bit. If we don't delay enough, we can starve the 47 | accumulator. *) 48 | for _ = 1 to sleep_time do 49 | Domain.cpu_relax () 50 | done 51 | done 52 | 53 | let accumulator_thread () = 54 | (* Accumulators allocated in the domain to avoid false sharing *) 55 | let accumulators = Array.init n_accumulators (fun _ -> Loc.make 0) in 56 | 57 | let tx ~xt = 58 | (* Compute sum of counters - these accesses can be interfered with *) 59 | let sum_of_counters = 60 | Array.fold_left (fun sum counter -> sum + Xt.get ~xt counter) 0 counters 61 | in 62 | 63 | (* And do some other work (updating accumulators) *) 64 | Array.iter 65 | (fun accumulator -> 66 | Xt.fetch_and_add ~xt accumulator sum_of_counters |> ignore) 67 | accumulators 68 | in 69 | 70 | Barrier.await barrier; 71 | 72 | for _ = 1 to loop_count do 73 | Xt.commit { tx } 74 | done; 75 | 76 | exit := true 77 | 78 | let () = 79 | accumulator_thread :: List.init n_counters counter_thread 80 | |> List.map Domain.spawn |> List.iter Domain.join; 81 | Printf.printf "Loc modes OK!\n%!" 82 | -------------------------------------------------------------------------------- /bench/bench_dllist.ml: -------------------------------------------------------------------------------- 1 | open Kcas_data 2 | open Multicore_bench 3 | 4 | let run_single ~budgetf ?(n_msgs = 15 * Util.iter_factor) () = 5 | let t = Dllist.create () in 6 | 7 | let op push = 8 | if push then Dllist.add_l 101 t |> ignore else Dllist.take_opt_r t |> ignore 9 | in 10 | 11 | let init _ = 12 | assert (Dllist.is_empty t); 13 | Util.generate_push_and_pop_sequence n_msgs 14 | in 15 | let work _ bits = Util.Bits.iter op bits in 16 | 17 | Times.record ~budgetf ~n_domains:1 ~init ~work () 18 | |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config:"one domain" 19 | 20 | let run_one ~budgetf ?(n_adders = 2) ?(n_takers = 2) ?(factor = 1) 21 | ?(n_msgs = 20 * factor * Util.iter_factor) () = 22 | let n_domains = n_adders + n_takers in 23 | 24 | let t = Dllist.create () in 25 | 26 | let n_msgs_to_take = Countdown.create ~n_domains:n_takers () in 27 | let n_msgs_to_add = Countdown.create ~n_domains:n_adders () in 28 | 29 | let init _ = 30 | assert (Dllist.is_empty t); 31 | Countdown.non_atomic_set n_msgs_to_take n_msgs; 32 | Countdown.non_atomic_set n_msgs_to_add n_msgs 33 | in 34 | let work i () = 35 | if i < n_adders then 36 | let domain_index = i in 37 | let rec work () = 38 | let n = Countdown.alloc n_msgs_to_add ~domain_index ~batch:1000 in 39 | if 0 < n then begin 40 | for i = 1 to n do 41 | Dllist.add_r i t |> ignore 42 | done; 43 | work () 44 | end 45 | in 46 | work () 47 | else 48 | let domain_index = i - n_adders in 49 | let rec work () = 50 | let n = Countdown.alloc n_msgs_to_take ~domain_index ~batch:1000 in 51 | if n <> 0 then begin 52 | for _ = 1 to n do 53 | while Option.is_none (Dllist.take_opt_l t) do 54 | Backoff.once Backoff.default |> ignore 55 | done 56 | done; 57 | work () 58 | end 59 | in 60 | work () 61 | in 62 | 63 | let config = 64 | let format role blocking n = 65 | Printf.sprintf "%d %s%s%s" n 66 | (if blocking then "" else "nb ") 67 | role 68 | (if n = 1 then "" else "s") 69 | in 70 | Printf.sprintf "%s, %s" 71 | (format "adder" false n_adders) 72 | (format "taker" false n_takers) 73 | in 74 | 75 | Times.record ~budgetf ~n_domains ~init ~work () 76 | |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config 77 | 78 | let run_suite ~budgetf = 79 | run_single ~budgetf () 80 | @ (Util.cross [ 1; 2 ] [ 1; 2 ] 81 | |> List.concat_map @@ fun (n_adders, n_takers) -> 82 | if Domain.recommended_domain_count () < n_adders + n_takers then [] 83 | else run_one ~budgetf ~n_adders ~n_takers ()) 84 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.14) 2 | 3 | (name kcas) 4 | 5 | (generate_opam_files true) 6 | 7 | (implicit_transitive_deps false) 8 | 9 | (authors 10 | "KC Sivaramakrishnan " 11 | "Vesa Karvonen ") 12 | 13 | (maintainers 14 | "Vesa Karvonen " 15 | "KC Sivaramakrishnan ") 16 | 17 | (source 18 | (github ocaml-multicore/kcas)) 19 | 20 | (homepage "https://github.com/ocaml-multicore/kcas") 21 | 22 | (license ISC) 23 | 24 | (using mdx 0.4) 25 | 26 | (package 27 | (name kcas) 28 | (synopsis 29 | "Software transactional memory based on lock-free multi-word compare-and-set") 30 | (description 31 | "A software transactional memory (STM) implementation based on an atomic lock-free multi-word compare-and-set (MCAS) algorithm enhanced with read-only compare operations and ability to block awaiting for changes.") 32 | (depends 33 | (ocaml 34 | (>= 4.13.0)) 35 | (backoff 36 | (>= 0.1.1)) 37 | (domain-local-await 38 | (>= 1.0.1)) 39 | (domain-local-timeout 40 | (>= 1.0.1)) 41 | (multicore-magic 42 | (>= 2.3.0)) 43 | (domain_shims 44 | (and 45 | (>= 0.1.0) 46 | :with-test)) 47 | (alcotest 48 | (and 49 | (>= 1.8.0) 50 | :with-test)) 51 | (qcheck-core 52 | (and 53 | (>= 0.21.2) 54 | :with-test)) 55 | (qcheck-stm 56 | (and 57 | (>= 0.3) 58 | :with-test)) 59 | (mdx 60 | (and 61 | (>= 2.4.1) 62 | :with-test)) 63 | (sherlodoc 64 | (and 65 | (>= 0.2) 66 | :with-doc)) 67 | (odoc 68 | (and 69 | (>= 2.4.2) 70 | :with-doc)))) 71 | 72 | (package 73 | (name kcas_data) 74 | (synopsis 75 | "Compositional lock-free data structures and primitives for communication and synchronization") 76 | (description 77 | "A library of compositional lock-free data structures and primitives for communication and synchronization implemented using kcas.") 78 | (depends 79 | (kcas 80 | (= :version)) 81 | (multicore-magic 82 | (>= 2.3.0)) 83 | (backoff 84 | (and 85 | (>= 0.1.1) 86 | :with-test)) 87 | (domain-local-await 88 | (and 89 | (>= 1.0.1) 90 | :with-test)) 91 | (domain_shims 92 | (and 93 | (>= 0.1.0) 94 | :with-test)) 95 | (multicore-bench 96 | (and 97 | (>= 0.1.7) 98 | :with-test)) 99 | (alcotest 100 | (and 101 | (>= 1.8.0) 102 | :with-test)) 103 | (qcheck-core 104 | (and 105 | (>= 0.21.2) 106 | :with-test)) 107 | (qcheck-stm 108 | (and 109 | (>= 0.3) 110 | :with-test)) 111 | (mdx 112 | (and 113 | (>= 2.4.1) 114 | :with-test)) 115 | (sherlodoc 116 | (and 117 | (>= 0.2) 118 | :with-doc)) 119 | (odoc 120 | (and 121 | (>= 2.4.2) 122 | :with-doc)))) 123 | -------------------------------------------------------------------------------- /bench/bench_mvar.ml: -------------------------------------------------------------------------------- 1 | open Kcas_data 2 | open Multicore_bench 3 | 4 | let run_one ~budgetf ?(n_adders = 2) ?(blocking_add = false) ?(n_takers = 2) 5 | ?(blocking_take = false) ?(n_msgs = 2 * Util.iter_factor) () = 6 | let n_domains = n_adders + n_takers in 7 | 8 | let t = Mvar.create None in 9 | 10 | let n_msgs_to_take = Countdown.create ~n_domains:n_takers () in 11 | let n_msgs_to_add = Countdown.create ~n_domains:n_adders () in 12 | 13 | let init _ = 14 | Countdown.non_atomic_set n_msgs_to_take n_msgs; 15 | Countdown.non_atomic_set n_msgs_to_add n_msgs 16 | in 17 | let work i () = 18 | if i < n_adders then 19 | let domain_index = i in 20 | if blocking_add then 21 | let rec work () = 22 | let n = Countdown.alloc n_msgs_to_add ~domain_index ~batch:1000 in 23 | if 0 < n then begin 24 | for i = 1 to n do 25 | Mvar.put t i 26 | done; 27 | work () 28 | end 29 | in 30 | work () 31 | else 32 | let rec work () = 33 | let n = Countdown.alloc n_msgs_to_add ~domain_index ~batch:1000 in 34 | if 0 < n then begin 35 | for i = 1 to n do 36 | while not (Mvar.try_put t i) do 37 | Backoff.once Backoff.default |> ignore 38 | done 39 | done; 40 | work () 41 | end 42 | in 43 | work () 44 | else 45 | let domain_index = i - n_adders in 46 | if blocking_take then 47 | let rec work () = 48 | let n = Countdown.alloc n_msgs_to_take ~domain_index ~batch:1000 in 49 | if n <> 0 then begin 50 | for _ = 1 to n do 51 | ignore (Mvar.take t) 52 | done; 53 | work () 54 | end 55 | in 56 | work () 57 | else 58 | let rec work () = 59 | let n = Countdown.alloc n_msgs_to_take ~domain_index ~batch:1000 in 60 | if n <> 0 then begin 61 | for _ = 1 to n do 62 | while Option.is_none (Mvar.take_opt t) do 63 | Backoff.once Backoff.default |> ignore 64 | done 65 | done; 66 | work () 67 | end 68 | in 69 | work () 70 | in 71 | 72 | let config = 73 | let format role blocking n = 74 | Printf.sprintf "%d %s%s%s" n 75 | (if blocking then "" else "nb ") 76 | role 77 | (if n = 1 then "" else "s") 78 | in 79 | Printf.sprintf "%s, %s" 80 | (format "adder" blocking_add n_adders) 81 | (format "taker" blocking_take n_takers) 82 | in 83 | 84 | Times.record ~budgetf ~n_domains ~init ~work () 85 | |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config 86 | 87 | let run_suite ~budgetf = 88 | Util.cross 89 | (Util.cross [ 1; 2 ] [ false; true ]) 90 | (Util.cross [ 1; 2 ] [ false; true ]) 91 | |> List.concat_map 92 | @@ fun ((n_adders, blocking_add), (n_takers, blocking_take)) -> 93 | if Domain.recommended_domain_count () < n_adders + n_takers then [] 94 | else run_one ~budgetf ~n_adders ~blocking_add ~n_takers ~blocking_take () 95 | -------------------------------------------------------------------------------- /bench/bench_stack.ml: -------------------------------------------------------------------------------- 1 | open Kcas_data 2 | open Multicore_bench 3 | 4 | let run_one_domain ~budgetf ?(n_msgs = 50 * Util.iter_factor) () = 5 | let t = Stack.create () in 6 | 7 | let op push = if push then Stack.push 101 t else Stack.pop_opt t |> ignore in 8 | 9 | let init _ = 10 | assert (Stack.is_empty t); 11 | Util.generate_push_and_pop_sequence n_msgs 12 | in 13 | let work _ bits = Util.Bits.iter op bits in 14 | 15 | Times.record ~budgetf ~n_domains:1 ~init ~work () 16 | |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config:"one domain" 17 | 18 | let run_one ~budgetf ?(n_adders = 2) ?(blocking_add = false) ?(n_takers = 2) 19 | ?(blocking_take = false) ?(n_msgs = 50 * Util.iter_factor) () = 20 | let n_domains = n_adders + n_takers in 21 | 22 | let t = Stack.create () in 23 | 24 | let n_msgs_to_take = Countdown.create ~n_domains:n_takers () in 25 | let n_msgs_to_add = Countdown.create ~n_domains:n_adders () in 26 | 27 | let init _ = 28 | assert (Stack.is_empty t); 29 | Countdown.non_atomic_set n_msgs_to_take n_msgs; 30 | Countdown.non_atomic_set n_msgs_to_add n_msgs 31 | in 32 | let work i () = 33 | if i < n_adders then 34 | let domain_index = i in 35 | let rec work () = 36 | let n = Countdown.alloc n_msgs_to_add ~domain_index ~batch:1000 in 37 | if 0 < n then begin 38 | for i = 1 to n do 39 | Stack.push i t 40 | done; 41 | work () 42 | end 43 | in 44 | work () 45 | else 46 | let domain_index = i - n_adders in 47 | if blocking_take then 48 | let rec work () = 49 | let n = Countdown.alloc n_msgs_to_take ~domain_index ~batch:1000 in 50 | if n <> 0 then begin 51 | for _ = 1 to n do 52 | ignore (Stack.pop_blocking t) 53 | done; 54 | work () 55 | end 56 | in 57 | work () 58 | else 59 | let rec work () = 60 | let n = Countdown.alloc n_msgs_to_take ~domain_index ~batch:1000 in 61 | if n <> 0 then begin 62 | for _ = 1 to n do 63 | while Option.is_none (Stack.pop_opt t) do 64 | Backoff.once Backoff.default |> ignore 65 | done 66 | done; 67 | work () 68 | end 69 | in 70 | work () 71 | in 72 | 73 | let config = 74 | let format role blocking n = 75 | Printf.sprintf "%d %s%s%s" n 76 | (if blocking then "" else "nb ") 77 | role 78 | (if n = 1 then "" else "s") 79 | in 80 | Printf.sprintf "%s, %s" 81 | (format "adder" blocking_add n_adders) 82 | (format "taker" blocking_take n_takers) 83 | in 84 | 85 | Times.record ~budgetf ~n_domains ~init ~work () 86 | |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config 87 | 88 | let run_suite ~budgetf = 89 | run_one_domain ~budgetf () 90 | @ (Util.cross 91 | (Util.cross [ 1; 2; 4 ] [ false ]) 92 | (Util.cross [ 1; 2; 4 ] [ false; true ]) 93 | |> List.concat_map 94 | @@ fun ((n_adders, blocking_add), (n_takers, blocking_take)) -> 95 | if Domain.recommended_domain_count () < n_adders + n_takers then [] 96 | else run_one ~budgetf ~n_adders ~blocking_add ~n_takers ~blocking_take () 97 | ) 98 | -------------------------------------------------------------------------------- /bench/bench_queue.ml: -------------------------------------------------------------------------------- 1 | open Kcas_data 2 | open Multicore_bench 3 | 4 | let run_one_domain ~budgetf ?(n_msgs = 50 * Util.iter_factor) () = 5 | let t = Queue.create () in 6 | 7 | let op push = if push then Queue.push 101 t else Queue.take_opt t |> ignore in 8 | 9 | let init _ = 10 | assert (Queue.is_empty t); 11 | Util.generate_push_and_pop_sequence n_msgs 12 | in 13 | let work _ bits = Util.Bits.iter op bits in 14 | 15 | Times.record ~budgetf ~n_domains:1 ~init ~work () 16 | |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config:"one domain" 17 | 18 | let run_one ~budgetf ?(n_adders = 2) ?(blocking_add = false) ?(n_takers = 2) 19 | ?(blocking_take = false) ?(n_msgs = 50 * Util.iter_factor) () = 20 | let n_domains = n_adders + n_takers in 21 | 22 | let t = Queue.create () in 23 | 24 | let n_msgs_to_take = Countdown.create ~n_domains:n_takers () in 25 | let n_msgs_to_add = Countdown.create ~n_domains:n_adders () in 26 | 27 | let init _ = 28 | assert (Queue.is_empty t); 29 | Countdown.non_atomic_set n_msgs_to_take n_msgs; 30 | Countdown.non_atomic_set n_msgs_to_add n_msgs 31 | in 32 | let work i () = 33 | if i < n_adders then 34 | let domain_index = i in 35 | let rec work () = 36 | let n = Countdown.alloc n_msgs_to_add ~domain_index ~batch:1000 in 37 | if 0 < n then begin 38 | for i = 1 to n do 39 | Queue.add i t 40 | done; 41 | work () 42 | end 43 | in 44 | work () 45 | else 46 | let domain_index = i - n_adders in 47 | if blocking_take then 48 | let rec work () = 49 | let n = Countdown.alloc n_msgs_to_take ~domain_index ~batch:1000 in 50 | if n <> 0 then begin 51 | for _ = 1 to n do 52 | ignore (Queue.take_blocking t) 53 | done; 54 | work () 55 | end 56 | in 57 | work () 58 | else 59 | let rec work () = 60 | let n = Countdown.alloc n_msgs_to_take ~domain_index ~batch:1000 in 61 | if n <> 0 then begin 62 | for _ = 1 to n do 63 | while Option.is_none (Queue.take_opt t) do 64 | Backoff.once Backoff.default |> ignore 65 | done 66 | done; 67 | work () 68 | end 69 | in 70 | work () 71 | in 72 | 73 | let config = 74 | let format role blocking n = 75 | Printf.sprintf "%d %s%s%s" n 76 | (if blocking then "" else "nb ") 77 | role 78 | (if n = 1 then "" else "s") 79 | in 80 | Printf.sprintf "%s, %s" 81 | (format "adder" blocking_add n_adders) 82 | (format "taker" blocking_take n_takers) 83 | in 84 | 85 | Times.record ~budgetf ~n_domains ~init ~work () 86 | |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config 87 | 88 | let run_suite ~budgetf = 89 | run_one_domain ~budgetf () 90 | @ (Util.cross 91 | (Util.cross [ 1; 2; 4 ] [ false ]) 92 | (Util.cross [ 1; 2; 4 ] [ false; true ]) 93 | |> List.concat_map 94 | @@ fun ((n_adders, blocking_add), (n_takers, blocking_take)) -> 95 | if Domain.recommended_domain_count () < n_adders + n_takers then [] 96 | else run_one ~budgetf ~n_adders ~blocking_add ~n_takers ~blocking_take () 97 | ) 98 | -------------------------------------------------------------------------------- /src/kcas_data/dllist.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | (** Doubly-linked list. 4 | 5 | The interface provides a subset of the operations of the doubly-linked list 6 | data structure provided by the 7 | {{:https://opam.ocaml.org/packages/lwt-dllist/}lwt-dllist} package with some 8 | omissions: 9 | 10 | - The sequence iterators, e.g. [iter_l], [iter_node_l], [fold_l], 11 | [find_node_opt_l], and [find_node_l], are not provided. 12 | - The [length] operation is not provided. 13 | - The [set] operation is not provided. 14 | 15 | A non-compositional {!take_all} operation is added for 16 | {{:https://en.wikipedia.org/wiki/Privatization_(computer_programming)}privatization} 17 | as well as conversions to a list of nodes ({!to_nodes_l} and {!to_nodes_r}) 18 | and to a list of values ({!to_list_l} and {!to_list_r}). 19 | 20 | Probably the main reason to use a doubly-linked list like this rather than 21 | e.g. a ['a list Loc.t] is the ability to remove a node without having to 22 | potentially iterate through the list: 23 | 24 | {[ 25 | let node_of_x = add_l x list in 26 | (* ... and then later somewhere else ... *) 27 | remove node_of_x 28 | ]} 29 | 30 | A doubly-linked list can also be used as a deque or double-ended queue, but 31 | a deque implementation that doesn't allow individual nodes to be removed is 32 | likely to be faster. *) 33 | 34 | (** {1 Common interface} *) 35 | 36 | type !'a t 37 | (** Type of a doubly-linked list containing {!node}s of type ['a]. *) 38 | 39 | type !'a node 40 | (** Type of a node containing a value of type ['a]. *) 41 | 42 | val create : unit -> 'a t 43 | (** [create ()] creates a new doubly-linked list. *) 44 | 45 | (** {2 Operations on nodes} *) 46 | 47 | val create_node : 'a -> 'a node 48 | (** [create_node value] creates a new doubly-linked list node that is not in any 49 | list. The node can then e.g. be added to a list using {!move_l} or 50 | {!move_r}. *) 51 | 52 | val get : 'a node -> 'a 53 | (** [get node] returns the value stored in the {!node}. *) 54 | 55 | (** {1 Compositional interface} *) 56 | 57 | module Xt : 58 | Dllist_intf.Ops 59 | with type 'a t := 'a t 60 | with type 'a node := 'a node 61 | with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn 62 | with type ('x, 'fn) blocking_fn := xt:'x Xt.t -> 'fn 63 | (** Explicit transaction log passing on doubly-linked lists. *) 64 | 65 | (** {1 Non-compositional interface} *) 66 | 67 | include 68 | Dllist_intf.Ops 69 | with type 'a t := 'a t 70 | with type 'a node := 'a node 71 | with type ('x, 'fn) fn := 'fn 72 | with type ('x, 'fn) blocking_fn := ?timeoutf:float -> 'fn 73 | 74 | val take_all : 'a t -> 'a t 75 | (** [take_all l] removes all nodes of the doubly-linked list [l] and returns a 76 | new doubly-linked list containing the removed nodes. *) 77 | 78 | exception Empty 79 | (** Raised when {!take_l} or {!take_r} is applied to an empty doubly-linked 80 | list. *) 81 | 82 | val take_l : 'a t -> 'a 83 | (** [take_l l] removes and returns the value of the leftmost node of the 84 | doubly-linked list [l], or raises {!Empty} if the list is empty. 85 | 86 | @raise Empty if the list is empty. *) 87 | 88 | val take_r : 'a t -> 'a 89 | (** [take_r l] removes and returns the value of the rightmost node of the 90 | doubly-linked list [l], or raises {!Empty} if the list is empty. 91 | 92 | @raise Empty if the list is empty. *) 93 | -------------------------------------------------------------------------------- /test/kcas_data/hashtbl_test.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | open Kcas_data 3 | 4 | let replace_and_remove () = 5 | let t = Hashtbl.create () in 6 | let n = try int_of_string Sys.argv.(1) with _ -> 10 * Util.iter_factor in 7 | for i = 1 to n do 8 | Hashtbl.replace t i i 9 | done; 10 | assert (Hashtbl.length t = n); 11 | assert (Seq.fold_left (fun n _ -> n + 1) 0 (Hashtbl.to_seq t) = n); 12 | for i = 1 to n do 13 | assert (Hashtbl.find t i = i) 14 | done; 15 | for i = 1 to n do 16 | Hashtbl.remove t i 17 | done; 18 | assert (Hashtbl.length t = 0) 19 | 20 | let large_tx () = 21 | let t = Hashtbl.create () in 22 | let n = 1_000 in 23 | let tx ~xt = 24 | for i = 1 to n do 25 | Hashtbl.Xt.replace ~xt t i i 26 | done 27 | in 28 | Xt.commit { tx }; 29 | assert (Seq.fold_left (fun n _ -> n + 1) 0 (Hashtbl.to_seq t) = n); 30 | let tx ~xt = 31 | for i = 1 to n do 32 | assert (Hashtbl.Xt.find_opt ~xt t i = Some i) 33 | done 34 | in 35 | Xt.commit { tx } 36 | 37 | let large_ops () = 38 | let t = Hashtbl.create () in 39 | Hashtbl.add t "key" 1; 40 | Hashtbl.add t "key" 2; 41 | Hashtbl.add t "key" 3; 42 | assert ( 43 | Hashtbl.fold (fun k v kvs -> (k, v) :: kvs) t [] 44 | = [ ("key", 1); ("key", 2); ("key", 3) ]); 45 | let stats = Hashtbl.stats t in 46 | assert (stats.num_bindings = 3); 47 | assert (stats.num_buckets > 0); 48 | assert (stats.max_bucket_length = 3); 49 | assert (stats.bucket_histogram.(3) = 1); 50 | assert (Hashtbl.find_all t "key" = [ 3; 2; 1 ]); 51 | let t' = Hashtbl.copy t in 52 | assert (Hashtbl.find_all t' "key" = [ 3; 2; 1 ]); 53 | let t' = Hashtbl.rebuild ~hashed_type:(Hashtbl.hashed_type_of t) t in 54 | assert (Hashtbl.find_all t' "key" = [ 3; 2; 1 ]); 55 | assert ( 56 | Hashtbl.to_seq t |> List.of_seq = [ ("key", 3); ("key", 2); ("key", 1) ]); 57 | let u = Hashtbl.to_seq t |> Hashtbl.of_seq in 58 | Hashtbl.swap t u; 59 | assert (Hashtbl.find t "key" = 1); 60 | assert (Hashtbl.find u "key" = 3); 61 | Hashtbl.filter_map_inplace (fun _ v -> if v = 1 then None else Some (-v)) u; 62 | assert (Hashtbl.find_all u "key" = [ -3; -2 ]); 63 | Hashtbl.swap u t; 64 | assert (Hashtbl.length t = 2); 65 | (match 66 | Hashtbl.filter_map_inplace 67 | (fun _ v -> if v = -2 then raise Exit else None) 68 | t 69 | with 70 | | _ -> assert false 71 | | exception Exit -> ()); 72 | assert (Hashtbl.find_all t "key" = [ -3; -2 ]); 73 | assert (Hashtbl.length t = 2) 74 | 75 | let basics () = 76 | let t = Hashtbl.create () in 77 | assert (Hashtbl.length t = 0); 78 | Hashtbl.replace t "foo" 101; 79 | Hashtbl.remove t "bar"; 80 | assert (Hashtbl.length t = 1); 81 | Hashtbl.replace t "bar" 19; 82 | assert (Hashtbl.mem t "foo"); 83 | assert (not (Hashtbl.mem t "bal")); 84 | Hashtbl.replace t "foo" 76; 85 | assert (Hashtbl.length t = 2); 86 | assert (Hashtbl.find_opt t "lol" = None); 87 | assert ( 88 | Hashtbl.to_seq t |> List.of_seq |> List.sort compare 89 | = [ ("bar", 19); ("foo", 76) ]); 90 | Hashtbl.remove t "foo"; 91 | assert (Hashtbl.length t = 1); 92 | assert (Hashtbl.to_seq t |> List.of_seq |> List.sort compare = [ ("bar", 19) ]); 93 | Hashtbl.reset t; 94 | assert (not (Hashtbl.mem t "nope")) 95 | 96 | let () = 97 | Alcotest.run "Hashtbl" 98 | [ 99 | ("replace and remove", [ Alcotest.test_case "" `Quick replace_and_remove ]); 100 | ("large tx", [ Alcotest.test_case "" `Quick large_tx ]); 101 | ("large ops", [ Alcotest.test_case "" `Quick large_ops ]); 102 | ("basics", [ Alcotest.test_case "" `Quick basics ]); 103 | ] 104 | -------------------------------------------------------------------------------- /test/kcas/ms_queue_test.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | module Q = struct 4 | type 'a node = Nil | Node of 'a * 'a node Loc.t 5 | type 'a queue = { head : 'a node Loc.t Loc.t; tail : 'a node Loc.t Atomic.t } 6 | 7 | let queue () = 8 | let next = Loc.make Nil in 9 | { head = Loc.make next; tail = Atomic.make next } 10 | 11 | let try_dequeue ~xt { head; _ } = 12 | let old_head = Xt.get ~xt head in 13 | match Xt.get ~xt old_head with 14 | | Nil -> None 15 | | Node (value, next) -> 16 | Xt.set ~xt head next; 17 | Some value 18 | 19 | let enqueue ~xt { tail; _ } value = 20 | let new_tail = Loc.make Nil in 21 | let new_node = Node (value, new_tail) in 22 | let rec find_and_set_tail old_tail = 23 | match Xt.compare_and_swap ~xt old_tail Nil new_node with 24 | | Nil -> () 25 | | Node (_, old_tail) -> find_and_set_tail old_tail 26 | in 27 | find_and_set_tail (Atomic.get tail); 28 | let rec fix_tail () = 29 | let old_tail = Atomic.get tail in 30 | if 31 | Loc.get new_tail == Nil 32 | && not (Atomic.compare_and_set tail old_tail new_tail) 33 | then fix_tail () 34 | in 35 | Xt.post_commit ~xt fix_tail 36 | 37 | let check_tail { tail; _ } = Loc.get (Atomic.get tail) == Nil 38 | end 39 | 40 | let failure exit msg = 41 | Atomic.set exit true; 42 | Printf.printf "%s\n%!" msg; 43 | failwith msg 44 | 45 | let write_skew_test n = 46 | let q1 = Q.queue () and q2 = Q.queue () in 47 | 48 | let push_to_q2 ~xt = 49 | match Q.try_dequeue ~xt q1 with None -> Q.enqueue ~xt q2 42 | Some _ -> () 50 | and push_to_q1 ~xt = 51 | match Q.try_dequeue ~xt q2 with None -> Q.enqueue ~xt q1 24 | Some _ -> () 52 | and clear ~xt = (Q.try_dequeue ~xt q1, Q.try_dequeue ~xt q2) in 53 | 54 | let barrier = Atomic.make 3 in 55 | let sync () = 56 | Atomic.decr barrier; 57 | while Atomic.get barrier != 0 do 58 | Domain.cpu_relax () 59 | done 60 | in 61 | 62 | let exit = Atomic.make false in 63 | 64 | let domains = 65 | [ 66 | Domain.spawn (fun () -> 67 | sync (); 68 | while not (Atomic.get exit) do 69 | Xt.commit { tx = push_to_q1 } 70 | done); 71 | Domain.spawn (fun () -> 72 | sync (); 73 | while not (Atomic.get exit) do 74 | Xt.commit { tx = push_to_q2 } 75 | done); 76 | ] 77 | in 78 | 79 | sync (); 80 | for _ = 1 to n do 81 | match Xt.commit { tx = clear } with 82 | | Some _, Some _ -> failure exit "write skew!" 83 | | _ -> () 84 | done; 85 | Atomic.set exit true; 86 | 87 | List.iter Domain.join domains 88 | 89 | let tail_leak_test n = 90 | let q = Q.queue () in 91 | 92 | let m = 2 in 93 | 94 | let exit = Atomic.make false 95 | and rounds = Array.init m @@ fun _ -> Atomic.make (n * 2) in 96 | let finished () = 97 | Array.exists (fun round -> Atomic.get round <= 0) rounds || Atomic.get exit 98 | and sync i = 99 | let n = Atomic.fetch_and_add rounds.(i) (-1) - 1 in 100 | while rounds |> Array.exists @@ fun round -> n < Atomic.get round do 101 | if Atomic.get exit then failwith "exit" 102 | done 103 | in 104 | 105 | let domain i () = 106 | try 107 | while not (finished ()) do 108 | sync i; 109 | 110 | Xt.commit { tx = Q.enqueue q 42 }; 111 | if None == Xt.commit { tx = Q.try_dequeue q } then 112 | failure exit "impossible!"; 113 | 114 | sync i; 115 | 116 | if not (Q.check_tail q) then failure exit "tail leak!" 117 | done 118 | with e -> 119 | Atomic.set exit true; 120 | raise e 121 | in 122 | 123 | List.init m domain |> List.map Domain.spawn |> List.iter Domain.join 124 | 125 | let () = 126 | let n = try int_of_string Sys.argv.(1) with _ -> 1 * Util.iter_factor in 127 | Alcotest.run "MS queue" 128 | [ 129 | ( "write skew", 130 | [ Alcotest.test_case "" `Quick (fun () -> write_skew_test n) ] ); 131 | ( "tail leak", 132 | [ Alcotest.test_case "" `Quick (fun () -> tail_leak_test n) ] ); 133 | ] 134 | -------------------------------------------------------------------------------- /bench/bench_loc.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | open Multicore_bench 3 | 4 | type _ op = 5 | | Get : int op 6 | | Incr : int op 7 | | Push_and_pop : int list op 8 | | Cas_int : int op 9 | | Xchg_int : int op 10 | | Swap : (int * int) op 11 | 12 | let run_one (type a) ~budgetf ?(n_iter = 250 * Util.iter_factor) (op : a op) = 13 | let name, extra, (value : a) = 14 | match op with 15 | | Get -> ("get", 10, 42) 16 | | Incr -> ("incr", 1, 0) 17 | | Push_and_pop -> ("push & pop", 2, []) 18 | | Cas_int -> ("cas int", 1, 0) 19 | | Xchg_int -> ("xchg int", 1, 0) 20 | | Swap -> ("swap", 1, (4, 2)) 21 | in 22 | 23 | let n_iter = n_iter * extra in 24 | 25 | let loc = Loc.make value in 26 | 27 | let init _ = () in 28 | let work _ () = 29 | match op with 30 | | Get -> 31 | let rec loop i = 32 | if i > 0 then begin 33 | let a = 34 | Loc.get (Sys.opaque_identity loc) 35 | land Loc.get (Sys.opaque_identity loc) 36 | and b = 37 | Loc.get (Sys.opaque_identity loc) 38 | land Loc.get (Sys.opaque_identity loc) 39 | and c = 40 | Loc.get (Sys.opaque_identity loc) 41 | land Loc.get (Sys.opaque_identity loc) 42 | and d = 43 | Loc.get (Sys.opaque_identity loc) 44 | land Loc.get (Sys.opaque_identity loc) 45 | in 46 | loop (i - 8 + (a - b) + (c - d)) 47 | end 48 | in 49 | loop n_iter 50 | | Incr -> 51 | let rec loop i = 52 | if i > 0 then begin 53 | Loc.incr loc; 54 | Loc.incr loc; 55 | Loc.incr loc; 56 | Loc.incr loc; 57 | Loc.incr loc; 58 | Loc.incr loc; 59 | loop (i - 6) 60 | end 61 | in 62 | loop n_iter 63 | | Push_and_pop -> 64 | let[@inline] push x = Loc.modify x (fun xs -> 101 :: xs) 65 | and[@inline] pop x = 66 | Loc.modify x (function [] -> [] | _ :: xs -> xs) 67 | in 68 | let rec loop i = 69 | if i > 0 then begin 70 | push loc; 71 | pop loc |> ignore; 72 | push loc; 73 | pop loc |> ignore; 74 | loop (i - 4) 75 | end 76 | in 77 | loop n_iter 78 | | Cas_int -> 79 | let rec loop i = 80 | if i > 0 then begin 81 | Loc.compare_and_set loc 0 1 |> ignore; 82 | Loc.compare_and_set loc 1 0 |> ignore; 83 | Loc.compare_and_set loc 0 1 |> ignore; 84 | Loc.compare_and_set loc 1 0 |> ignore; 85 | Loc.compare_and_set loc 0 1 |> ignore; 86 | Loc.compare_and_set loc 1 0 |> ignore; 87 | loop (i - 6) 88 | end 89 | in 90 | loop n_iter 91 | | Xchg_int -> 92 | let rec loop i = 93 | if i > 0 then begin 94 | Loc.exchange loc 1 |> ignore; 95 | Loc.exchange loc 0 |> ignore; 96 | Loc.exchange loc 1 |> ignore; 97 | Loc.exchange loc 0 |> ignore; 98 | Loc.exchange loc 1 |> ignore; 99 | Loc.exchange loc 0 |> ignore; 100 | loop (i - 6) 101 | end 102 | in 103 | loop n_iter 104 | | Swap -> 105 | let[@inline] swap x = Loc.modify x (fun (x, y) -> (y, x)) in 106 | let rec loop i = 107 | if i > 0 then begin 108 | swap loc; 109 | swap loc; 110 | swap loc; 111 | swap loc; 112 | swap loc; 113 | swap loc; 114 | loop (i - 6) 115 | end 116 | in 117 | loop n_iter 118 | in 119 | 120 | Times.record ~budgetf ~n_domains:1 ~init ~work () 121 | |> Times.to_thruput_metrics ~n:n_iter ~singular:"op" ~config:name 122 | 123 | let run_suite ~budgetf = 124 | [ 125 | run_one ~budgetf Get; 126 | run_one ~budgetf Incr; 127 | run_one ~budgetf Push_and_pop; 128 | run_one ~budgetf Cas_int; 129 | run_one ~budgetf Xchg_int; 130 | run_one ~budgetf Swap; 131 | ] 132 | |> List.concat 133 | -------------------------------------------------------------------------------- /src/kcas_data/dllist_intf.ml: -------------------------------------------------------------------------------- 1 | module type Ops = sig 2 | type 'a t 3 | type 'a node 4 | type ('x, 'fn) fn 5 | type ('x, 'fn) blocking_fn 6 | 7 | (** {2 Operations on nodes} *) 8 | 9 | val remove : ('x, 'a node -> unit) fn 10 | (** [remove n] removes the node [n] from the doubly-linked list it is part of. 11 | [remove] is idempotent. *) 12 | 13 | val move_l : ('x, 'a node -> 'a t -> unit) fn 14 | (** [move_l n l] removes the node [n] from the doubly-linked list it is part 15 | of and then adds it to the left of the list [l]. *) 16 | 17 | val move_r : ('x, 'a node -> 'a t -> unit) fn 18 | (** [move_r n l] removes the node [n] from the doubly-linked list it is part 19 | of and then adds it to the right of the list [l]. *) 20 | 21 | (** {2 Operations on lists} *) 22 | 23 | val is_empty : ('x, 'a t -> bool) fn 24 | (** [is_empty l] determines whether the doubly-linked list [l] is empty or 25 | not. *) 26 | 27 | (** {3 Adding or removing values at the ends of a list} *) 28 | 29 | val add_l : ('x, 'a -> 'a t -> 'a node) fn 30 | (** [add_l v l] creates and returns a new node with the value [v] and adds the 31 | node to the left of the doubly-linked list [l]. *) 32 | 33 | val add_r : ('x, 'a -> 'a t -> 'a node) fn 34 | (** [add_r v l] creates and returns a new node with the value [v] and adds the 35 | node to the right of the doubly-linked list [l]. *) 36 | 37 | val take_opt_l : ('x, 'a t -> 'a option) fn 38 | (** [take_opt_l l] removes and returns the value of leftmost node of the 39 | doubly-linked list [l], or return [None] if the list is empty. *) 40 | 41 | val take_opt_r : ('x, 'a t -> 'a option) fn 42 | (** [take_opt_r l] removes and returns the value of rightmost node of the 43 | doubly-linked list [l], or return [None] if the list is empty. *) 44 | 45 | val take_blocking_l : ('x, 'a t -> 'a) blocking_fn 46 | (** [take_blocking_l l] removes and returns the value of leftmost node of the 47 | doubly-linked list [l], or blocks waiting for the list to become 48 | non-empty. *) 49 | 50 | val take_blocking_r : ('x, 'a t -> 'a) blocking_fn 51 | (** [take_blocking_r l] removes and returns the value of rightmost node of the 52 | doubly-linked list [l], or blocks waiting for the list to become 53 | non-empty. *) 54 | 55 | (** {3 Moving all nodes between lists} *) 56 | 57 | val swap : ('x, 'a t -> 'a t -> unit) fn 58 | (** [swap l1 l2] exchanges the nodes of the doubly-linked lists [l1] and [l2]. 59 | *) 60 | 61 | val transfer_l : ('x, 'a t -> 'a t -> unit) fn 62 | (** [transfer_l l1 l2] removes all nodes of [l1] and adds them to the left of 63 | [l2]. *) 64 | 65 | val transfer_r : ('x, 'a t -> 'a t -> unit) fn 66 | (** [transfer_r l1 l2] removes all nodes of [l1] and adds them to the right of 67 | [l2]. *) 68 | 69 | (** {3 Extracting all values or nodes from a list} *) 70 | 71 | val to_list_l : ('x, 'a t -> 'a list) fn 72 | (** [to_list_l l] collects the values of the nodes of the doubly-linked list 73 | [l] to a list in left-to-right order. 74 | 75 | {b NOTE}: This operation is linear time, [O(n)], and should typically be 76 | avoided unless the list is privatized, e.g. by using {!take_all}. *) 77 | 78 | val to_list_r : ('x, 'a t -> 'a list) fn 79 | (** [to_list_r l] collects the values of the nodes of the doubly-linked list 80 | [l] to a list in right-to-left order. 81 | 82 | {b NOTE}: This operation is linear time, [O(n)], and should typically be 83 | avoided unless the list is privatized, e.g. by using {!take_all}. *) 84 | 85 | val to_nodes_l : ('x, 'a t -> 'a node list) fn 86 | (** [to_nodes_l l] collects the nodes of the doubly-linked list [l] to a list 87 | in left-to-right order. 88 | 89 | {b NOTE}: This operation is linear time, [O(n)], and should typically be 90 | avoided unless the list is privatized, e.g. by using {!take_all}. *) 91 | 92 | val to_nodes_r : ('x, 'a t -> 'a node list) fn 93 | (** [to_nodes_r l] collects the nodes of the doubly-linked list [l] to a list 94 | in right-to-left order. 95 | 96 | {b NOTE}: This operation is linear time, [O(n)], and should typically be 97 | avoided unless the list is privatized, e.g. by using {!take_all}. *) 98 | end 99 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 0.7.0 2 | 3 | - Numerous minor internal improvements (@polytypic) 4 | - Added many benchmarks to allow better understanding of the overheads of 5 | composable transactions (@polytypic) 6 | - Exposed shape of `_ Loc.t` to avoid float array pessimization (@polytypic) 7 | - Made `Accumulator` automatically scaling and removed optional `n_way` 8 | arguments (@polytypic) 9 | - Use polymorphic variant for `mode` (@polytypic) 10 | - Add `?backoff` to `Loc.compare_and_set` (@polytypic) 11 | - Remove the Op API (@polytypic, @lyrm) 12 | - Fix `Hashtbl.clear` (@polytypic) 13 | - Fix single location updates to be linearizable (@polytypic) 14 | - Add `Xt.compare_and_set` (@polytypic) 15 | - Add `Dllist.create_node value` (@polytypic) 16 | - Workarounds for CSE optimization (@polytypic) 17 | - Changed to use `(implicit_transitive_deps false)` (@polytypic) 18 | - Move `Backoff` module to its own `backoff` package (@lyrm, @polytypic) 19 | - Support padding to avoid false sharing (@polytypic) 20 | - Pass through `?timeoutf` to blocking operations on data structures 21 | (@polytypic) 22 | - Ported to OCaml 4.13 (@polytypic) 23 | 24 | ## 0.6.1 25 | 26 | - Ported to OCaml 4.14 (@polytypic) 27 | 28 | ## 0.6.0 29 | 30 | - Add timeout support to potentially blocking operations (@polytypic) 31 | - Add explicit `~xt` parameter to `Xt.call` to make it polymorphic (@polytypic) 32 | 33 | ## 0.5.3 34 | 35 | - Fix to also snapshot and rollback post commit actions (@polytypic) 36 | - Fix `Loc.compare_and_set` to have strong semantics (@polytypic) 37 | - Fix single location no-op updates to be strictly serializable (@polytypic) 38 | - Add `Dllist.move_l node list` and `Dllist.move_r node list` (@polytypic) 39 | 40 | ## 0.5.2 41 | 42 | - Improve `Hashtbl` read-write performance and add `swap` (@polytypic) 43 | - Avoid some unnecessary verifies of read-only CMP operations (@polytypic) 44 | 45 | ## 0.5.1 46 | 47 | - Add synchronizing variable `Mvar` to `kcas_data` (@polytypic) 48 | - Fix to allow retry from within `Xt.update` and `Xt.modify` (@polytypic) 49 | 50 | ## 0.5.0 51 | 52 | - Add nested conditional transaction support (@polytypic) 53 | - Add explicit location validation support (@polytypic) 54 | 55 | ## 0.4.0 56 | 57 | - Allocation of location ids in a transaction log friendly order (@polytypic) 58 | - Per location operating mode selection (@Dashy-Dolphin, review: @polytypic) 59 | - Injectivity `!'a Kcas_data.Dllist.t` annotation (@polytypic) 60 | 61 | ## 0.3.1 62 | 63 | - Added doubly-linked list `Dllist` to `kcas_data` (@polytypic) 64 | - Minor optimizations (@polytypic) 65 | 66 | ## 0.3.0 67 | 68 | - Remove the `Tx` API (@polytypic) 69 | - Add blocking support to turn kcas into a proper STM (@polytypic, review: 70 | @lyrm) 71 | - Add periodic validation of transactions (@polytypic) 72 | 73 | ## 0.2.4 74 | 75 | - Introduce `kcas_data` companion package of composable lock-free data 76 | structures (@polytypic) 77 | - Add `is_in_log` operation to determine whether a location has been accessed by 78 | a transaction (@polytypic) 79 | - Add `Loc.modify` (@polytypic) 80 | - Add transactional `swap` operation to exchange contents of two locations 81 | (@polytypic) 82 | - Injectivity `!'a Loc.t` and variance `+'a Tx.t` annotations (@polytypic) 83 | 84 | ## 0.2.3 85 | 86 | - Add support for post commit actions to transactions (@polytypic) 87 | - Bring `Xt` and `Tx` access combinators to parity and add `compare_and_swap` 88 | (@polytypic) 89 | 90 | ## 0.2.2 91 | 92 | - New explicit transaction log passing API based on idea by @gasche (@polytypic, 93 | review: @samoht and @lyrm) 94 | 95 | ## 0.2.1 96 | 97 | - New k-CAS-n-CMP algorithm extending the GKMZ algorithm (@polytypic, review: 98 | @bartoszmodelski) 99 | 100 | ## 0.2.0 101 | 102 | - Complete redesign adding a new transaction API (@polytypic, review: 103 | @bartoszmodelski) 104 | 105 | ## 0.1.8 106 | 107 | - Fix a bug in GKMZ implementation (@polytypic, review: @bartoszmodelski) 108 | 109 | ## 0.1.7 110 | 111 | - Change to use the new GKMZ algorithm (@polytypic, review: @bartoszmodelski) 112 | 113 | ## 0.1.6 114 | 115 | - Add preflights sorting and checks (@bartoszmodelski, review: @polytypic) 116 | 117 | ## 0.1.5 118 | 119 | - Republish in opam (update opam, dune) (@tmcgilchrist, review: @Sudha247) 120 | -------------------------------------------------------------------------------- /doc/scheduler-interop.md: -------------------------------------------------------------------------------- 1 | # Scheduler interop 2 | 3 | The blocking mechanism in **Kcas** is based on a 4 | [_domain local await_](https://github.com/ocaml-multicore/domain-local-await) 5 | mechanism that schedulers can choose to implement to allow libraries like 6 | **Kcas** to work with them. 7 | 8 | Implementing schedulers is not really what casual users of **Kcas** are supposed 9 | to do. Below is an example of a _toy_ scheduler whose purpose is only to give a 10 | sketch of how a scheduler can provide the domain local await mechanism. 11 | 12 | Let's also demonstrate the use of the 13 | [`Queue`](https://ocaml-multicore.github.io/kcas/doc/kcas_data/Kcas_data/Queue/index.html), 14 | [`Stack`](https://ocaml-multicore.github.io/kcas/doc/kcas_data/Kcas_data/Stack/index.html), 15 | and 16 | [`Promise`](https://ocaml-multicore.github.io/kcas/doc/kcas_data/Kcas_data/Promise/index.html) 17 | implementations that are conveniently provided by 18 | [**Kcas_data**](https://ocaml-multicore.github.io/kcas/doc/kcas_data/Kcas_data/index.html). 19 | 20 | 28 | 29 | Here is the full toy scheduler module: 30 | 31 | ```ocaml 32 | module Scheduler : sig 33 | type t 34 | val spawn : unit -> t 35 | val join : t -> unit 36 | val fiber : t -> (unit -> 'a) -> 'a Promise.t 37 | end = struct 38 | open Effect.Deep 39 | type _ Effect.t += 40 | | Suspend : (('a, unit) continuation -> unit) -> 'a Effect.t 41 | type t = { 42 | queue: (unit -> unit) Queue.t; 43 | domain: unit Domain.t 44 | } 45 | let spawn () = 46 | let queue = Queue.create () in 47 | let rec scheduler work = 48 | let effc (type a) : a Effect.t -> _ = function 49 | | Suspend ef -> Some ef 50 | | _ -> None in 51 | try_with work () { effc }; 52 | match Queue.take_opt queue with 53 | | Some work -> scheduler work 54 | | None -> () in 55 | let prepare_for_await _ = 56 | let state = Atomic.make `Init in 57 | let release () = 58 | if Atomic.get state != `Released then 59 | match Atomic.exchange state `Released with 60 | | `Awaiting k -> 61 | Queue.add (continue k) queue 62 | | _ -> () in 63 | let await () = 64 | if Atomic.get state != `Released then 65 | Effect.perform @@ Suspend (fun k -> 66 | if not (Atomic.compare_and_set state `Init 67 | (`Awaiting k)) then 68 | continue k ()) 69 | in 70 | Domain_local_await.{ release; await } in 71 | let domain = Domain.spawn @@ fun () -> 72 | try 73 | while true do 74 | let work = Queue.take_blocking queue in 75 | Domain_local_await.using 76 | ~prepare_for_await 77 | ~while_running:(fun () -> scheduler work) 78 | done 79 | with Exit -> () in 80 | { queue; domain } 81 | let join t = 82 | Queue.add (fun () -> raise Exit) t.queue; 83 | Domain.join t.domain 84 | let fiber t thunk = 85 | let (promise, resolver) = Promise.create () in 86 | Queue.add 87 | (fun () -> Promise.resolve resolver (thunk ())) 88 | t.queue; 89 | promise 90 | end 91 | ``` 92 | 93 | The idea is that one can spawn a scheduler to run on a new domain. Then one can 94 | run fibers on the scheduler. Because the scheduler provides the domain local 95 | await mechanism libraries like **Kcas** can use it to block in a scheduler 96 | independent and friendly manner. 97 | 98 | Let's then demonstrate the integration. To start we spawn a scheduler: 99 | 100 | ```ocaml 101 | # let scheduler = Scheduler.spawn () 102 | val scheduler : Scheduler.t = 103 | ``` 104 | 105 | The scheduler is now eagerly awaiting for fibers to run. Let's give it a couple 106 | of them, but, let's first create a queue and a stack to communicate with the 107 | fibers: 108 | 109 | ```ocaml 110 | # let in_queue : int Queue.t = Queue.create () 111 | val in_queue : int Kcas_data.Queue.t = 112 | # let out_stack : int Stack.t = Stack.create () 113 | val out_stack : int Kcas_data.Stack.t = 114 | ``` 115 | 116 | The first fiber we create just copies elements from the `in_queue` to the 117 | `out_stack`: 118 | 119 | ```ocaml 120 | # ignore @@ Scheduler.fiber scheduler @@ fun () -> 121 | while true do 122 | let elem = Queue.take_blocking in_queue in 123 | Printf.printf "Giving %d...\n%!" elem; 124 | Stack.push elem out_stack 125 | done 126 | - : unit = () 127 | ``` 128 | 129 | The second fiber awaits to take two elements from the `out_stack`, updates a 130 | state in between, and then returns their sum: 131 | 132 | ```ocaml 133 | # let state = Loc.make 0 134 | val state : int Loc.t = Kcas.Loc.Loc {Kcas.Loc.state = ; id = } 135 | # let sync_to target = 136 | state 137 | |> Loc.get_as @@ fun current -> 138 | Retry.unless (target <= current) 139 | val sync_to : int -> unit = 140 | # let a_promise = Scheduler.fiber scheduler @@ fun () -> 141 | let x = Stack.pop_blocking out_stack in 142 | Printf.printf "First you gave me %d.\n%!" x; 143 | Loc.set state 1; 144 | let y = Stack.pop_blocking out_stack in 145 | Printf.printf "Then you gave me %d.\n%!" y; 146 | Loc.set state 2; 147 | x + y 148 | val a_promise : int Promise.t = 149 | ``` 150 | 151 | To interact with the fibers, we add some elements to the `in_queue`: 152 | 153 | ```ocaml 154 | # Queue.add 14 in_queue; sync_to 1 155 | Giving 14... 156 | First you gave me 14. 157 | - : unit = () 158 | # Queue.add 28 in_queue; sync_to 2 159 | Giving 28... 160 | Then you gave me 28. 161 | - : unit = () 162 | # Promise.await a_promise 163 | - : int = 42 164 | ``` 165 | 166 | As can be seen above, the scheduler multiplexes the domain among the fibers. 167 | Notice that thanks to the domain local await mechanism we could just perform 168 | blocking operations without thinking about the schedulers. Communication between 169 | the main domain, the scheduler domain, and the fibers _just works_ ™. 170 | 171 | Time to close the shop. 172 | 173 | ```ocaml 174 | # Scheduler.join scheduler 175 | - : unit = () 176 | ``` 177 | 178 | _That's all Folks!_ 179 | -------------------------------------------------------------------------------- /src/kcas_data/kcas_data.mli: -------------------------------------------------------------------------------- 1 | (** This is a library of compositional lock-free data structures and primitives 2 | for communication and synchronization implemented using {!Kcas}. 3 | 4 | All data structure implementations in this library are concurrency and 5 | parallelism safe and should strive to provide the following guarantees: 6 | 7 | - Provided operations are {i strictly serializable} (i.e. both 8 | {{:https://en.wikipedia.org/wiki/Linearizability}linerizable} and 9 | {{:https://en.wikipedia.org/wiki/Serializability}serializable}). 10 | - Provided operations are efficient, either 11 | ({{:https://en.wikipedia.org/wiki/Amortized_analysis}amortized}) constant 12 | time, [O(1)], or logarithmic time, [O(log(n))]. 13 | - Provided operations are 14 | {{:https://en.wikipedia.org/wiki/Non-blocking_algorithm#Lock-freedom}lock-free} 15 | and designed to avoid 16 | {{:https://en.wikipedia.org/wiki/Starvation_(computer_science)}starvation} 17 | under moderate contention. 18 | - Provided read-only operations scale perfectly when only read-only 19 | operations are performed in parallel. 20 | 21 | Unobvious exceptions to the above guarantees should be clearly and 22 | explicitly documented. 23 | 24 | The main feature of these data structure implementations is their 25 | compositionality. If your application does not need compositionality, then 26 | other concurrency and parallelism safe data structure libraries may 27 | potentially offer better performance. 28 | 29 | But why should you care about composability? 30 | 31 | As an example, consider the implementation of a least-recently-used (LRU) 32 | cache or a bounded associative map, but first, let's open the libraries for 33 | convenience: 34 | 35 | {[ 36 | open Kcas 37 | open Kcas_data 38 | ]} 39 | 40 | A simple sequential approach to implement a LRU cache is to use a hash table 41 | and a doubly-linked list and keep track of the amount of space in the cache: 42 | 43 | {[ 44 | type ('k, 'v) cache = { 45 | space : int Loc.t; 46 | table : ('k, 'k Dllist.node * 'v) Hashtbl.t; 47 | order : 'k Dllist.t; 48 | } 49 | ]} 50 | 51 | On a cache lookup the doubly-linked list node corresponding to the accessed 52 | key is moved to the left end of the list: 53 | 54 | {[ 55 | let get_opt { table; order; _ } key = 56 | Hashtbl.find_opt table key 57 | |> Option.map @@ fun (node, datum) -> 58 | Dllist.move_l node order; 59 | datum 60 | ]} 61 | 62 | On a cache update, in case of overflow, the association corresponding to the 63 | node on the right end of the list is dropped: 64 | 65 | {[ 66 | let set { table; order; space; _ } key datum = 67 | let node = 68 | match Hashtbl.find_opt table key with 69 | | None -> 70 | if 0 = Loc.update space (fun n -> max 0 (n - 1)) then 71 | Dllist.take_opt_r order |> Option.iter (Hashtbl.remove table); 72 | Dllist.add_l key order 73 | | Some (node, _) -> 74 | Dllist.move_l node order; 75 | node 76 | in 77 | Hashtbl.replace table key (node, datum) 78 | ]} 79 | 80 | Sequential algorithms such as the above are so common that one does not even 81 | think about them. Unfortunately, in a concurrent setting the above doesn't 82 | work even if the individual operations on lists and hash tables were atomic 83 | as they are in this library. 84 | 85 | But how would one make the operations on a cache atomic as a whole? As 86 | explained by Maurice Herlihy in one of his talks on 87 | {{:https://youtu.be/ZkUrl8BZHjk?t=1503} Transactional Memory} adding locks 88 | to protect the atomicity of the operation is far from trivial. 89 | 90 | Fortunately, rather than having to e.g. wrap the cache implementation behind 91 | a {{:https://en.wikipedia.org/wiki/Lock_(computer_science)} mutex} and make 92 | another individually atomic yet uncomposable data structure, or having to 93 | learn a completely different programming model and rewrite the cache 94 | implementation, we can use the transactional programming model provided by 95 | the {!Kcas} library and the transactional data structures provided by this 96 | library to trivially convert the previous implementation to a lock-free 97 | composable transactional data structure. 98 | 99 | To make it so, we simply use transactional versions, [*.Xt.*], of operations 100 | on the data structures and explicitly pass a transaction log, [~xt], to the 101 | operations. For the [get_opt] operation we end up with 102 | 103 | {[ 104 | let get_opt ~xt { table; order; _ } key = 105 | Hashtbl.Xt.find_opt ~xt table key 106 | |> Option.map @@ fun (node, datum) -> 107 | Dllist.Xt.move_l ~xt node order; 108 | datum 109 | ]} 110 | 111 | and the [set] operation is just as easy to convert to a transactional 112 | version. One way to think about transactions is that they give us back the 113 | ability to compose programs such as the above. *) 114 | 115 | (** {1 [Stdlib] style data structures} 116 | 117 | The data structures in this section are designed to closely mimic the 118 | corresponding unsynchronized data structures in the OCaml [Stdlib]. Each of 119 | these provide a non-compositional, but concurrency and parallelism safe, 120 | interface that is close to the [Stdlib] equivalent. Additionally, 121 | compositional transactional interfaces are provided for some operations. 122 | 123 | These implementations will use more space than the corresponding [Stdlib] 124 | data structures. Performance, when accessed concurrently, should be 125 | competitive or superior compared to naïve locking. *) 126 | 127 | module Hashtbl = Hashtbl 128 | module Queue = Queue 129 | module Stack = Stack 130 | 131 | (** {1 Communication and synchronization primitives} *) 132 | 133 | module Mvar = Mvar 134 | module Promise = Promise 135 | 136 | (** {1 Linked data structures} *) 137 | 138 | module Dllist = Dllist 139 | 140 | (** {1 Utilities} *) 141 | 142 | module Accumulator = Accumulator 143 | -------------------------------------------------------------------------------- /src/kcas_data/queue.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | type 'a t = { 4 | front : 'a Elems.t Loc.t; 5 | middle : 'a Elems.t Loc.t; 6 | back : 'a Elems.t Loc.t; 7 | } 8 | 9 | let alloc ~front ~middle ~back = 10 | (* We allocate locations in specific order to make most efficient use of the 11 | splay-tree based transaction log. *) 12 | let front = Loc.make ~padded:true front 13 | and middle = Loc.make ~padded:true middle 14 | and back = Loc.make ~padded:true back in 15 | Multicore_magic.copy_as_padded { back; middle; front } 16 | 17 | let create () = alloc ~front:Elems.empty ~middle:Elems.empty ~back:Elems.empty 18 | 19 | let copy q = 20 | let tx ~xt = (Xt.get ~xt q.front, Xt.get ~xt q.middle, Xt.get ~xt q.back) in 21 | let front, middle, back = Xt.commit { tx } in 22 | alloc ~front ~middle ~back 23 | 24 | module Xt = struct 25 | let is_empty ~xt t = 26 | (* We access locations in order of allocation to make most efficient use of 27 | the splay-tree based transaction log. *) 28 | Xt.get ~xt t.front == Elems.empty 29 | && Xt.get ~xt t.middle == Elems.empty 30 | && Xt.get ~xt t.back == Elems.empty 31 | 32 | let length ~xt { back; middle; front } = 33 | Elems.length (Xt.get ~xt front) 34 | + Elems.length (Xt.get ~xt middle) 35 | + Elems.length (Xt.get ~xt back) 36 | 37 | let add ~xt x q = Xt.modify ~xt q.back @@ Elems.cons x 38 | let push = add 39 | 40 | (** Cooperative helper to move elems from back to middle. *) 41 | let back_to_middle ~middle ~back = 42 | let tx ~xt = 43 | let xs = Xt.exchange ~xt back Elems.empty in 44 | if xs == Elems.empty || Xt.exchange ~xt middle xs != Elems.empty then 45 | raise_notrace Exit 46 | in 47 | try Xt.commit { tx } with Exit -> () 48 | 49 | let take_opt_finish ~xt front elems = 50 | let elems = Elems.rev elems in 51 | Xt.set ~xt front (Elems.tl_safe elems); 52 | Elems.hd_opt elems 53 | 54 | let take_opt ~xt t = 55 | let front = t.front in 56 | let elems = Xt.update ~xt front Elems.tl_safe in 57 | if elems != Elems.empty then Elems.hd_opt elems 58 | else 59 | let middle = t.middle and back = t.back in 60 | if not (Xt.is_in_log ~xt middle || Xt.is_in_log ~xt back) then 61 | back_to_middle ~middle ~back; 62 | let elems = Xt.exchange ~xt middle Elems.empty in 63 | if elems != Elems.empty then take_opt_finish ~xt front elems 64 | else 65 | let elems = Xt.exchange ~xt back Elems.empty in 66 | if elems != Elems.empty then take_opt_finish ~xt front elems else None 67 | 68 | let take_blocking ~xt q = Xt.to_blocking ~xt (take_opt q) 69 | 70 | let peek_opt_finish ~xt front elems = 71 | let elems = Elems.rev elems in 72 | Xt.set ~xt front elems; 73 | Elems.hd_opt elems 74 | 75 | let peek_opt ~xt t = 76 | let front = t.front in 77 | let elems = Xt.get ~xt front in 78 | if elems != Elems.empty then Elems.hd_opt elems 79 | else 80 | let middle = t.middle and back = t.back in 81 | if not (Xt.is_in_log ~xt middle || Xt.is_in_log ~xt back) then 82 | back_to_middle ~middle ~back; 83 | let elems = Xt.exchange ~xt middle Elems.empty in 84 | if elems != Elems.empty then peek_opt_finish ~xt front elems 85 | else 86 | let elems = Xt.exchange ~xt back Elems.empty in 87 | if elems != Elems.empty then peek_opt_finish ~xt front elems else None 88 | 89 | let peek_blocking ~xt q = Xt.to_blocking ~xt (peek_opt q) 90 | 91 | let clear ~xt t = 92 | Xt.set ~xt t.front Elems.empty; 93 | Xt.set ~xt t.middle Elems.empty; 94 | Xt.set ~xt t.back Elems.empty 95 | 96 | let swap ~xt q1 q2 = 97 | let front = Xt.get ~xt q1.front 98 | and middle = Xt.get ~xt q1.middle 99 | and back = Xt.get ~xt q1.back in 100 | let front = Xt.exchange ~xt q2.front front 101 | and middle = Xt.exchange ~xt q2.middle middle 102 | and back = Xt.exchange ~xt q2.back back in 103 | Xt.set ~xt q1.front front; 104 | Xt.set ~xt q1.middle middle; 105 | Xt.set ~xt q1.back back 106 | 107 | let seq_of ~front ~middle ~back = 108 | (* Sequence construction is lazy, so this function is O(1). *) 109 | Seq.empty 110 | |> Elems.rev_prepend_to_seq back 111 | |> Elems.rev_prepend_to_seq middle 112 | |> Elems.prepend_to_seq front 113 | 114 | let to_seq ~xt t = 115 | let front = Xt.get ~xt t.front 116 | and middle = Xt.get ~xt t.middle 117 | and back = Xt.get ~xt t.back in 118 | seq_of ~front ~middle ~back 119 | 120 | let take_all ~xt t = 121 | let front = Xt.exchange ~xt t.front Elems.empty 122 | and middle = Xt.exchange ~xt t.middle Elems.empty 123 | and back = Xt.exchange ~xt t.back Elems.empty in 124 | seq_of ~front ~middle ~back 125 | end 126 | 127 | let is_empty q = Kcas.Xt.commit { tx = Xt.is_empty q } 128 | let length q = Kcas.Xt.commit { tx = Xt.length q } 129 | 130 | let add x q = 131 | (* Fenceless is safe as we always update. *) 132 | Loc.fenceless_modify q.back @@ Elems.cons x 133 | 134 | let push = add 135 | 136 | let take_opt q = 137 | (* Fenceless is safe as we revert to a transaction in case we didn't update. *) 138 | match Loc.fenceless_update q.front Elems.tl_safe |> Elems.hd_opt with 139 | | None -> Kcas.Xt.commit { tx = Xt.take_opt q } 140 | | some -> some 141 | 142 | let take_blocking ?timeoutf q = 143 | (* Fenceless is safe as we revert to a transaction in case we didn't update. *) 144 | match Loc.fenceless_update q.front Elems.tl_safe |> Elems.hd_opt with 145 | | None -> Kcas.Xt.commit ?timeoutf { tx = Xt.take_blocking q } 146 | | Some elem -> elem 147 | 148 | let take_all q = Kcas.Xt.commit { tx = Xt.take_all q } 149 | 150 | let peek_opt q = 151 | match Loc.get q.front |> Elems.hd_opt with 152 | | None -> Kcas.Xt.commit { tx = Xt.peek_opt q } 153 | | some -> some 154 | 155 | let peek_blocking ?timeoutf q = 156 | Kcas.Xt.commit ?timeoutf { tx = Xt.peek_blocking q } 157 | 158 | let clear q = Kcas.Xt.commit { tx = Xt.clear q } 159 | let swap q1 q2 = Kcas.Xt.commit { tx = Xt.swap q1 q2 } 160 | let to_seq q = Kcas.Xt.commit { tx = Xt.to_seq q } 161 | let iter f q = Seq.iter f @@ to_seq q 162 | let fold f a q = Seq.fold_left f a @@ to_seq q 163 | 164 | exception Empty 165 | 166 | let[@inline] of_option = function None -> raise Empty | Some value -> value 167 | let peek s = peek_opt s |> of_option 168 | let top = peek 169 | let take s = take_opt s |> of_option 170 | -------------------------------------------------------------------------------- /src/kcas_data/hashtbl.mli: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | (** Hash table. 4 | 5 | The interface provides a subset of the OCaml [Stdlib.Hashtbl] module with 6 | some changes: 7 | 8 | - The functorial interface of the [Stdlib.Hashtbl] is not provided. Instead 9 | the constructor functions, {!create}, {!of_seq}, and {!rebuild}, take an 10 | optional [HashedType] module as an argument. By default {!create} returns 11 | a randomized hash table. 12 | - The [add_seq] and [replace_seq] operations are not provided at all. 13 | - Non-instance specific operations related to randomization (e.g. 14 | [randomize], [is_randomized]) are not provided. 15 | - Non-instance specific operations related to hashing (e.g. [hash], 16 | [seeded_hash], [hash_param], [seeded_hash_param]) are not provided. 17 | 18 | Compositional versions of {!find}, {!to_seq}, {!to_seq_keys}, 19 | {!to_seq_values}, {!rebuild}, {!copy}, {!iter}, {!filter_map_inplace}, 20 | {!fold}, and {!stats} are not provided. 21 | 22 | Please note that the design is intentionally based on [Stdlib.Hashtbl] and 23 | copies its semantics as accurately as possible. Some of the operations come 24 | with warnings. 25 | 26 | The hash table implementation is designed to avoid starvation. Read-only 27 | accesses can generally proceed in parallel without interference. Write 28 | accesses that do not change the number of bindings can proceed in parallel 29 | as long as they hit different internal buckets. Write accesses that change 30 | the number of bindings use a scalable {!Accumulator} and only make 31 | infrequent random checks to determine whether the hash table should be 32 | resized. *) 33 | 34 | (** {1 Common interface} *) 35 | 36 | type (!'k, !'v) t 37 | (** The type of hash tables from type ['k] to type ['v]. *) 38 | 39 | type 'k hashed_type = (module Stdlib.Hashtbl.HashedType with type t = 'k) 40 | (** First-class [HashedType] module type abbreviation. *) 41 | 42 | val create : 43 | ?hashed_type:'k hashed_type -> 44 | ?min_buckets:int -> 45 | ?max_buckets:int -> 46 | unit -> 47 | ('k, 'v) t 48 | (** [create ()] returns a new empty hash table. 49 | 50 | - The default [hash] is computed as [Stdlib.Hashtbl.hash (Random.bits ())]. 51 | - The default [equal] is [(=)]. 52 | - The default [min_buckets] is unspecified and a given [min_buckets] may be 53 | adjusted by the implementation. 54 | - The default [max_buckets] is the minimum of [1 lsl 30] and suitably 55 | adjusted [Sys.max_array_length] and a given [max_buckets] may be adjusted 56 | by the implementation. 57 | 58 | Hash tables are automatically internally resized. *) 59 | 60 | val hashed_type_of : ('k, 'v) t -> 'k hashed_type 61 | (** [hashed_type_of t] returns a copy of the hashed type used when the hash 62 | table [t] was {!create}d. *) 63 | 64 | val min_buckets_of : ('k, 'v) t -> int 65 | (** [min_buckets_of t] returns the minimum number of buckets of the hash table 66 | [t]. 67 | 68 | {b NOTE}: The returned value may not be the same as given to {!create}. *) 69 | 70 | val max_buckets_of : ('k, 'v) t -> int 71 | (** [max_buckets_of t] returns the maximum number of buckets of the hash table 72 | [t]. 73 | 74 | {b NOTE}: The returned value may not be the same as given to {!create}. *) 75 | 76 | val of_seq : 77 | ?hashed_type:'k hashed_type -> 78 | ?min_buckets:int -> 79 | ?max_buckets:int -> 80 | ('k * 'v) Seq.t -> 81 | ('k, 'v) t 82 | (** [of_seq assoc] creates a new hash table from the given association sequence 83 | [assoc]. The associations are added in the same order as they appear in the 84 | sequence, using {!replace}, which means that if two pairs have the same key, 85 | only the latest one will appear in the table. See {!create} for the optional 86 | arguments. 87 | 88 | ⚠️ [of_seq (to_seq t)] does not necessarily copy the bindings of a hash table 89 | correctly. *) 90 | 91 | (** {1 Compositional interface} *) 92 | 93 | module Xt : 94 | Hashtbl_intf.Ops 95 | with type ('k, 'v) t := ('k, 'v) t 96 | with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn 97 | (** Explicit transaction log passing on hash tables. *) 98 | 99 | (** {1 Non-compositional interface} *) 100 | 101 | include 102 | Hashtbl_intf.Ops 103 | with type ('k, 'v) t := ('k, 'v) t 104 | with type ('x, 'fn) fn := 'fn 105 | 106 | val find : ('k, 'v) t -> 'k -> 'v 107 | (** [find t k] returns the current binding of [k] in hash table [t], or raises 108 | [Not_found] if no such binding exists. *) 109 | 110 | val to_seq : ('k, 'v) t -> ('k * 'v) Seq.t 111 | (** [to_seq t] takes a snapshot of the keys and values in the hash table and 112 | returns them as an association sequence. Bindings of each individual key 113 | appear in the sequence in reverse order of their introduction. 114 | 115 | ⚠️ [of_seq (to_seq t)] does not necessarily copy the bindings of a hash table 116 | correctly. *) 117 | 118 | val to_seq_keys : ('k, 'v) t -> 'k Seq.t 119 | (** [to_seq_keys t] is equivalent to [to_seq t |> Seq.map fst]. 120 | 121 | ⚠️ The sequence may include duplicates. *) 122 | 123 | val to_seq_values : ('k, 'v) t -> 'v Seq.t 124 | (** [to_seq_values t] is equivalent to [to_seq t |> Seq.map snd]. 125 | 126 | ⚠️ The sequence may include values of bindings that are hidden. *) 127 | 128 | val rebuild : 129 | ?hashed_type:'k hashed_type -> 130 | ?min_buckets:int -> 131 | ?max_buckets:int -> 132 | ('k, 'v) t -> 133 | ('k, 'v) t 134 | (** [rebuild t] returns a copy of the given hash table [t] optionally rehashing 135 | all of the bindings. 136 | 137 | See {!create} for descriptions of the optional arguments. Unlike {!create}, 138 | [rebuild] uses the given hash table [t] as a template to get defaults for 139 | the optional arguments. *) 140 | 141 | val copy : ('k, 'v) t -> ('k, 'v) t 142 | (** [copy t] is equivalent to [rebuild t]. In other words, the returned hash 143 | table uses the same {!hashed_type} (and other parameters) as the given hash 144 | table [t]. *) 145 | 146 | val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit 147 | (** [iter f t] is equivalent to [Seq.iter (fun (k, v) -> f k v) (to_seq t)]. *) 148 | 149 | val filter_map_inplace : ('k -> 'v -> 'v option) -> ('k, 'v) t -> unit 150 | (** [filter_map_inplace f t] applies [f] to all bindings in the hash table [t] 151 | and updates each binding depending on the result of [f]. If [f] returns 152 | [None], the binding is discarded. If [f] returns [Some new_value], the 153 | binding is updated to associate the key to the [new_value]. 154 | 155 | ⚠️ The given [f] may be called multiple times for the same bindings from 156 | multiple domains in parallel. *) 157 | 158 | val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c 159 | (** [fold f t a] is equivalent to 160 | [Seq.fold_left (fun a (k, v) -> f k v a) a (to_seq t)]. *) 161 | 162 | val stats : ('a, 'b) t -> Stdlib.Hashtbl.statistics 163 | (** [stats t] returns statistics about the hash table [t]. *) 164 | -------------------------------------------------------------------------------- /test/kcas_data/linearizable_chaining_example.ml: -------------------------------------------------------------------------------- 1 | (** This demonstrates an approach to composing non-blocking linearizable data 2 | structures inspired by the paper 3 | 4 | Concurrent Size by Gal Sela and Erez Petrank 5 | https://arxiv.org/pdf/2209.07100.pdf 6 | 7 | First a [Hashtbl] is implemented that allows [idempotent_add] and 8 | [idempotent_remove] operations to be specified. The hash table makes sure 9 | that any operations that might witness the addition or the removal of a key 10 | will perform those operations before returning. 11 | 12 | Then a [Hashtbl_with_order] is implemented on top of the [Hashtbl] by 13 | specifying the [idempotent_add] and [idempotent_remove] operation such that 14 | they update a lock-free doubly-linked list to maintain a list of the keys in 15 | the hash table in insertion [order]. In other words, we composed a hash 16 | table with a doubly-linked list, both lock-free and linearizable, resulting 17 | in a lock-free linearizable hash table that maintains the insertion order. 18 | 19 | Finally a STM tests is used test against linearizability violations. 20 | 21 | Note that this technique does not require the use of Kcas or software 22 | transactional memory, but Kcas makes it easy to demonstrate the technique, 23 | because it makes it easy to implement idempotent non-blocking operations 24 | based on existing non-blocking data structures, such as the doubly-linked 25 | list used in this example. *) 26 | 27 | open Kcas 28 | open Kcas_data 29 | 30 | module type Hashtbl_base = sig 31 | type (!'k, !'v) t 32 | 33 | val find_opt : ('k, 'v) t -> 'k -> 'v option 34 | val add : ('k, 'v) t -> 'k -> 'v -> bool 35 | val remove : ('k, 'v) t -> 'k -> bool 36 | end 37 | 38 | module Hashtbl : sig 39 | include Hashtbl_base 40 | 41 | val create : 42 | ?idempotent_add:('k -> 'v -> ('k, 'v) t -> unit) -> 43 | ?idempotent_remove:('k -> 'v -> ('k, 'v) t -> unit) -> 44 | unit -> 45 | ('k, 'v) t 46 | end = struct 47 | type ('k, 'v) t = { 48 | idempotent_add : 'k -> 'v -> ('k, 'v) t -> unit; 49 | idempotent_remove : 'k -> 'v -> ('k, 'v) t -> unit; 50 | hashtbl : ('k, ('k, 'v) value) Hashtbl.t; 51 | } 52 | 53 | and ('k, 'v) value = 54 | | Add of { event : ('k, 'v) t -> unit; value : 'v } 55 | | Remove of { event : ('k, 'v) t -> unit } 56 | 57 | let create ?(idempotent_add = fun _ _ _ -> ()) 58 | ?(idempotent_remove = fun _ _ _ -> ()) () = 59 | let hashtbl = Hashtbl.create () in 60 | { idempotent_add; idempotent_remove; hashtbl } 61 | 62 | let find_opt t key = 63 | match Hashtbl.find_opt t.hashtbl key with 64 | | None -> None 65 | | Some (Add r) -> 66 | r.event t; 67 | Some r.value 68 | | Some (Remove r) -> 69 | r.event t; 70 | None 71 | 72 | let add t key value = 73 | let event = t.idempotent_add key value in 74 | let value = Add { event; value } in 75 | let tx ~xt = 76 | begin 77 | match Hashtbl.Xt.find_opt ~xt t.hashtbl key with 78 | | None -> true 79 | | Some (Add r) -> 80 | r.event t; 81 | false 82 | | Some (Remove r) -> 83 | r.event t; 84 | true 85 | end 86 | && begin 87 | Hashtbl.Xt.replace ~xt t.hashtbl key value; 88 | true 89 | end 90 | in 91 | Xt.commit { tx } 92 | && begin 93 | event t; 94 | true 95 | end 96 | 97 | let remove t key = 98 | let tx ~xt = 99 | begin 100 | match Hashtbl.Xt.find_opt ~xt t.hashtbl key with 101 | | None -> false 102 | | Some (Add r) -> 103 | r.event t; 104 | let event = t.idempotent_remove key r.value in 105 | let value = Remove { event } in 106 | Hashtbl.Xt.replace ~xt t.hashtbl key value; 107 | true 108 | | Some (Remove r) -> 109 | r.event t; 110 | false 111 | end 112 | in 113 | Xt.commit { tx } 114 | && 115 | let tx ~xt = 116 | match Hashtbl.Xt.find_opt ~xt t.hashtbl key with 117 | | None -> () 118 | | Some (Add _) -> () 119 | | Some (Remove r) -> 120 | r.event t; 121 | Hashtbl.Xt.remove ~xt t.hashtbl key 122 | in 123 | Xt.commit { tx }; 124 | true 125 | end 126 | 127 | module Hashtbl_with_order : sig 128 | include Hashtbl_base 129 | 130 | val create : unit -> ('k, 'v) t 131 | val order : ('k, 'v) t -> 'k list 132 | end = struct 133 | type ('k, 'v) t = { 134 | table : ('k, 'k Dllist.node * 'v) Hashtbl.t; 135 | order : 'k Dllist.t; 136 | } 137 | 138 | let create () = 139 | let order = Dllist.create () in 140 | let idempotent_add _key (node, _value) = 141 | let node = Loc.make (Some node) in 142 | let tx ~xt = 143 | match Xt.exchange ~xt node None with 144 | | None -> () 145 | | Some node -> Dllist.Xt.move_l ~xt node order 146 | in 147 | fun _table -> Xt.commit { tx } 148 | in 149 | let idempotent_remove _key (node, _value) = 150 | let node = Loc.make (Some node) in 151 | let tx ~xt = 152 | match Xt.exchange ~xt node None with 153 | | None -> () 154 | | Some node -> Dllist.Xt.remove ~xt node 155 | in 156 | fun _table -> Xt.commit { tx } 157 | in 158 | let table = Hashtbl.create ~idempotent_add ~idempotent_remove () in 159 | { table; order } 160 | 161 | let find_opt t key = 162 | Hashtbl.find_opt t.table key |> Option.map (fun (_, v) -> v) 163 | 164 | let add t key value = Hashtbl.add t.table key (Dllist.create_node key, value) 165 | let remove t key = Hashtbl.remove t.table key 166 | let order t = Dllist.to_list_l t.order 167 | end 168 | 169 | module Spec = struct 170 | type cmd = Add of int | Remove of int | Order 171 | 172 | let show_cmd = function 173 | | Add key -> "Add " ^ string_of_int key 174 | | Remove key -> "Remove " ^ string_of_int key 175 | | Order -> "Order" 176 | 177 | type state = int list 178 | type sut = (int, unit) Hashtbl_with_order.t 179 | 180 | let arb_cmd _s = 181 | QCheck.( 182 | [ 183 | (* Generate keys in small range so that [remove] hits. *) 184 | Gen.int_range 1 5 |> Gen.map (fun key -> Add key); 185 | Gen.int_range 1 5 |> Gen.map (fun key -> Remove key); 186 | Gen.return Order; 187 | ] 188 | |> Gen.oneof |> make ~print:show_cmd) 189 | 190 | let init_state = [] 191 | let init_sut () = Hashtbl_with_order.create () 192 | let cleanup _ = () 193 | 194 | let next_state c s = 195 | match c with 196 | | Add key -> if List.for_all (( != ) key) s then key :: s else s 197 | | Remove key -> List.filter (( != ) key) s 198 | | Order -> s 199 | 200 | let precond _ _ = true 201 | 202 | let run c d = 203 | let open STM in 204 | match c with 205 | | Add key -> Res (bool, Hashtbl_with_order.add d key ()) 206 | | Remove key -> Res (bool, Hashtbl_with_order.remove d key) 207 | | Order -> Res (list int, Hashtbl_with_order.order d) 208 | 209 | let postcond c (s : state) res = 210 | let open STM in 211 | match (c, res) with 212 | | Add key, Res ((Bool, _), res) -> res = List.for_all (( != ) key) s 213 | | Remove key, Res ((Bool, _), res) -> res = List.exists (( == ) key) s 214 | | Order, Res ((List Int, _), res) -> res = s 215 | | _, _ -> false 216 | end 217 | 218 | let () = 219 | Stm_run.run ~count:1000 ~verbose:true ~name:"Hashtbl_with_order" (module Spec) 220 | |> exit 221 | -------------------------------------------------------------------------------- /src/kcas_data/dllist.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | (** Tagged GADT for representing doubly-linked lists. 4 | 5 | The [lhs] and [rhs] fields are the first two fields in both a [List] and a 6 | [Node] so that it is possible (by using an unsafe cast) to access the fields 7 | without knowing whether the target is a [List] or a [Node]. *) 8 | type ('a, _) tdt = 9 | | List : { 10 | lhs : 'a cursor Loc.t; 11 | (** [lhs] points to the rightmost node of this list or to the list 12 | itself in case the list is empty. *) 13 | rhs : 'a cursor Loc.t; 14 | (** [rhs] points to the leftmost node of this list or to the list 15 | itself in case the list is empty. *) 16 | } 17 | -> ('a, [> `List ]) tdt 18 | | Node : { 19 | lhs : 'a cursor Loc.t; 20 | (** [lhs] points to the node on the left side of this node, to the 21 | list if this node is the leftmost node, or to the node itself in 22 | case this node is not in any list. *) 23 | rhs : 'a cursor Loc.t; 24 | (** [rhs] points to the node on the right side of this node, to the 25 | list if this node is the rightmost node, or to the node itself in 26 | case this node is not in any list. *) 27 | value : 'a; 28 | } 29 | -> ('a, [> `Node ]) tdt 30 | 31 | and 'a cursor = At : ('a, [< `List | `Node ]) tdt -> 'a cursor [@@unboxed] 32 | 33 | type 'a t = ('a, [ `List ]) tdt 34 | type 'a node = ('a, [ `Node ]) tdt 35 | 36 | external as_list : ('a, _) tdt -> 'a t = "%identity" 37 | external as_node : ('a, _) tdt -> 'a node = "%identity" 38 | 39 | let[@inline] get (Node { value; _ } : 'a node) = value 40 | 41 | let[@inline] lhs_of list_or_node = 42 | let (List list_r) = as_list list_or_node in 43 | list_r.lhs 44 | 45 | let[@inline] rhs_of list_or_node = 46 | let (List list_r) = as_list list_or_node in 47 | list_r.rhs 48 | 49 | let[@inline] value_of (Node node_r : 'a node) = node_r.value 50 | 51 | let create () = 52 | let lhs = Loc.make ~padded:true (Obj.magic ()) in 53 | let rhs = Loc.make ~padded:true (Obj.magic ()) in 54 | let list = Multicore_magic.copy_as_padded (List { lhs; rhs }) in 55 | Loc.set lhs (At list); 56 | Loc.set rhs (At list); 57 | list 58 | 59 | let create_node value = 60 | let node = 61 | let lhs = Loc.make (Obj.magic ()) in 62 | let rhs = Loc.make (Obj.magic ()) in 63 | Node { lhs; rhs; value } 64 | in 65 | Loc.set (lhs_of node) (At node); 66 | Loc.set (rhs_of node) (At node); 67 | node 68 | 69 | let create_node_with ~lhs ~rhs value = 70 | Node { lhs = Loc.make (At lhs); rhs = Loc.make (At rhs); value } 71 | 72 | module Xt = struct 73 | let remove ~xt node = 74 | let (At rhs) = Xt.exchange ~xt (rhs_of node) (At node) in 75 | if At rhs != At node then begin 76 | let (At lhs) = Xt.exchange ~xt (lhs_of node) (At node) in 77 | Xt.set ~xt (lhs_of rhs) (At lhs); 78 | Xt.set ~xt (rhs_of lhs) (At rhs) 79 | end 80 | 81 | let is_empty ~xt list = Xt.get ~xt (lhs_of list) == At list 82 | 83 | let add_node_l ~xt node list = 84 | let (At rhs) = Xt.get ~xt (rhs_of list) in 85 | assert (Loc.fenceless_get (lhs_of node) == At list); 86 | Loc.set (rhs_of node) (At rhs); 87 | Xt.set ~xt (rhs_of list) (At node); 88 | Xt.set ~xt (lhs_of rhs) (At node); 89 | node 90 | 91 | let add_l ~xt value list = 92 | let (At rhs) = Xt.get ~xt (rhs_of list) in 93 | let node = create_node_with ~lhs:list ~rhs value in 94 | Xt.set ~xt (rhs_of list) (At node); 95 | Xt.set ~xt (lhs_of rhs) (At node); 96 | node 97 | 98 | let add_node_r ~xt node list = 99 | let (At lhs) = Xt.get ~xt (lhs_of list) in 100 | Loc.set (lhs_of node) (At lhs); 101 | assert (Loc.fenceless_get (rhs_of node) == At list); 102 | Xt.set ~xt (lhs_of list) (At node); 103 | Xt.set ~xt (rhs_of lhs) (At node); 104 | node 105 | 106 | let add_r ~xt value list = 107 | let (At lhs) = Xt.get ~xt (lhs_of list) in 108 | let node = create_node_with ~lhs ~rhs:list value in 109 | Xt.set ~xt (lhs_of list) (At node); 110 | Xt.set ~xt (rhs_of lhs) (At node); 111 | node 112 | 113 | let move_l ~xt node list = 114 | let (At list_rhs) = Xt.exchange ~xt (rhs_of list) (At node) in 115 | if At list_rhs != At node then begin 116 | let (At node_lhs) = Xt.exchange ~xt (lhs_of node) (At list) in 117 | let (At node_rhs) = Xt.exchange ~xt (rhs_of node) (At list_rhs) in 118 | if At node_lhs != At node then begin 119 | Xt.set ~xt (rhs_of node_lhs) (At node_rhs); 120 | Xt.set ~xt (lhs_of node_rhs) (At node_lhs) 121 | end; 122 | Xt.set ~xt (lhs_of list_rhs) (At node) 123 | end 124 | 125 | let move_r ~xt node list = 126 | let (At list_lhs) = Xt.exchange ~xt (lhs_of list) (At node) in 127 | if At list_lhs != At node then begin 128 | let (At node_rhs) = Xt.exchange ~xt (rhs_of node) (At list) in 129 | let (At node_lhs) = Xt.exchange ~xt (lhs_of node) (At list_lhs) in 130 | if At node_rhs != At node then begin 131 | Xt.set ~xt (rhs_of node_lhs) (At node_rhs); 132 | Xt.set ~xt (lhs_of node_rhs) (At node_lhs) 133 | end; 134 | Xt.set ~xt (rhs_of list_lhs) (At node) 135 | end 136 | 137 | let take_opt_l ~xt list = 138 | let (At rhs) = Xt.get ~xt (rhs_of list) in 139 | if At rhs == At list then None 140 | else 141 | let node = as_node rhs in 142 | remove ~xt node; 143 | Some (value_of node) 144 | 145 | let take_opt_r ~xt list = 146 | let (At lhs) = Xt.get ~xt (lhs_of list) in 147 | if At lhs == At list then None 148 | else 149 | let node = as_node lhs in 150 | remove ~xt node; 151 | Some (value_of node) 152 | 153 | let take_blocking_l ~xt list = Xt.to_blocking ~xt (take_opt_l list) 154 | let take_blocking_r ~xt list = Xt.to_blocking ~xt (take_opt_r list) 155 | 156 | let transfer_l ~xt t1 t2 = 157 | let (At t1_rhs) = Xt.exchange ~xt (rhs_of t1) (At t1) in 158 | if At t1_rhs != At t1 then begin 159 | let (At t1_lhs) = Xt.exchange ~xt (lhs_of t1) (At t1) in 160 | let (At t2_rhs) = Xt.exchange ~xt (rhs_of t2) (At t1_rhs) in 161 | Xt.set ~xt (lhs_of t2_rhs) (At t1_lhs); 162 | Xt.set ~xt (lhs_of t1_rhs) (At t2); 163 | Xt.set ~xt (rhs_of t1_lhs) (At t2_rhs) 164 | end 165 | 166 | let transfer_r ~xt t1 t2 = 167 | let (At t1_rhs) = Xt.exchange ~xt (rhs_of t1) (At t1) in 168 | if At t1_rhs != At t1 then begin 169 | let (At t1_lhs) = Xt.exchange ~xt (lhs_of t1) (At t1) in 170 | let (At t2_lhs) = Xt.exchange ~xt (lhs_of t2) (At t1_lhs) in 171 | Xt.set ~xt (rhs_of t2_lhs) (At t1_rhs); 172 | Xt.set ~xt (rhs_of t1_lhs) (At t2); 173 | Xt.set ~xt (lhs_of t1_rhs) (At t2_lhs) 174 | end 175 | 176 | let swap ~xt t1 t2 = 177 | let (At t1_rhs) = Xt.get ~xt (rhs_of t1) in 178 | if At t1_rhs == At t1 then transfer_l ~xt t2 t1 179 | else 180 | let (At t2_lhs) = Xt.get ~xt (lhs_of t2) in 181 | if At t2_lhs == At t2 then transfer_l ~xt t1 t2 182 | else 183 | let (At t1_lhs) = Xt.exchange ~xt (lhs_of t1) (At t2_lhs) in 184 | let (At t2_rhs) = Xt.exchange ~xt (rhs_of t2) (At t1_rhs) in 185 | Xt.set ~xt (lhs_of t2) (At t1_lhs); 186 | Xt.set ~xt (rhs_of t1) (At t2_rhs); 187 | Xt.set ~xt (lhs_of t2_rhs) (At t1); 188 | Xt.set ~xt (rhs_of t2_lhs) (At t1); 189 | Xt.set ~xt (lhs_of t1_rhs) (At t2); 190 | Xt.set ~xt (rhs_of t1_lhs) (At t2) 191 | 192 | let[@tail_mod_cons] rec to_list_as_l ~xt f list (At at) = 193 | if At at == At list then [] 194 | else f (as_node at) :: to_list_as_l ~xt f list (Xt.get ~xt (rhs_of at)) 195 | 196 | let to_list_as_l ~xt f list = 197 | to_list_as_l ~xt f list (Xt.get ~xt (rhs_of list)) 198 | 199 | let to_list_l ~xt list = to_list_as_l ~xt get list 200 | let to_nodes_l ~xt list = to_list_as_l ~xt Fun.id list 201 | 202 | let[@tail_mod_cons] rec to_list_as_r ~xt f list (At at) = 203 | if At at == At list then [] 204 | else f (as_node at) :: to_list_as_r ~xt f list (Xt.get ~xt (lhs_of at)) 205 | 206 | let to_list_as_r ~xt f list = 207 | to_list_as_r ~xt f list (Xt.get ~xt (lhs_of list)) 208 | 209 | let to_list_r ~xt list = to_list_as_r ~xt get list 210 | let to_nodes_r ~xt list = to_list_as_r ~xt Fun.id list 211 | end 212 | 213 | let remove node = Kcas.Xt.commit { tx = Xt.remove node } 214 | let is_empty list = Loc.get (lhs_of list) == At list 215 | 216 | let add_l value list = 217 | let node = create_node_with ~lhs:list ~rhs:list value in 218 | Kcas.Xt.commit { tx = Xt.add_node_l node list } 219 | 220 | let add_r value list = 221 | let node = create_node_with ~lhs:list ~rhs:list value in 222 | Kcas.Xt.commit { tx = Xt.add_node_r node list } 223 | 224 | let move_l node list = Kcas.Xt.commit { tx = Xt.move_l node list } 225 | let move_r node list = Kcas.Xt.commit { tx = Xt.move_r node list } 226 | let take_opt_l list = Kcas.Xt.commit { tx = Xt.take_opt_l list } 227 | let take_opt_r list = Kcas.Xt.commit { tx = Xt.take_opt_r list } 228 | 229 | let take_blocking_l ?timeoutf list = 230 | Kcas.Xt.commit ?timeoutf { tx = Xt.take_blocking_l list } 231 | 232 | let take_blocking_r ?timeoutf list = 233 | Kcas.Xt.commit ?timeoutf { tx = Xt.take_blocking_r list } 234 | 235 | let swap t1 t2 = Kcas.Xt.commit { tx = Xt.swap t1 t2 } 236 | let transfer_l t1 t2 = Kcas.Xt.commit { tx = Xt.transfer_l t1 t2 } 237 | let transfer_r t1 t2 = Kcas.Xt.commit { tx = Xt.transfer_r t1 t2 } 238 | let to_list_l list = Kcas.Xt.commit { tx = Xt.to_list_l list } 239 | let to_list_r list = Kcas.Xt.commit { tx = Xt.to_list_r list } 240 | let to_nodes_l list = Kcas.Xt.commit { tx = Xt.to_nodes_l list } 241 | let to_nodes_r list = Kcas.Xt.commit { tx = Xt.to_nodes_r list } 242 | 243 | exception Empty 244 | 245 | let take_l list = match take_opt_l list with None -> raise Empty | Some v -> v 246 | let take_r list = match take_opt_r list with None -> raise Empty | Some v -> v 247 | 248 | let take_all list = 249 | let copy = 250 | let lhs = Loc.make ~padded:true (At list) in 251 | let rhs = Loc.make ~padded:true (At list) in 252 | List { lhs; rhs } |> Multicore_magic.copy_as_padded 253 | in 254 | let open Kcas in 255 | let tx ~xt = 256 | let (At lhs) = Xt.exchange ~xt (lhs_of list) (At list) in 257 | if At lhs == At list then begin 258 | Loc.set (lhs_of copy) (At copy); 259 | Loc.set (rhs_of copy) (At copy) 260 | end 261 | else 262 | let (At rhs) = Xt.exchange ~xt (rhs_of list) (At list) in 263 | Xt.set ~xt (rhs_of lhs) (At copy); 264 | Xt.set ~xt (lhs_of rhs) (At copy); 265 | Loc.set (lhs_of copy) (At lhs); 266 | Loc.set (rhs_of copy) (At rhs) 267 | in 268 | Xt.commit { tx }; 269 | copy 270 | -------------------------------------------------------------------------------- /doc/gkmz-with-read-only-cmp-ops.md: -------------------------------------------------------------------------------- 1 | # Extending k-CAS with efficient read-only CMP operations 2 | 3 | > **_NOTE_**: This document was originally written at around the time the kcas 4 | > library was extended with a 5 | > [`Tx`](https://ocaml-multicore.github.io/kcas/0.2.0/kcas/Kcas/Tx/index.html) 6 | > API for monadic transactions. This version of the document has been updated to 7 | > use the new 8 | > [`Xt`](https://ocaml-multicore.github.io/kcas/doc/kcas/Kcas/Xt/index.html) 9 | > API. 10 | 11 | [`Kcas`](https://ocaml-multicore.github.io/kcas/) currently uses the GKMZ 12 | algorithm for 13 | [Efficient Multi-word Compare and Swap](https://arxiv.org/abs/2008.02527) or 14 | MCAS aka k-CAS. This is a nearly optimal algorithm for MCAS as it requires only 15 | `k + 1` CAS operations. 16 | 17 | The new library API also provides a transactional API for using the algorithm. 18 | For example, suppose one would create the following shared memory locations: 19 | 20 | 26 | 27 | ```ocaml 28 | let a = Loc.make 10 29 | let b = Loc.make 52 30 | let x = Loc.make 0 31 | let y = Loc.make 0 32 | ``` 33 | 34 | Using the 35 | [`Xt`](https://ocaml-multicore.github.io/kcas/doc/kcas/Kcas/Xt/index.html) API 36 | one could define a transaction `x_to_b_sub_a` 37 | 38 | ```ocaml 39 | let x_to_b_sub_a ~xt = 40 | let a' = Xt.get ~xt a 41 | and b' = Xt.get ~xt b in 42 | Xt.set ~xt x (b' - a') 43 | ``` 44 | 45 | to update `x` with the difference of `b` and `a` and commit that transaction: 46 | 47 | ```ocaml 48 | Xt.commit { tx = x_to_b_sub_a } 49 | ``` 50 | 51 | One could similarly define a transaction `y_to_a_add_b` 52 | 53 | ```ocaml 54 | let y_to_a_add_b ~xt = 55 | let a' = Xt.get ~xt a 56 | and b' = Xt.get ~xt b in 57 | Xt.set ~xt y (a' + b') 58 | ``` 59 | 60 | to update `y` with the sum of `a` and `b` and commit that transaction: 61 | 62 | ```ocaml 63 | Xt.commit { tx = y_to_a_add_b } 64 | ``` 65 | 66 | The above committed transactions essentially correspond to MCAS operations as 67 | follows: 68 | 69 | ```ml 70 | Xt.commit { tx = x_to_b_sub_a } == [ CAS (a, 10, 10); CAS (b, 52, 52); CAS (x, 0, 42) ] 71 | Xt.commit { tx = y_to_a_add_b } == [ CAS (a, 10, 10); CAS (b, 52, 52); CAS (y, 0, 62) ] 72 | ``` 73 | 74 | CAS with equal expected or before and desired or after values essentially 75 | expresses an operation that does not change the logical content of the target 76 | location, but only "asserts" that it does not change during the operation. 77 | 78 | Note that the transactions `x_to_b_sub_a` and `y_to_a_add_b`, unlike the MCAS 79 | operations they generate, are independent of the exact values of the locations 80 | being accessed. It is important to distinguish between them. A transaction is a 81 | specification for generating a list of CASes. 82 | 83 | One might attempt to perform both of the two MCAS operations 84 | 85 | ```ml 86 | [ CAS (a, 10, 10); CAS (b, 52, 52); CAS (x, 0, 42) ] 87 | ``` 88 | 89 | and 90 | 91 | ```ml 92 | [ CAS (a, 10, 10); CAS (b, 52, 52); CAS (y, 0, 62) ] 93 | ``` 94 | 95 | in parallel, but that will not be allowed by the GKMZ algorithm. Every CAS 96 | actually updates the targeted memory locations. This means two things: 97 | 98 | 1. CAS operations targeting the same location can only execute sequentially. 99 | 2. CAS operations, even those that do not change the logical content of a 100 | location, cause contention as after the operation only the cache of the 101 | writer will have a valid copy of the 102 | [shared memory](https://en.wikipedia.org/wiki/MSI_protocol) location. 103 | 104 | Could we extend upon GKMZ and allow read-only CMP operations to be expressed 105 | directly and also make it so that read-only CMP operations do not write to 106 | memory? 107 | 108 | Let's first examine, in a bit more detail, how GKMZ, or our OCaml adaptation of 109 | it, operates. For this issue, in order to make it a bit easier to follow, I'll 110 | simplify the implementation a bit. We'll replace the splay tree representation 111 | with a simpler list, assume that locations are always given in some total order, 112 | and we also ignore the release of unused values after the operation. 113 | 114 | Here are the core data structures used by the GKMZ algorithm: 115 | 116 | ```ocaml 117 | type 'a loc = 'a state Atomic.t 118 | and 'a state = { before : 'a; after : 'a; casn : casn } 119 | and cass = CASS : 'a loc * 'a state -> cass 120 | and casn = status Atomic.t 121 | and status = Undetermined of cass list | After | Before 122 | ``` 123 | 124 | Take a closer look at the internal `cass` type. Previously we explained 125 | transactions and talked about MCAS in terms a different CAS type whose 126 | definition could look like this: 127 | 128 | ```ocaml 129 | type cas = 130 | | CAS : 'a loc * 'a * 'a -> cas 131 | ``` 132 | 133 | The difference between the above logical `cas` operation and the internal `cass` 134 | descriptor is that the logical `cas` deals with plain values of type `'a` while 135 | the internal `cass` descriptor uses a state type or the `'a state` type. A 136 | location `'a loc` is an atomic location that contains a `'a state`. The core 137 | GKMZ algorithm attempts a MCAS by attempting to replace the states of all the 138 | locations in a list of `cass`es and then setting status of the `casn` descriptor 139 | to either `After` or `Before` depending on whether the whole operation was a 140 | success or a failure, respectively. 141 | 142 | When using GKMZ one first prepares a list of internal `cass` descriptors and a 143 | `casn` descriptor that has the `Undetermined` list of those descriptors. The 144 | data structure is cyclic: `casn` contains the list of `cass` descriptors which 145 | contain `state`s which contain a reference to the `casn` descriptor. This cyclic 146 | form allows the whole data structure to be traversed starting from any `state`, 147 | which one might find in a location. 148 | 149 | Here is the core of the GKMZ algorithm in OCaml: 150 | 151 | ```ocaml 152 | let finish casn desired = 153 | match Atomic.get casn with 154 | | After -> true 155 | | Before -> false 156 | | Undetermined _ as current -> 157 | Atomic.compare_and_set casn current desired |> ignore; 158 | Atomic.get casn == After 159 | 160 | let rec gkmz casn = function 161 | | [] -> finish casn After (* seems like a success *) 162 | | (CASS (loc, desired) :: continue) as retry -> 163 | let current = Atomic.get loc in 164 | if desired == current then 165 | gkmz casn continue 166 | else 167 | let current_value = 168 | if is_after current.casn then 169 | current.after 170 | else 171 | current.before 172 | in 173 | if current_value != desired.before then 174 | finish casn Before (* seems like a failure *) 175 | else 176 | match Atomic.get casn with 177 | | Undetermined _ -> 178 | (* operation still unfinished *) 179 | if Atomic.compare_and_set loc current desired then 180 | gkmz casn continue 181 | else 182 | gkmz casn retry 183 | | After -> true (* operation was a success *) 184 | | Before -> false (* operation was a failure *) 185 | 186 | and is_after casn = 187 | match Atomic.get casn with 188 | | Undetermined cass -> gkmz casn cass 189 | | After -> true 190 | | Before -> false 191 | 192 | let get loc = 193 | let state = Atomic.get loc in 194 | if is_after state.casn then 195 | state.after 196 | else 197 | state.before 198 | 199 | let atomically logical_cas_list = 200 | let casn = Atomic.make After in 201 | let cass = 202 | logical_cas_list 203 | |> List.map @@ function 204 | | CAS (loc, before, after) -> CASS (loc, {before; after; casn}) 205 | in 206 | Atomic.set casn (Undetermined cass); 207 | gkmz casn cass 208 | ``` 209 | 210 | Note that every call of `atomically` allocates a fresh location for a `casn` 211 | descriptor and also fresh `state`s for all the `CASS` descriptors. This is 212 | important as it makes sure that 213 | [ABA problems](https://en.wikipedia.org/wiki/ABA_problem) are avoided. It is 214 | doubly important in the following extended algorithm. 215 | 216 | Let's then simply extend the algorithm to allow `CMP` operations. First we 217 | extend the logical `cas` type with a new logical `CMP` operation: 218 | 219 | ```diff 220 | type cas = 221 | | CAS : 'a loc * 'a * 'a -> cas 222 | + | CMP : 'a loc * 'a -> cas 223 | ``` 224 | 225 | It turns out that we don't need to change the internal data structures at all. 226 | The gist is that an internal read-only `CASS (loc, state)` descriptor refers to 227 | the `state` of a location before the operation started. We can distinguish such 228 | a `state` simply by comparing the `casn` of the state to the `casn` of the 229 | entire operation. Furthermore, because we know that the `state`s and `casn` are 230 | always freshly allocated, we know that we can compare them simply by their 231 | identities without [ABA problems](https://en.wikipedia.org/wiki/ABA_problem). 232 | 233 | Then we extend the algorithm to allow read-only `CMP` operations. The idea is 234 | simple: instead of attempting to store the `state`s of read-only `CMP` 235 | operations to the locations, we simply check that those locations have their 236 | original `state`s. Additionally, before we attempt to complete an operation as a 237 | success (by writing `After` to the `casn`), we verify that all of the read-only 238 | locations still have their original values. 239 | 240 | ```diff 241 | +let is_cmp casn state = 242 | + state.casn != casn 243 | + 244 | let finish casn desired = 245 | match Atomic.get casn with 246 | | After -> true 247 | | Before -> false 248 | - | Undetermined _ as current -> 249 | + | Undetermined cass as current -> 250 | + let desired = 251 | + if desired == After 252 | + && cass 253 | + |> List.exists @@ fun (CASS (loc, state)) -> 254 | + is_cmp casn state && Atomic.get loc != state then 255 | + Before 256 | + else 257 | + desired in 258 | Atomic.compare_and_set casn current desired |> ignore; 259 | Atomic.get casn == After 260 | 261 | let rec gkmz casn = function 262 | | [] -> finish casn After (* seems like a success *) 263 | | (CASS (loc, desired) :: continue) as retry -> 264 | let current = Atomic.get loc in 265 | if desired == current then 266 | gkmz casn continue 267 | + else if is_cmp casn desired then 268 | + finish casn Before (* seems like a failure *) 269 | else 270 | let current_value = 271 | if is_after current.casn then 272 | current.after 273 | else 274 | current.before 275 | in 276 | if current_value != desired.before then 277 | finish casn Before (* seems like a failure *) 278 | else 279 | match Atomic.get casn with 280 | | Undetermined _ -> 281 | (* operation still unfinished *) 282 | if Atomic.compare_and_set loc current desired then 283 | gkmz casn continue 284 | else 285 | gkmz casn retry 286 | | After -> true (* operation was a success *) 287 | | Before -> false (* operation was a failure *) 288 | 289 | and is_after casn = 290 | match Atomic.get casn with 291 | | Undetermined cass -> gkmz casn cass 292 | | After -> true 293 | | Before -> false 294 | 295 | let get loc = 296 | let state = Atomic.get loc in 297 | if is_after state.casn then 298 | state.after 299 | else 300 | state.before 301 | 302 | let atomically logical_cas_list = 303 | let casn = Atomic.make After in 304 | let cass = 305 | logical_cas_list 306 | |> List.map @@ function 307 | | CAS (loc, before, after) -> CASS (loc, {before; after; casn}) 308 | + | CMP (loc, expected) -> 309 | + let current = Atomic.get loc in 310 | + if get loc != expected || Atomic.get loc != current then 311 | + raise Exit 312 | + else 313 | + CASS (loc, current) 314 | in 315 | Atomic.set casn (Undetermined cass); 316 | gkmz casn cass 317 | + 318 | +let atomically logical_cas_list = 319 | + try atomically logical_cas_list with Exit -> false 320 | ``` 321 | 322 | The above implementation is specifically designed to minimize the diffs compared 323 | to the original GKMZ algorithm. Minor optimizations are possible that are not 324 | shown above. Additionally, it makes sense to distinguish the case when the 325 | algorithm specifically fails during the verification step. We'll get back to 326 | this shortly. 327 | 328 | We claim that the above algorithm is 329 | [linearizable](https://cs.brown.edu/~mph/HerlihyW90/p463-herlihy.pdf) and 330 | [obstruction-free](https://core.ac.uk/download/pdf/9590574.pdf). 331 | 332 | It should be clear that if one thread runs the above algorithm in isolation, it 333 | will be able to finish in a finite number of steps. When not running in 334 | isolation, the verification steps (in `finish`) of two operations may 335 | indefinitely cause both to fail. To see this, consider the following operations 336 | operating in parallel: 337 | 338 | ```ml 339 | [ CMP (a, 0); CAS (b, 0, 1) ] and [ CAS (a, 0, 1); CMP (b, 0) ] 340 | ``` 341 | 342 | Let's assume both operations manage to initially convert the `CMP` operations in 343 | `atomically`, check the read-only `CASS` once during `gkmz`, and perform their 344 | mutating `CASS` operations. At that point both enter the verification step and 345 | both of them will fail. The same could happen on a subsequent retry. 346 | 347 | To prove linearizability we need to show that, for any set of operations 348 | performed in parallel, there is an order in which the operations could have been 349 | performed sequentially giving the same state at the end for all locations. 350 | 351 | First note that the new algorithm operates exactly the same as the original GKMZ 352 | algorithm in case only `CAS` operations are performed. All the cases where 353 | operations write to overlapping locations are already proven to be linearizable 354 | by the basic GKMZ algorithm. Operations that are completely non-overlapping are 355 | trivially linearizable. 356 | 357 | The interesting case to consider is when an operation `R` that only reads a 358 | location `x` (and might also write other locations) needs to be linearizable 359 | with an operation `W` that writes to said location `x`. We claim any observer of 360 | said operations will only be able to read an end state that is consistent with 361 | `R` happening before `W`. Let's assume the opposite, that an observer reads the 362 | results of `W` and `R` and can determine that the operation `W` happened before 363 | `R`. For that to be possible, the `casn` descriptors of both `W` and `R` must be 364 | set to the `After` state. The only way for that to be possible is that the `R` 365 | operation verified the `x` location before `W` wrote to it and so the result of 366 | `R` must be consistent with `R` happening before `W`. This contradicts the 367 | assumption and proves the original claim. 368 | 369 | Previously we mentioned that it makes sense to distinguish the case when the 370 | verification step fails. Let's assume we have done so. Consider having a 371 | transaction mechanism using the new algorithm. Initially such a mechanism 372 | attempts to perform the transaction optimistically using the obstruction-free 373 | algorithm for `k-CAS-n-CMP`. If that repeatedly fails during the verification 374 | step, then the transaction mechanism can switch to using only `k-CAS` operations 375 | and try to complete the operation in lock-free manner. This way the transaction 376 | mechanism can guarantee lock-free behavior, which ensures that at least one 377 | thread will be able to make progress. 378 | 379 | Recall the example transactions `x_to_b_sub_a` and `y_to_a_add_b` that we 380 | started with. Using the new `k-CAS-n-CMP` algorithm the transactions can 381 | generate the following operations: 382 | 383 | ```ml 384 | Xt.commit { tx = x_to_b_sub_a } == [ CMP (a, 10); CMP (b, 52); CAS (x, 0, 42) ] 385 | Xt.commit { tx = y_to_a_add_b } == [ CMP (a, 10); CMP (b, 52); CAS (y, 0, 62) ] 386 | ``` 387 | 388 | The new algorithm will then be able to run the two transaction in parallel. 389 | -------------------------------------------------------------------------------- /src/kcas_data/hashtbl.ml: -------------------------------------------------------------------------------- 1 | open Kcas 2 | 3 | (** Optimized operations on internal association lists with custom equality. *) 4 | module Assoc = struct 5 | type ('k, 'v) t = Nil | Cons of { k : 'k; v : 'v; kvs : ('k, 'v) t } 6 | 7 | let[@inline] cons k v kvs = Cons { k; v; kvs } 8 | 9 | let rec fold fn accum = function 10 | | Nil -> accum 11 | | Cons { k; v; kvs } -> fold fn (fn k v accum) kvs 12 | 13 | let length kvs = fold (fun _ _ n -> n + 1) 0 kvs 14 | 15 | let rec rev_append kvs accum = 16 | match kvs with 17 | | Nil -> accum 18 | | Cons { k; v; kvs } -> rev_append kvs (Cons { k; v; kvs = accum }) 19 | 20 | let rev kvs = rev_append kvs Nil 21 | 22 | let rec iter fn = function 23 | | Nil -> () 24 | | Cons { k; v; kvs } -> 25 | fn k v; 26 | iter fn kvs 27 | 28 | let iter_rev fn = function 29 | | Nil -> () 30 | | Cons { k; v; kvs = Nil } -> fn k v 31 | | kvs -> kvs |> rev |> iter fn 32 | 33 | let rec find_opt equal k' = function 34 | | Nil -> None 35 | | Cons r -> if equal r.k k' then Some r.v else find_opt equal k' r.kvs 36 | 37 | let[@tail_mod_cons] rec find_all equal k' = function 38 | | Nil -> [] 39 | | Cons { k; v; kvs } -> 40 | if equal k k' then v :: find_all equal k' kvs else find_all equal k' kvs 41 | 42 | let rec mem equal k' = function 43 | | Nil -> false 44 | | Cons r -> equal r.k k' || mem equal k' r.kvs 45 | 46 | exception Not_found 47 | 48 | let[@tail_mod_cons] rec remove equal k' = function 49 | | Nil -> raise_notrace Not_found 50 | | Cons r -> 51 | if equal r.k k' then r.kvs 52 | else Cons { k = r.k; v = r.v; kvs = remove equal k' r.kvs } 53 | 54 | type change = Nop | Replaced | Added 55 | 56 | let[@tail_mod_cons] rec replace equal change k' v' = function 57 | | Nil -> 58 | change := Added; 59 | Cons { k = k'; v = v'; kvs = Nil } 60 | | Cons r as original -> 61 | if equal r.k k' then 62 | if r.v == v' then original 63 | else begin 64 | change := Replaced; 65 | Cons { k = r.k; v = v'; kvs = r.kvs } 66 | end 67 | else Cons { k = r.k; v = r.v; kvs = replace equal change k' v' r.kvs } 68 | 69 | let[@tail_mod_cons] rec filter_map fn delta = function 70 | | Nil -> Nil 71 | | Cons { k; v; kvs } -> begin 72 | match fn k v with 73 | | None -> 74 | decr delta; 75 | filter_map fn delta kvs 76 | | Some v' -> Cons { k; v = v'; kvs = filter_map fn delta kvs } 77 | end 78 | end 79 | 80 | type ('k, 'v) pending = 81 | | Nothing 82 | | Rehash of { 83 | state : int Loc.t; 84 | new_capacity : int; 85 | new_buckets : ('k, 'v) Assoc.t Loc.t array Loc.t; 86 | } 87 | | Snapshot of { state : int Loc.t; snapshot : ('k, 'v) Assoc.t array Loc.t } 88 | | Filter_map of { 89 | state : int Loc.t; 90 | fn : 'k -> 'v -> 'v option; 91 | raised : exn Loc.t; 92 | new_buckets : ('k, 'v) Assoc.t Loc.t array Loc.t; 93 | } 94 | 95 | type ('k, 'v) r = { 96 | pending : ('k, 'v) pending; 97 | length : Accumulator.t; 98 | buckets : ('k, 'v) Assoc.t Loc.t array; 99 | hash : 'k -> int; 100 | equal : 'k -> 'k -> bool; 101 | min_buckets : int; 102 | max_buckets : int; 103 | } 104 | 105 | type ('k, 'v) t = ('k, 'v) r Loc.t 106 | type 'k hashed_type = (module Stdlib.Hashtbl.HashedType with type t = 'k) 107 | 108 | let lo_buckets = 1 lsl 5 109 | let hi_buckets = Bits.ceil_pow_2 (Sys.max_array_length lsr 1) 110 | let min_buckets_default = lo_buckets 111 | let max_buckets_default = Int.min hi_buckets (1 lsl 30 (* Limit of [hash] *)) 112 | 113 | module HashedType = struct 114 | let pack (type k) hash equal : k hashed_type = 115 | (module struct 116 | type t = k 117 | 118 | let hash = hash 119 | and equal = equal 120 | end) 121 | 122 | let unpack (type k) ((module HashedType) : k hashed_type) = 123 | (HashedType.hash, HashedType.equal) 124 | 125 | let is_same_as (type k) hash equal ((module HashedType) : k hashed_type) = 126 | hash == HashedType.hash && equal == HashedType.equal 127 | end 128 | 129 | let create ?hashed_type ?min_buckets ?max_buckets () = 130 | let min_buckets = 131 | match min_buckets with 132 | | None -> min_buckets_default 133 | | Some c -> Int.max lo_buckets c |> Int.min hi_buckets |> Bits.ceil_pow_2 134 | in 135 | let t = Loc.make ~padded:true (Obj.magic ()) in 136 | let max_buckets = 137 | match max_buckets with 138 | | None -> Int.max min_buckets max_buckets_default 139 | | Some c -> Int.max min_buckets c |> Int.min hi_buckets |> Bits.ceil_pow_2 140 | and hash, equal = 141 | match hashed_type with 142 | | None -> (Stdlib.Hashtbl.seeded_hash (Random.bits ()), ( = )) 143 | | Some hashed_type -> HashedType.unpack hashed_type 144 | and pending = Nothing 145 | and buckets = Loc.make_array min_buckets Assoc.Nil 146 | and length = Accumulator.make 0 in 147 | Loc.set t 148 | (Multicore_magic.copy_as_padded 149 | { pending; length; buckets; hash; equal; min_buckets; max_buckets }); 150 | t 151 | 152 | let min_buckets_of t = (Loc.get t).min_buckets 153 | let max_buckets_of t = (Loc.get t).max_buckets 154 | 155 | let hashed_type_of t = 156 | let r = Loc.get t in 157 | HashedType.pack r.hash r.equal 158 | 159 | let bucket_of hash key buckets = 160 | Array.unsafe_get buckets (hash key land (Array.length buckets - 1)) 161 | 162 | exception Done 163 | 164 | module Xt = struct 165 | let find_opt ~xt t k = 166 | let r = Xt.get ~xt t in 167 | r.buckets |> bucket_of r.hash k |> Xt.get ~xt |> Assoc.find_opt r.equal k 168 | 169 | let find_all ~xt t k = 170 | let r = Xt.get ~xt t in 171 | r.buckets |> bucket_of r.hash k |> Xt.get ~xt |> Assoc.find_all r.equal k 172 | 173 | let mem ~xt t k = 174 | let r = Xt.get ~xt t in 175 | r.buckets |> bucket_of r.hash k |> Xt.get ~xt |> Assoc.mem r.equal k 176 | 177 | let get_or_alloc array_loc make length = 178 | let tx ~xt = 179 | let array = Xt.get ~xt array_loc in 180 | if array != [||] then array 181 | else 182 | let array = make length Assoc.Nil in 183 | Xt.set ~xt array_loc array; 184 | array 185 | in 186 | Xt.commit { tx } 187 | 188 | (** Pending operations are performed incrementally in small batches. *) 189 | let batch_size = 3 190 | 191 | let perform_pending ~xt t = 192 | (* TODO: Implement pending operations such that multiple domains may be 193 | working to complete them in parallel by extending the [state] to an array 194 | of multiple partition [states]. *) 195 | let must_be_done_in_this_tx = Xt.is_in_log ~xt t in 196 | let r = Xt.get ~xt t in 197 | match r.pending with 198 | | Nothing -> r 199 | | Rehash { state; new_capacity; new_buckets } -> begin 200 | let new_buckets = 201 | get_or_alloc new_buckets Loc.make_array new_capacity 202 | in 203 | let old_buckets = r.buckets in 204 | let r = 205 | Multicore_magic.copy_as_padded 206 | { r with pending = Nothing; buckets = new_buckets } 207 | in 208 | Xt.set ~xt t r; 209 | let hash = r.hash and mask = new_capacity - 1 in 210 | let rehash_a_few_buckets ~xt = 211 | (* We process buckets in descending order as that is slightly faster 212 | with the transaction log. It also makes sure that we know when the 213 | operation has already been performed independently of the 214 | buckets array we read above. *) 215 | let i = Xt.fetch_and_add ~xt state (-batch_size) in 216 | if i <= 0 then raise_notrace Done; 217 | for i = i - 1 downto Bits.max_0 (i - batch_size) do 218 | Array.unsafe_get old_buckets i 219 | |> Xt.get ~xt 220 | |> Assoc.iter_rev @@ fun k v -> 221 | Xt.modify ~xt 222 | (Array.unsafe_get new_buckets (hash k land mask)) 223 | (Assoc.cons k v) 224 | done 225 | in 226 | try 227 | if must_be_done_in_this_tx then begin 228 | (* If the old buckets have already been accessed, we cannot perform 229 | rehashing outside of the transaction. In this case rehashing 230 | becomes linearithmic, O(n*log(n)), because that is the best that 231 | the transaction log promises. However, as we access the bucket 232 | locations mostly in order, we often actually get linear time, 233 | O(n), performance. *) 234 | let initial_state = Array.length old_buckets in 235 | while true do 236 | (* If state is modified outside our expensive tx would fail. *) 237 | if Loc.fenceless_get state != initial_state then Retry.invalid (); 238 | rehash_a_few_buckets ~xt 239 | done; 240 | r 241 | end 242 | else begin 243 | (* When possible, rehashing is performed cooperatively a few buckets 244 | at a time. This gives expected linear time, O(n). *) 245 | while true do 246 | Xt.commit { tx = rehash_a_few_buckets } 247 | done; 248 | r 249 | end 250 | with Done -> r 251 | end 252 | | Snapshot { state; snapshot } -> begin 253 | assert (not must_be_done_in_this_tx); 254 | let buckets = r.buckets in 255 | let r = Multicore_magic.copy_as_padded { r with pending = Nothing } in 256 | Xt.set ~xt t r; 257 | (* Check state to ensure that buckets have not been updated. *) 258 | if Loc.fenceless_get state < 0 then Retry.invalid (); 259 | let snapshot = 260 | get_or_alloc snapshot Array.make (Array.length buckets) 261 | in 262 | let snapshot_a_few_buckets ~xt = 263 | let i = Xt.fetch_and_add ~xt state (-batch_size) in 264 | if i <= 0 then raise_notrace Done; 265 | for i = i - 1 downto Bits.max_0 (i - batch_size) do 266 | Array.unsafe_get buckets i |> Xt.get ~xt 267 | |> Array.unsafe_set snapshot i 268 | done 269 | in 270 | try 271 | while true do 272 | Xt.commit { tx = snapshot_a_few_buckets } 273 | done; 274 | r 275 | with Done -> r 276 | end 277 | | Filter_map { state; fn; raised; new_buckets } -> begin 278 | assert (not must_be_done_in_this_tx); 279 | let old_buckets = r.buckets in 280 | (* Check state to ensure that buckets have not been updated. *) 281 | if Loc.fenceless_get state < 0 then Retry.invalid (); 282 | let new_capacity = Array.length old_buckets in 283 | let new_buckets = 284 | get_or_alloc new_buckets Loc.make_array new_capacity 285 | in 286 | let filter_map_a_few_buckets ~xt = 287 | let i = Xt.fetch_and_add ~xt state (-batch_size) in 288 | if i <= 0 then raise_notrace Done; 289 | let a_few_buckets_delta = ref 0 in 290 | for i = i - 1 downto Bits.max_0 (i - batch_size) do 291 | Xt.get ~xt (Array.unsafe_get old_buckets i) 292 | |> Assoc.filter_map fn a_few_buckets_delta 293 | |> Xt.set ~xt (Array.unsafe_get new_buckets i) 294 | done; 295 | !a_few_buckets_delta 296 | in 297 | let total_delta = ref 0 in 298 | try 299 | while true do 300 | total_delta := 301 | !total_delta + Xt.commit { tx = filter_map_a_few_buckets } 302 | done; 303 | r 304 | with 305 | | Done -> 306 | Accumulator.Xt.add ~xt r.length !total_delta; 307 | let r = 308 | Multicore_magic.copy_as_padded 309 | { r with pending = Nothing; buckets = new_buckets } 310 | in 311 | Xt.set ~xt t r; 312 | r 313 | | exn -> 314 | Loc.compare_and_set raised Done exn |> ignore; 315 | let r = 316 | Multicore_magic.copy_as_padded { r with pending = Nothing } 317 | in 318 | Xt.set ~xt t r; 319 | r 320 | end 321 | 322 | let[@inline] make_rehash old_capacity new_capacity = 323 | let state = Loc.make old_capacity and new_buckets = Loc.make [||] in 324 | Rehash { state; new_capacity; new_buckets } 325 | 326 | let reset ~xt t = 327 | let r = perform_pending ~xt t in 328 | Accumulator.Xt.set ~xt r.length 0; 329 | let buckets = Loc.make_array r.min_buckets Assoc.Nil in 330 | Xt.set ~xt t { r with buckets } 331 | 332 | let clear ~xt t = reset ~xt t 333 | 334 | let remove ~xt t k = 335 | let r = perform_pending ~xt t in 336 | let buckets = r.buckets in 337 | let mask = Array.length buckets - 1 in 338 | let bucket = Array.unsafe_get buckets (r.hash k land mask) in 339 | match Xt.modify ~xt bucket (Assoc.remove r.equal k) with 340 | | () -> 341 | Accumulator.Xt.decr ~xt r.length; 342 | if r.min_buckets <= mask && Random.bits () land mask = 0 then 343 | let capacity = mask + 1 in 344 | let length = Accumulator.Xt.get ~xt r.length in 345 | if length * 4 < capacity then 346 | Xt.set ~xt t 347 | { r with pending = make_rehash capacity (capacity asr 1) } 348 | | exception Assoc.Not_found -> () 349 | 350 | let add ~xt t k v = 351 | let r = perform_pending ~xt t in 352 | let buckets = r.buckets in 353 | let mask = Array.length buckets - 1 in 354 | let bucket = Array.unsafe_get buckets (r.hash k land mask) in 355 | Xt.modify ~xt bucket (Assoc.cons k v); 356 | Accumulator.Xt.incr ~xt r.length; 357 | if mask + 1 < r.max_buckets && Random.bits () land mask = 0 then 358 | let capacity = mask + 1 in 359 | let length = Accumulator.Xt.get ~xt r.length in 360 | if capacity < length then 361 | Xt.set ~xt t { r with pending = make_rehash capacity (capacity * 2) } 362 | 363 | let replace ~xt t k v = 364 | let r = perform_pending ~xt t in 365 | let buckets = r.buckets in 366 | let mask = Array.length buckets - 1 in 367 | let bucket = Array.unsafe_get buckets (r.hash k land mask) in 368 | let change = ref Assoc.Nop in 369 | Xt.modify ~xt bucket (fun kvs -> 370 | let kvs' = Assoc.replace r.equal change k v kvs in 371 | if !change != Assoc.Nop then kvs' else kvs); 372 | if !change == Assoc.Added then begin 373 | Accumulator.Xt.incr ~xt r.length; 374 | if mask + 1 < r.max_buckets && Random.bits () land mask = 0 then 375 | let capacity = mask + 1 in 376 | let length = Accumulator.Xt.get ~xt r.length in 377 | if capacity < length then 378 | Xt.set ~xt t { r with pending = make_rehash capacity (capacity * 2) } 379 | end 380 | 381 | let length ~xt t = Accumulator.Xt.get ~xt (Xt.get ~xt t).length 382 | let swap = Xt.swap 383 | end 384 | 385 | let find_opt t k = 386 | let t = Loc.get t in 387 | (* Fenceless is safe as we have a fence above. *) 388 | t.buckets |> bucket_of t.hash k |> Loc.fenceless_get 389 | |> Assoc.find_opt t.equal k 390 | 391 | let find_all t k = 392 | let t = Loc.get t in 393 | (* Fenceless is safe as we have a fence above. *) 394 | t.buckets |> bucket_of t.hash k |> Loc.fenceless_get 395 | |> Assoc.find_all t.equal k 396 | 397 | let find t k = match find_opt t k with None -> raise Not_found | Some v -> v 398 | 399 | let mem t k = 400 | let t = Loc.get t in 401 | (* Fenceless is safe as we have a fence above. *) 402 | t.buckets |> bucket_of t.hash k |> Loc.fenceless_get |> Assoc.mem t.equal k 403 | 404 | let clear t = Kcas.Xt.commit { tx = Xt.clear t } 405 | let reset t = Kcas.Xt.commit { tx = Xt.reset t } 406 | let remove t k = Kcas.Xt.commit { tx = Xt.remove t k } 407 | let add t k v = Kcas.Xt.commit { tx = Xt.add t k v } 408 | let replace t k v = Kcas.Xt.commit { tx = Xt.replace t k v } 409 | let length t = Accumulator.get (Loc.get t).length 410 | let swap t1 t2 = Kcas.Xt.commit { tx = Xt.swap t1 t2 } 411 | 412 | let snapshot ?length ?record t = 413 | let state = Loc.make 0 and snapshot = Loc.make [||] in 414 | let pending = Snapshot { state; snapshot } in 415 | let tx ~xt = 416 | let r = Xt.perform_pending ~xt t in 417 | length 418 | |> Option.iter (fun length -> length := Accumulator.Xt.get ~xt r.length); 419 | record |> Option.iter (fun record -> record := r); 420 | Loc.set state (Array.length r.buckets); 421 | Kcas.Xt.set ~xt t { r with pending } 422 | in 423 | Kcas.Xt.commit { tx }; 424 | Kcas.Xt.commit { tx = Xt.perform_pending t } |> ignore; 425 | (* Fenceless is safe as commit above has fences. *) 426 | Loc.fenceless_get snapshot 427 | 428 | let to_seq t = 429 | let snapshot = snapshot t in 430 | let rec loop i kvs () = 431 | match kvs with 432 | | Assoc.Nil -> 433 | if i = Array.length snapshot then Seq.Nil 434 | else loop (i + 1) (Array.unsafe_get snapshot i) () 435 | | Cons { k; v; kvs } -> Seq.Cons ((k, v), loop i kvs) 436 | in 437 | loop 0 Nil 438 | 439 | let to_seq_keys t = to_seq t |> Seq.map fst 440 | let to_seq_values t = to_seq t |> Seq.map snd 441 | 442 | let of_seq ?hashed_type ?min_buckets ?max_buckets xs = 443 | let t = create ?hashed_type ?min_buckets ?max_buckets () in 444 | Seq.iter (fun (k, v) -> replace t k v) xs; 445 | t 446 | 447 | let rebuild ?hashed_type ?min_buckets ?max_buckets t = 448 | let record = ref (Obj.magic ()) and length = ref 0 in 449 | let snapshot = snapshot ~length ~record t in 450 | let r = !record in 451 | let min_buckets = 452 | match min_buckets with 453 | | None -> r.min_buckets 454 | | Some c -> Int.max lo_buckets c |> Int.min hi_buckets |> Bits.ceil_pow_2 455 | in 456 | let max_buckets = 457 | match max_buckets with 458 | | None -> Int.max min_buckets r.max_buckets 459 | | Some c -> Int.max min_buckets c |> Int.min hi_buckets |> Bits.ceil_pow_2 460 | in 461 | let is_same_hashed_type = 462 | match hashed_type with 463 | | None -> true 464 | | Some hashed_type -> HashedType.is_same_as r.hash r.equal hashed_type 465 | and length = !length in 466 | if is_same_hashed_type && min_buckets <= length && length <= max_buckets then begin 467 | let t = Loc.make ~padded:true (Obj.magic ()) in 468 | let pending = Nothing 469 | and buckets = Array.map Loc.make snapshot 470 | and length = Accumulator.make length in 471 | Loc.set t 472 | @@ Multicore_magic.copy_as_padded 473 | { r with pending; length; buckets; min_buckets; max_buckets }; 474 | t 475 | end 476 | else 477 | let t = create ?hashed_type ~min_buckets ~max_buckets () in 478 | snapshot |> Array.iter (Assoc.iter_rev (add t)); 479 | t 480 | 481 | let copy t = rebuild t 482 | let fold fn t a = Array.fold_left (Assoc.fold fn) a (snapshot t) 483 | let iter f t = fold (fun k v () -> f k v) t () 484 | 485 | let filter_map_inplace fn t = 486 | let state = Loc.make 0 487 | and raised = Loc.make Done 488 | and new_buckets = Loc.make [||] in 489 | let pending = Filter_map { state; fn; raised; new_buckets } in 490 | let tx ~xt = 491 | let r = Xt.perform_pending ~xt t in 492 | Loc.set state (Array.length r.buckets); 493 | Kcas.Xt.set ~xt t { r with pending } 494 | in 495 | Kcas.Xt.commit { tx }; 496 | Kcas.Xt.commit { tx = Xt.perform_pending t } |> ignore; 497 | (* Fenceless is safe as commit above has fences. *) 498 | match Loc.fenceless_get raised with 499 | | Done -> () 500 | | exn -> raise exn 501 | 502 | let stats t = 503 | let length = ref 0 in 504 | let snapshot = snapshot ~length t in 505 | let num_bindings = !length in 506 | let num_buckets = Array.length snapshot in 507 | let bucket_lengths = Array.map Assoc.length snapshot in 508 | let max_bucket_length = Array.fold_left Int.max 0 bucket_lengths in 509 | let bucket_histogram = Array.make (max_bucket_length + 1) 0 in 510 | bucket_lengths 511 | |> Array.iter (fun i -> bucket_histogram.(i) <- 1 + bucket_histogram.(i)); 512 | Stdlib.Hashtbl. 513 | { num_bindings; num_buckets; max_bucket_length; bucket_histogram } 514 | --------------------------------------------------------------------------------