├── .dockerignore ├── test ├── stm_run │ ├── empty.ocaml4.ml │ ├── empty.ocaml5.ml │ ├── dune │ ├── stm_run.ocaml4.ml │ ├── util.ml │ ├── stm_run.ocaml5.ml │ └── intf.ml ├── atomic │ ├── atomic.ml │ └── dune ├── seqtest │ ├── .gitignore │ ├── Makefile │ ├── dune │ ├── README.md │ └── seqtest.ml ├── barrier │ ├── dune │ ├── barrier.ml │ └── barrier.mli ├── htbl │ ├── htbls │ │ ├── dune │ │ └── htbls.ml │ ├── htbl_utils.ml │ └── dune ├── spsc_queue │ ├── spsc_queues │ │ ├── dune │ │ └── spsc_queues.ml │ ├── dune │ ├── test_spsc_queue.ml │ ├── stm_spsc_queue.ml │ └── spsc_queue_dscheck.ml ├── bounded_queue │ ├── bounded_queues │ │ ├── dune │ │ └── bounded_queues.ml │ ├── dune │ └── stm_bounded_queue.ml ├── michael_scott_queue │ ├── ms_queues │ │ ├── dune │ │ └── ms_queues.ml │ ├── michael_scott_queue_unsafe_node.ml │ ├── dune │ └── stm_michael_scott_queue.ml ├── bag │ ├── dune │ ├── stm_bag.ml │ └── qcheck_bag.ml ├── size │ ├── dune │ ├── stm_size.ml │ ├── dscheck_size.ml │ └── linked_set.ml ├── bounded_stack │ ├── dune │ └── stm_bounded_stack.ml ├── mpsc_queue │ ├── dune │ └── stm_mpsc_queue.ml ├── skiplist │ ├── dune │ ├── stm_skiplist.ml │ └── dscheck_skiplist.ml ├── treiber_stack │ ├── dune │ └── stm_treiber_stack.ml ├── ws_deque │ ├── dune │ ├── stm_ws_deque.ml │ └── test_ws_deque.ml └── README.md ├── src ├── domain.ocaml4.ml ├── atomic.without_contended.ml ├── spsc_queue │ ├── dune │ ├── spsc_queue.mli │ ├── spsc_queue_unsafe.mli │ ├── spsc_queue.ml │ └── spsc_queue_unsafe.ml ├── seq.ocaml4.13.ml ├── michael_scott_queue │ ├── dune │ ├── michael_scott_queue.mli │ ├── michael_scott_queue_unsafe.mli │ ├── michael_scott_queue_unsafe_node.ml │ ├── michael_scott_queue.ml │ ├── michael_scott_queue_unsafe.ml │ └── michael_scott_queue_intf.mli ├── bounded_queue │ ├── bounded_queue.mli │ ├── bounded_queue_unsafe.mli │ ├── dune │ ├── bounded_queue.head_safe.ml │ └── bounded_queue.head_unsafe.ml ├── htbl │ ├── htbl.mli │ ├── dune │ ├── htbl_unsafe.mli │ ├── htbl_utils.ml │ ├── htbl.head_unsafe.ml │ └── htbl.head_safe.ml ├── bag.ml ├── dune ├── bag.mli ├── saturn.ml ├── ArrayExtra.ml ├── treiber_stack.ml ├── saturn.mli ├── mpsc_queue.ml ├── bounded_stack.ml ├── skiplist.mli ├── ws_deque.mli └── treiber_stack.mli ├── .ocamlformat ├── .gitignore ├── Makefile ├── .prettierrc ├── bench.Dockerfile ├── CODE_OF_CONDUCT.md ├── LICENSE.md ├── bench ├── dune ├── main.ml ├── bench_size.ml ├── bench_spsc_queue.ml ├── README.md ├── bench_stack.ml ├── bench_bounded_stack.ml ├── bench_skiplist.ml ├── bench_mpsc.ml ├── bench_htbl.ml ├── bench_queue.ml ├── bench_bounded_queue.ml └── bench_ws_deque.ml ├── .github └── workflows │ ├── main.yml │ └── deploy-odoc.yml ├── dune-project ├── CONTRIBUTING.md ├── saturn.opam ├── CHANGES.md └── doc ├── domain-role.md └── composability.md /.dockerignore: -------------------------------------------------------------------------------- 1 | _build 2 | -------------------------------------------------------------------------------- /test/stm_run/empty.ocaml4.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/stm_run/empty.ocaml5.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/domain.ocaml4.ml: -------------------------------------------------------------------------------- 1 | let cpu_relax = Thread.yield 2 | -------------------------------------------------------------------------------- /test/atomic/atomic.ml: -------------------------------------------------------------------------------- 1 | include Dscheck.TracedAtomic 2 | -------------------------------------------------------------------------------- /test/seqtest/.gitignore: -------------------------------------------------------------------------------- 1 | input 2 | output 3 | dune-workspace.afl 4 | -------------------------------------------------------------------------------- /test/barrier/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name barrier) 3 | (libraries domain_shims)) 4 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | version = 0.27.0 3 | 4 | exp-grouping=preserve 5 | -------------------------------------------------------------------------------- /src/atomic.without_contended.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Atomic 2 | 3 | let make_contended = make 4 | -------------------------------------------------------------------------------- /test/atomic/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name atomic) 3 | (libraries dscheck) 4 | (enabled_if 5 | (>= %{ocaml_version} 5))) 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.install 7 | *.native 8 | *.byte 9 | *.merlin 10 | *.json 11 | node_modules -------------------------------------------------------------------------------- /test/seqtest/Makefile: -------------------------------------------------------------------------------- 1 | SWITCH := $(shell opam switch show) 2 | EXE := seqtest.exe 3 | DUNEFLAGS := --profile seqtest 4 | include ./Makefile.monolith 5 | -------------------------------------------------------------------------------- /test/seqtest/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name seqtest) 3 | (libraries monolith saturn) 4 | (modules seqtest) 5 | (enabled_if 6 | (= %{profile} seqtest))) 7 | -------------------------------------------------------------------------------- /test/htbl/htbls/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy ../../../src/htbl/htbl_intf.mli htbl_intf.ml)) 4 | (package saturn)) 5 | 6 | (library 7 | (name htbls) 8 | (libraries saturn)) 9 | -------------------------------------------------------------------------------- /src/spsc_queue/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package saturn) 3 | (enabled_if 4 | (and 5 | (<> %{os_type} Win32) 6 | (>= %{ocaml_version} 5.0.0))) 7 | (libraries saturn) 8 | (files spsc_queue_intf.mli)) 9 | -------------------------------------------------------------------------------- /src/seq.ocaml4.13.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Seq 2 | 3 | let rec length_aux accu xs = 4 | match xs () with Nil -> accu | Cons (_, xs) -> length_aux (accu + 1) xs 5 | 6 | let[@inline] length xs = length_aux 0 xs 7 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean test bench 2 | 3 | all: 4 | dune build 5 | 6 | test: 7 | dune runtest 8 | 9 | clean: 10 | dune clean 11 | 12 | bench: 13 | @dune exec --release -- ./bench/main.exe -budget 1 14 | -------------------------------------------------------------------------------- /src/michael_scott_queue/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package saturn) 3 | (enabled_if 4 | (and 5 | (<> %{os_type} Win32) 6 | (>= %{ocaml_version} 5.0.0))) 7 | (libraries saturn) 8 | (files michael_scott_queue_intf.mli)) 9 | -------------------------------------------------------------------------------- /test/spsc_queue/spsc_queues/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy ../../../src/spsc_queue/spsc_queue_intf.mli spsc_queue_intf.ml)) 4 | (package saturn)) 5 | 6 | (library 7 | (name spsc_queues) 8 | (libraries saturn)) 9 | -------------------------------------------------------------------------------- /test/bounded_queue/bounded_queues/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy 4 | ../../../src/bounded_queue/bounded_queue_intf.mli 5 | bounded_queue_intf.ml)) 6 | (package saturn)) 7 | 8 | (library 9 | (name bounded_queues) 10 | (libraries saturn)) 11 | -------------------------------------------------------------------------------- /test/michael_scott_queue/ms_queues/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy 4 | ../../../src/michael_scott_queue/michael_scott_queue_intf.mli 5 | michael_scott_queue_intf.ml)) 6 | (package saturn)) 7 | 8 | (library 9 | (name ms_queues) 10 | (libraries saturn)) 11 | -------------------------------------------------------------------------------- /.prettierrc: -------------------------------------------------------------------------------- 1 | { 2 | "arrowParens": "avoid", 3 | "bracketSpacing": false, 4 | "printWidth": 80, 5 | "semi": false, 6 | "singleQuote": true, 7 | "proseWrap": "always", 8 | "overrides": [ 9 | { 10 | "files": ["*.md"], 11 | "excludeFiles": "_build/*" 12 | } 13 | ] 14 | } 15 | -------------------------------------------------------------------------------- /test/htbl/htbls/htbls.ml: -------------------------------------------------------------------------------- 1 | module type Htbl_tests = sig 2 | include Htbl_intf.HTBL 3 | 4 | val name : string 5 | end 6 | 7 | module Htbl : Htbl_tests = struct 8 | include Saturn.Htbl 9 | 10 | let name = "htbl_safe" 11 | end 12 | 13 | module Htbl_unsafe : Htbl_tests = struct 14 | include Saturn.Htbl_unsafe 15 | 16 | let name = "htbl_unsafe" 17 | end 18 | -------------------------------------------------------------------------------- /test/bag/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (package saturn) 3 | (name qcheck_bag) 4 | (modules qcheck_bag) 5 | (libraries 6 | saturn 7 | barrier 8 | qcheck 9 | qcheck-core 10 | qcheck-alcotest 11 | alcotest 12 | domain_shims)) 13 | 14 | (test 15 | (package saturn) 16 | (name stm_bag) 17 | (modules stm_bag) 18 | (libraries saturn qcheck-core qcheck-stm.stm stm_run)) 19 | -------------------------------------------------------------------------------- /src/bounded_queue/bounded_queue.mli: -------------------------------------------------------------------------------- 1 | (** Lock-free bounded Queue. 2 | 3 | This module implements a lock-free bounded queue based on Michael-Scott's 4 | queue algorithm. Adding a capacity to this algorithm adds a general overhead 5 | to the operations, and thus, it is recommended to use the unbounded queue 6 | {!Saturn.Queue} if you don't need it. *) 7 | 8 | include Bounded_queue_intf.BOUNDED_QUEUE 9 | -------------------------------------------------------------------------------- /src/bounded_queue/bounded_queue_unsafe.mli: -------------------------------------------------------------------------------- 1 | (** Optimized lock-free bounded Queue. 2 | 3 | This module implements a lock-free bounded queue based on Michael-Scott's 4 | queue algorithm. Adding a capacity to this algorithm adds a general overhead 5 | to the operations, and thus, it is recommended to use the unbounded queue 6 | {!Saturn.Queue} if you don't need it. *) 7 | 8 | include Bounded_queue_intf.BOUNDED_QUEUE 9 | -------------------------------------------------------------------------------- /bench.Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:debian-ocaml-5.3 2 | RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam 3 | WORKDIR bench-dir 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 | -------------------------------------------------------------------------------- /src/spsc_queue/spsc_queue.mli: -------------------------------------------------------------------------------- 1 | (** Lock-free single-producer, single-consumer queue. 2 | 3 | {b Warning}: This queue does not include safety mechanisms to prevent 4 | misuse. If consumer-only functions are called concurrently by multiple 5 | domains, the queue may enter an unexpected state, due to data races and a 6 | lack of linearizability. The same goes for producer-only functions. *) 7 | 8 | include Spsc_queue_intf.SPSC_queue 9 | -------------------------------------------------------------------------------- /src/spsc_queue/spsc_queue_unsafe.mli: -------------------------------------------------------------------------------- 1 | (** Optimized lock-free single-producer, single-consumer queue. 2 | 3 | {b Warning}: This queue does not include safety mechanisms to prevent 4 | misuse. If consumer-only functions are called concurrently by multiple 5 | domains, the queue may enter an unexpected state, due to data races and a 6 | lack of linearizability. The same goes for producer-only functions. *) 7 | 8 | include Spsc_queue_intf.SPSC_queue 9 | -------------------------------------------------------------------------------- /test/spsc_queue/spsc_queues/spsc_queues.ml: -------------------------------------------------------------------------------- 1 | module type SPSC_tests = sig 2 | include Spsc_queue_intf.SPSC_queue 3 | 4 | val name : string 5 | end 6 | 7 | module Spsc_queue : SPSC_tests = struct 8 | include Saturn.Single_prod_single_cons_queue 9 | 10 | let name = "Spsc_queue" 11 | end 12 | 13 | module Spsc_queue_unsafe : SPSC_tests = struct 14 | include Saturn.Single_prod_single_cons_queue_unsafe 15 | 16 | let name = "Spsc_queue_unsafe" 17 | end 18 | -------------------------------------------------------------------------------- /test/michael_scott_queue/ms_queues/ms_queues.ml: -------------------------------------------------------------------------------- 1 | module type MS_queue_tests = sig 2 | include Michael_scott_queue_intf.MS_QUEUE 3 | 4 | val name : string 5 | end 6 | 7 | module Michael_scott_queue : MS_queue_tests = struct 8 | include Saturn.Queue 9 | 10 | let name = "michael_scott_queue_safe" 11 | end 12 | 13 | module Michael_scott_queue_unsafe : MS_queue_tests = struct 14 | include Saturn.Queue_unsafe 15 | 16 | let name = "michael_scott_queue_unsafe" 17 | end 18 | -------------------------------------------------------------------------------- /test/bounded_queue/bounded_queues/bounded_queues.ml: -------------------------------------------------------------------------------- 1 | module type Bounded_queue_tests = sig 2 | include Bounded_queue_intf.BOUNDED_QUEUE 3 | 4 | val name : string 5 | end 6 | 7 | module Bounded_queue : Bounded_queue_tests = struct 8 | include Saturn.Bounded_queue 9 | 10 | let name = "Bounded_queue_safe" 11 | end 12 | 13 | module Bounded_queue_unsafe : Bounded_queue_tests = struct 14 | include Saturn.Bounded_queue_unsafe 15 | 16 | let name = "Bounded_queue_unsafe" 17 | end 18 | -------------------------------------------------------------------------------- /test/barrier/barrier.ml: -------------------------------------------------------------------------------- 1 | type t = { waiters : int Atomic.t; size : int; passed : int Atomic.t } 2 | 3 | let create n = { waiters = Atomic.make n; size = n; passed = Atomic.make 0 } 4 | 5 | let await { waiters; size; passed } = 6 | if Atomic.fetch_and_add passed 1 = size - 1 then ( 7 | Atomic.set passed 0; 8 | Atomic.set waiters 0); 9 | 10 | while Atomic.get waiters = size do 11 | Domain.cpu_relax () 12 | done; 13 | 14 | Atomic.incr waiters; 15 | while Atomic.get waiters < size do 16 | Domain.cpu_relax () 17 | done 18 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). 4 | 5 | # Enforcement 6 | 7 | This project follows the OCaml Code of Conduct 8 | [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). 9 | 10 | To report any violations, please contact: 11 | 12 | * Bartosz Modelski 13 | * Carine Morel 14 | * Sudha Parimala -------------------------------------------------------------------------------- /test/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/seqtest/README.md: -------------------------------------------------------------------------------- 1 | ## A sequential test of the work-stealing queue 2 | 3 | This test exercises the work-stealing queue in `Ws_deque` 4 | in a purely sequential mode. 5 | 6 | To compile this test, type `make` or `dune build --profile seqtest`. 7 | 8 | To run this test, type `make random` or `dune exec --profile seqtest ./seqtest.exe`. 9 | The test runs until it is interrupted. 10 | 11 | This test requires the `monolith` package. Because we do not wish 12 | to create a hard dependency on `monolith`, the code in this directory 13 | is built by `dune` only when `--profile seqtest` is passed on the command line. 14 | -------------------------------------------------------------------------------- /test/size/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (package saturn) 3 | (name linked_set) 4 | (modules linked_set)) 5 | 6 | (rule 7 | (action 8 | (copy ../../src/size.ml size.ml)) 9 | (package saturn)) 10 | 11 | (test 12 | (package saturn) 13 | (name dscheck_size) 14 | (modules dscheck_size size) 15 | (build_if 16 | (>= %{ocaml_version} 5)) 17 | (libraries dscheck linked_set alcotest multicore-magic-dscheck) 18 | (flags 19 | (:standard -open Multicore_magic_dscheck))) 20 | 21 | (test 22 | (package saturn) 23 | (name stm_size) 24 | (modules stm_size) 25 | (libraries saturn linked_set qcheck-core qcheck-stm.stm stm_run)) 26 | -------------------------------------------------------------------------------- /test/bounded_stack/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy ../../src/bounded_stack.ml bounded_stack.ml)) 4 | (package saturn)) 5 | 6 | (test 7 | (package saturn) 8 | (name bounded_stack_dscheck) 9 | (libraries atomic dscheck alcotest backoff multicore-magic) 10 | (build_if 11 | (and 12 | (>= %{ocaml_version} 5) 13 | (not 14 | (and 15 | (= %{arch_sixtyfour} false) 16 | (= %{architecture} arm))))) 17 | (modules bounded_stack bounded_stack_dscheck)) 18 | 19 | (test 20 | (package saturn) 21 | (name stm_bounded_stack) 22 | (modules stm_bounded_stack) 23 | (libraries saturn qcheck-core qcheck-stm.stm stm_run)) 24 | -------------------------------------------------------------------------------- /src/htbl/htbl.mli: -------------------------------------------------------------------------------- 1 | (** Lock-free and resizable hash table. 2 | 3 | The operations provided by this hash table are designed to work as building 4 | blocks of non-blocking algorithms. Specifically, the operation signatures 5 | and semantics are designed to allow building 6 | {{:https://dl.acm.org/doi/10.1145/62546.62593} consensus protocols over 7 | arbitrary numbers of processes}. 8 | 9 | 🏎️ Single key reads with this hash table are actually wait-free rather than 10 | just lock-free. Internal resizing automatically uses all the threads that 11 | are trying to write to the hash table. *) 12 | 13 | include Htbl_intf.HTBL 14 | -------------------------------------------------------------------------------- /test/stm_run/stm_run.ocaml4.ml: -------------------------------------------------------------------------------- 1 | include Intf 2 | 3 | let run ?(verbose = true) ?(count = default_count) ?(budgetf = default_budgetf) 4 | ~name ?make_domain (module Spec : STM.Spec) = 5 | let module Seq = STM_sequential.Make (Spec) in 6 | let module Con = STM_thread.Make (Spec) [@alert "-experimental"] in 7 | Util.run_with_budget ~budgetf ~count @@ fun count -> 8 | [ 9 | [ Seq.agree_test ~count ~name:(name ^ " sequential") ]; 10 | (match make_domain with 11 | | None -> [ Con.agree_test_conc ~count ~name:(name ^ " concurrent") ] 12 | | Some _ -> []); 13 | ] 14 | |> List.concat 15 | |> QCheck_base_runner.run_tests ~verbose 16 | -------------------------------------------------------------------------------- /src/htbl/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (with-stdout-to 4 | htbl.ml 5 | (progn 6 | (echo "# 1 \"htbl.head_safe.ml\"\n") 7 | (cat htbl.head_safe.ml) 8 | (echo "# 1 \"htbl.body.ml\"\n") 9 | (cat htbl.body.ml))))) 10 | 11 | (rule 12 | (action 13 | (with-stdout-to 14 | htbl_unsafe.ml 15 | (progn 16 | (echo "# 1 \"htbl.head_unsafe.ml\"\n") 17 | (cat htbl.head_safe.ml) 18 | (echo "# 1 \"htbl.body.ml\"\n") 19 | (cat htbl.body.ml))))) 20 | 21 | (mdx 22 | (package saturn) 23 | (enabled_if 24 | (and 25 | (<> %{os_type} Win32) 26 | (>= %{ocaml_version} 5.1.0))) 27 | (libraries saturn) 28 | (files htbl_intf.mli)) 29 | -------------------------------------------------------------------------------- /src/htbl/htbl_unsafe.mli: -------------------------------------------------------------------------------- 1 | (** Optimized lock-free and resizable hash table. 2 | 3 | The operations provided by this hash table are designed to work as building 4 | blocks of non-blocking algorithms. Specifically, the operation signatures 5 | and semantics are designed to allow building 6 | {{:https://dl.acm.org/doi/10.1145/62546.62593} consensus protocols over 7 | arbitrary numbers of processes}. 8 | 9 | 🏎️ Single key reads with this hash table are actually wait-free rather than 10 | just lock-free. Internal resizing automatically uses all the threads that 11 | are trying to write to the hash table. *) 12 | 13 | include Htbl_intf.HTBL 14 | -------------------------------------------------------------------------------- /src/michael_scott_queue/michael_scott_queue.mli: -------------------------------------------------------------------------------- 1 | (** Michael-Scott classic lock-free multi-producer multi-consumer queue. 2 | 3 | All functions are lockfree. It is the recommended starting point when 4 | needing FIFO structure. It is inspired by 5 | {{:https://www.cs.rochester.edu/~scott/papers/1996_PODC_queues.pdf} Simple, 6 | Fast, and Practical Non-Blocking and Blocking Concurrent Queue Algorithms}. 7 | 8 | If you need a [length] function, you can use the bounded queue 9 | {!Saturn.Bounded_queue} instead with maximun capacity (default value). 10 | However, this adds a general overhead to the operation. *) 11 | 12 | include Michael_scott_queue_intf.MS_QUEUE 13 | -------------------------------------------------------------------------------- /src/michael_scott_queue/michael_scott_queue_unsafe.mli: -------------------------------------------------------------------------------- 1 | (** Optimized Michael-Scott lock-free multi-producer multi-consumer queue. 2 | 3 | All functions are lockfree. It is the recommended starting point when 4 | needing FIFO structure. It is inspired by 5 | {{:https://www.cs.rochester.edu/~scott/papers/1996_PODC_queues.pdf} Simple, 6 | Fast, and Practical Non-Blocking and Blocking Concurrent Queue Algorithms}. 7 | 8 | If you need a [length] function, you can use the bounded queue 9 | {!Saturn.Bounded_queue} instead with maximun capacity (default value). 10 | However, this adds a general overhead to the operation. *) 11 | 12 | include Michael_scott_queue_intf.MS_QUEUE 13 | -------------------------------------------------------------------------------- /src/bounded_queue/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (with-stdout-to 4 | bounded_queue.ml 5 | (progn 6 | (echo "# 1 \"bounded_queue.head_safe.ml\"\n") 7 | (cat bounded_queue.head_safe.ml) 8 | (echo "# 1 \"bounded_queue.body.ml\"\n") 9 | (cat bounded_queue.body.ml))))) 10 | 11 | (rule 12 | (action 13 | (with-stdout-to 14 | bounded_queue_unsafe.ml 15 | (progn 16 | (echo "# 1 \"bounded_queue.head_unsafe.ml\"\n") 17 | (cat bounded_queue.head_unsafe.ml) 18 | (echo "# 1 \"bounded_queue.body.ml\"\n") 19 | (cat bounded_queue.body.ml))))) 20 | 21 | (mdx 22 | (package saturn) 23 | (enabled_if 24 | (and 25 | (<> %{os_type} Win32) 26 | (>= %{ocaml_version} 5.0.0))) 27 | (libraries saturn) 28 | (files bounded_queue_intf.mli)) 29 | -------------------------------------------------------------------------------- /test/mpsc_queue/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy ../../src/mpsc_queue.ml mpsc_queue.ml)) 4 | (package saturn)) 5 | 6 | (test 7 | (package saturn) 8 | (name mpsc_queue_dscheck) 9 | (libraries atomic dscheck alcotest) 10 | (build_if 11 | (>= %{ocaml_version} 5)) 12 | (modules mpsc_queue mpsc_queue_dscheck)) 13 | 14 | (test 15 | (package saturn) 16 | (name qcheck_mpsc_queue) 17 | (libraries 18 | saturn 19 | barrier 20 | qcheck 21 | qcheck-core 22 | qcheck-alcotest 23 | domain_shims 24 | alcotest) 25 | (modules qcheck_mpsc_queue)) 26 | 27 | (test 28 | (package saturn) 29 | (name stm_mpsc_queue) 30 | (modules stm_mpsc_queue) 31 | (libraries 32 | saturn 33 | qcheck-core 34 | qcheck-multicoretests-util 35 | qcheck-stm.stm 36 | stm_run)) 37 | -------------------------------------------------------------------------------- /test/skiplist/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (progn 4 | (copy ../../src/skiplist.ml skiplist.ml) 5 | (copy ../../src/size.ml size.ml))) 6 | (package saturn)) 7 | 8 | (test 9 | (package saturn) 10 | (name dscheck_skiplist) 11 | (modules skiplist size dscheck_skiplist) 12 | (build_if 13 | (>= %{ocaml_version} 5)) 14 | (libraries alcotest dscheck multicore-magic-dscheck) 15 | (flags 16 | (:standard -open Multicore_magic_dscheck))) 17 | 18 | (test 19 | (package saturn) 20 | (name qcheck_skiplist) 21 | (modules qcheck_skiplist) 22 | (libraries 23 | saturn 24 | barrier 25 | qcheck 26 | qcheck-core 27 | qcheck-alcotest 28 | alcotest 29 | domain_shims)) 30 | 31 | (test 32 | (package saturn) 33 | (name stm_skiplist) 34 | (modules stm_skiplist) 35 | (libraries saturn qcheck-core qcheck-stm.stm stm_run)) 36 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 KC Sivaramakrishnan 2 | Copyright (C) 2022 Thomas Leonard 3 | Copyright (C) 2023 Vesa Karvonen 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /src/michael_scott_queue/michael_scott_queue_unsafe_node.ml: -------------------------------------------------------------------------------- 1 | module Atomic = Multicore_magic.Transparent_atomic 2 | 3 | type ('a, _) t = 4 | | Nil : ('a, [> `Nil ]) t 5 | | Next : { 6 | mutable next : ('a, [ `Nil | `Next ]) t; 7 | mutable value : 'a; 8 | } 9 | -> ('a, [> `Next ]) t 10 | 11 | let[@inline] make value = Next { next = Nil; value } 12 | 13 | let node_of_list values = 14 | let (Next tail_node as tail) : ('a, [ `Next ]) t = 15 | Next { value = Obj.magic (); next = Nil } 16 | in 17 | let rec build_next = function 18 | | [ x ] -> 19 | tail_node.value <- x; 20 | tail 21 | | hd :: tl -> Next { next = build_next tl; value = hd } 22 | | [] -> assert false 23 | in 24 | (tail, build_next values) 25 | 26 | external as_atomic : ('a, [ `Next ]) t -> ('a, [ `Nil | `Next ]) t Atomic.t 27 | = "%identity" 28 | -------------------------------------------------------------------------------- /test/treiber_stack/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy ../../src/treiber_stack.ml treiber_stack.ml)) 4 | (package saturn)) 5 | 6 | (test 7 | (package saturn) 8 | (name treiber_stack_dscheck) 9 | (libraries atomic dscheck alcotest backoff multicore-magic) 10 | (build_if 11 | (and 12 | (>= %{ocaml_version} 5) 13 | (not 14 | (and 15 | (= %{arch_sixtyfour} false) 16 | (= %{architecture} arm))))) 17 | (modules treiber_stack treiber_stack_dscheck)) 18 | 19 | (test 20 | (package saturn) 21 | (name qcheck_treiber_stack) 22 | (libraries 23 | saturn 24 | barrier 25 | qcheck 26 | qcheck-core 27 | qcheck-alcotest 28 | domain_shims 29 | alcotest) 30 | (modules qcheck_treiber_stack)) 31 | 32 | (test 33 | (package saturn) 34 | (name stm_treiber_stack) 35 | (modules stm_treiber_stack) 36 | (libraries saturn qcheck-core qcheck-stm.stm stm_run)) 37 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let maybe_domain_shims = 4 | if Jbuild_plugin.V1.ocaml_version < "5" then "domain_shims" else "" 5 | 6 | let () = 7 | Jbuild_plugin.V1.send 8 | @@ {| 9 | 10 | (rule 11 | (action 12 | (copy ../src/htbl/htbl_intf.mli htbl_intf.ml)) 13 | (package saturn)) 14 | 15 | (rule 16 | (action 17 | (copy ../src/michael_scott_queue/michael_scott_queue_intf.mli michael_scott_queue_intf.ml)) 18 | (package saturn)) 19 | 20 | (rule 21 | (action 22 | (copy ../src/spsc_queue/spsc_queue_intf.mli spsc_queue_intf.ml)) 23 | (package saturn)) 24 | 25 | (rule 26 | (action 27 | (copy ../src/bounded_queue/bounded_queue_intf.mli bounded_queue_intf.ml)) 28 | (package saturn)) 29 | 30 | (test 31 | (package saturn) 32 | (name main) 33 | (action 34 | (run %{test} -brief)) 35 | (libraries saturn multicore-bench multicore-magic |} 36 | ^ maybe_domain_shims ^ {| )) 37 | |} 38 | -------------------------------------------------------------------------------- /test/michael_scott_queue/michael_scott_queue_unsafe_node.ml: -------------------------------------------------------------------------------- 1 | open Multicore_magic_dscheck 2 | module Atomic = Multicore_magic.Transparent_atomic 3 | 4 | type ('a, _) t = 5 | | Nil : ('a, [> `Nil ]) t 6 | | Next : { 7 | next : ('a, [ `Nil | `Next ]) t Atomic.t; 8 | mutable value : 'a; 9 | } 10 | -> ('a, [> `Next ]) t 11 | 12 | let[@inline] make value = Next { next = Atomic.make Nil; value } 13 | 14 | let node_of_list values = 15 | let (Next tail_node as tail) : ('a, [ `Next ]) t = 16 | Next { value = Obj.magic (); next = Atomic.make Nil } 17 | in 18 | let rec build_next = function 19 | | [ x ] -> 20 | tail_node.value <- x; 21 | tail 22 | | value :: tl -> Next { value; next = Atomic.make @@ build_next tl } 23 | | [] -> assert false 24 | in 25 | (tail, Atomic.make @@ build_next values) 26 | 27 | let[@inline] as_atomic (Next r : ('a, [ `Next ]) t) = r.next 28 | -------------------------------------------------------------------------------- /test/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 | -------------------------------------------------------------------------------- /src/htbl/htbl_utils.ml: -------------------------------------------------------------------------------- 1 | let[@inline never] impossible () = failwith "impossible" 2 | 3 | let ceil_pow_2_minus_1 n = 4 | let n = Nativeint.of_int n in 5 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 1) in 6 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 2) in 7 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 4) in 8 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 8) in 9 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 16) in 10 | Nativeint.to_int 11 | (if Sys.int_size > 32 then 12 | Nativeint.logor n (Nativeint.shift_right_logical n 32) 13 | else n) 14 | 15 | let lo_buckets = 1 lsl 3 16 | 17 | and hi_buckets = 18 | (* floor_pow_2 *) 19 | let mask = ceil_pow_2_minus_1 Sys.max_array_length in 20 | mask lxor (mask lsr 1) 21 | 22 | let min_buckets_default = 1 lsl 4 23 | and max_buckets_default = Int.min hi_buckets (1 lsl 30 (* Limit of [hash] *)) 24 | -------------------------------------------------------------------------------- /src/htbl/htbl.head_unsafe.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2023 Vesa Karvonen 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 9 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 11 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 12 | OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 13 | PERFORMANCE OF THIS SOFTWARE. *) 14 | 15 | module Atomic = Multicore_magic.Transparent_atomic 16 | module Atomic_array = Multicore_magic.Atomic_array 17 | -------------------------------------------------------------------------------- /src/bag.ml: -------------------------------------------------------------------------------- 1 | module Key = struct 2 | type t = int 3 | 4 | let equal = Int.equal 5 | let hash = Fun.id 6 | end 7 | 8 | type 'v t = (int, 'v) Htbl.t 9 | 10 | let create () = Htbl.create ~hashed_type:(module Key) () 11 | 12 | (* *) 13 | 14 | let rec push t value = 15 | let key = Int64.to_int (Random.bits64 ()) in 16 | if not (Htbl.try_add t key value) then push t value 17 | 18 | (* *) 19 | 20 | exception Empty 21 | 22 | type ('a, _) poly = Option : ('a, 'a option) poly | Value : ('a, 'a) poly 23 | 24 | let rec pop_as : type a r. a t -> (a, r) poly -> r = 25 | fun t poly -> 26 | match Htbl.find_random_exn t with 27 | | key -> begin 28 | match Htbl.remove_exn t key with 29 | | value -> ( match poly with Option -> Some value | Value -> value) 30 | | exception Not_found -> pop_as t poly 31 | end 32 | | exception Not_found -> ( 33 | match poly with Option -> None | Value -> raise Empty) 34 | 35 | let pop_exn t = pop_as t Value 36 | let pop_opt t = pop_as t Option 37 | -------------------------------------------------------------------------------- /bench/main.ml: -------------------------------------------------------------------------------- 1 | let benchmarks = 2 | [ 3 | ("Saturn Queue (MS)", Bench_queue.Safe.run_suite); 4 | ("Saturn Queue_unsafe (MS)", Bench_queue.Unsafe.run_suite); 5 | ("Saturn Bounded_Queue", Bench_bounded_queue.Safe.run_suite); 6 | ("Saturn Bounded_Queue_unsafe", Bench_bounded_queue.Unsafe.run_suite); 7 | ("Saturn Single_prod_single_cons_queue", Bench_spsc_queue.Safe.run_suite); 8 | ( "Saturn Single_prod_single_cons_queue_unsafe", 9 | Bench_spsc_queue.Unsafe.run_suite ); 10 | ("Saturn Single_consumer_queue", Bench_mpsc.run_suite); 11 | ("Saturn Size", Bench_size.run_suite); 12 | ("Saturn Skiplist", Bench_skiplist.run_suite); 13 | ("Saturn Htbl", Bench_htbl.Safe.run_suite); 14 | ("Saturn Htbl_unsafe", Bench_htbl.Unsafe.run_suite); 15 | ("Saturn Stack", Bench_stack.run_suite); 16 | ("Saturn Work_stealing_deque", Bench_ws_deque.run_suite); 17 | ("Saturn Bounded_Stack", Bench_bounded_stack.run_suite); 18 | ] 19 | 20 | let () = Multicore_bench.Cmd.run ~benchmarks () 21 | -------------------------------------------------------------------------------- /test/stm_run/stm_run.ocaml5.ml: -------------------------------------------------------------------------------- 1 | include Intf 2 | 3 | let run (type cmd state sut) ?(verbose = true) ?(count = default_count) 4 | ?(budgetf = default_budgetf) ~name ?make_domain 5 | (module Spec : STM.Spec 6 | with type cmd = cmd 7 | and type state = state 8 | and type sut = sut) = 9 | let module Seq = STM_sequential.Make (Spec) in 10 | let module Dom = struct 11 | module Spec = Spec 12 | include STM_domain.Make (Spec) 13 | end in 14 | Util.run_with_budget ~budgetf ~count @@ fun count -> 15 | [ 16 | [ Seq.agree_test ~count ~name:(name ^ " sequential") ]; 17 | (match make_domain with 18 | | None -> [ Dom.agree_test_par ~count ~name:(name ^ " parallel") ] 19 | | Some make_domain -> 20 | make_domain ~count ~name 21 | (module Dom : STM_domain 22 | with type Spec.cmd = cmd 23 | and type Spec.state = state 24 | and type Spec.sut = sut)); 25 | ] 26 | |> List.concat 27 | |> QCheck_base_runner.run_tests ~verbose 28 | -------------------------------------------------------------------------------- /test/htbl/htbl_utils.ml: -------------------------------------------------------------------------------- 1 | (* This file enables to define a lower low_buckets value for dscheck testing *) 2 | 3 | let[@inline never] impossible () = failwith "impossible" 4 | 5 | let ceil_pow_2_minus_1 n = 6 | let n = Nativeint.of_int n in 7 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 1) in 8 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 2) in 9 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 4) in 10 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 8) in 11 | let n = Nativeint.logor n (Nativeint.shift_right_logical n 16) in 12 | Nativeint.to_int 13 | (if Sys.int_size > 32 then 14 | Nativeint.logor n (Nativeint.shift_right_logical n 32) 15 | else n) 16 | 17 | let lo_buckets = 1 lsl 1 18 | 19 | and hi_buckets = 20 | (* floor_pow_2 *) 21 | let mask = ceil_pow_2_minus_1 Sys.max_array_length in 22 | mask lxor (mask lsr 1) 23 | 24 | let min_buckets_default = 1 lsl 4 25 | and max_buckets_default = Int.min hi_buckets (1 lsl 30 (* Limit of [hash] *)) 26 | -------------------------------------------------------------------------------- /src/bounded_queue/bounded_queue.head_safe.ml: -------------------------------------------------------------------------------- 1 | type ('a, _) node = 2 | | Null : ('a, [> `Null ]) node 3 | | Node : { 4 | next : 'a link Atomic.t; 5 | mutable value : 'a; 6 | mutable capacity : int; 7 | mutable counter : int; 8 | } 9 | -> ('a, [> `Node ]) node 10 | 11 | and 'a link = Link : ('a, [< `Null | `Node ]) node -> 'a link [@@unboxed] 12 | 13 | let[@inline] make_node ~value ~capacity ~counter next = 14 | Node { next = Atomic.make (Link next); value; capacity; counter } 15 | 16 | let[@inline] link_as_node (Link n) : (_, [< `Node ]) node = 17 | match n with Null -> assert false | Node _ as node -> node 18 | 19 | let[@inline] get_next (Node node : (_, [< `Node ]) node) = Atomic.get node.next 20 | 21 | let[@inline] fenceless_get_next (Node node : (_, [< `Node ]) node) = 22 | Atomic.get node.next 23 | 24 | let[@inline] compare_and_set_next (Node node : (_, [< `Node ]) node) before 25 | after = 26 | Atomic.compare_and_set node.next before after 27 | 28 | let fenceless_get = Atomic.get 29 | -------------------------------------------------------------------------------- /test/htbl/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy ../../src/htbl/htbl.ml htbl.ml)) 4 | (package saturn)) 5 | 6 | (rule 7 | (action 8 | (copy ../../src/htbl/htbl_unsafe.ml htbl_unsafe.ml)) 9 | (package saturn)) 10 | 11 | (rule 12 | (action 13 | (copy ../../src/htbl/htbl_intf.mli htbl_intf.ml)) 14 | (package saturn)) 15 | 16 | (rule 17 | (action 18 | (copy ../../src/size.ml size.ml)) 19 | (package saturn)) 20 | 21 | (test 22 | (package saturn) 23 | (name dscheck_htbl) 24 | (libraries alcotest atomic backoff dscheck multicore-magic-dscheck) 25 | (build_if 26 | (and 27 | (>= %{ocaml_version} 5) 28 | (not 29 | (and 30 | (= %{arch_sixtyfour} false) 31 | (= %{architecture} arm))))) 32 | (modules htbl htbl_unsafe htbl_intf htbl_utils dscheck_htbl size) 33 | (flags 34 | (:standard -open Multicore_magic_dscheck))) 35 | 36 | (test 37 | (package saturn) 38 | (name stm_htbl) 39 | (modules stm_htbl) 40 | (libraries htbls saturn qcheck-core qcheck-stm.stm stm_run) 41 | (enabled_if 42 | (= %{arch_sixtyfour} true))) 43 | -------------------------------------------------------------------------------- /src/bounded_queue/bounded_queue.head_unsafe.ml: -------------------------------------------------------------------------------- 1 | module Atomic = Multicore_magic.Transparent_atomic 2 | 3 | type ('a, _) node = 4 | | Null : ('a, [> `Null ]) node 5 | | Node : { 6 | mutable _next : 'a link; 7 | mutable value : 'a; 8 | mutable capacity : int; 9 | mutable counter : int; 10 | } 11 | -> ('a, [> `Node ]) node 12 | 13 | and 'a link = Link : ('a, [< `Null | `Node ]) node -> 'a link [@@unboxed] 14 | 15 | let[@inline] make_node ~value ~capacity ~counter next = 16 | Node { _next = Link next; value; capacity; counter } 17 | 18 | external link_as_node : 'a link -> ('a, [ `Node ]) node = "%identity" 19 | 20 | external next_as_atomic : ('a, [< `Node ]) node -> 'a link Atomic.t 21 | = "%identity" 22 | 23 | let[@inline] get_next node = Atomic.get (next_as_atomic node) 24 | 25 | let[@inline] fenceless_get_next node = 26 | Atomic.fenceless_get (next_as_atomic node) 27 | 28 | let[@inline] compare_and_set_next node before after = 29 | Atomic.compare_and_set (next_as_atomic node) before after 30 | 31 | let fenceless_get = Atomic.fenceless_get 32 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let maybe_threads = 4 | if Jbuild_plugin.V1.ocaml_version < "5" then "threads.posix" else "" 5 | 6 | let () = 7 | Jbuild_plugin.V1.send 8 | @@ {| 9 | 10 | (include_subdirs unqualified) 11 | 12 | (library 13 | (name saturn) 14 | (public_name saturn) 15 | (modules_without_implementation htbl_intf bounded_queue_intf spsc_queue_intf michael_scott_queue_intf) 16 | (libraries backoff multicore-magic |} 17 | ^ maybe_threads 18 | ^ {| )) 19 | 20 | (rule 21 | (enabled_if 22 | (< %{ocaml_version} 5.0.0)) 23 | (action 24 | (copy domain.ocaml4.ml domain.ml))) 25 | 26 | (rule 27 | (enabled_if 28 | (< %{ocaml_version} 4.14.0)) 29 | (action 30 | (copy seq.ocaml4.13.ml seq.ml))) 31 | 32 | (rule 33 | (enabled_if 34 | (< %{ocaml_version} 5.2.0)) 35 | (action 36 | (copy atomic.without_contended.ml atomic.ml))) 37 | 38 | (mdx 39 | (package saturn) 40 | (enabled_if 41 | (and 42 | (<> %{os_type} Win32) 43 | (>= %{ocaml_version} 5.0.0))) 44 | (libraries saturn) 45 | (files treiber_stack.mli bounded_stack.mli ws_deque.mli mpsc_queue.mli skiplist.mli bag.mli)) 46 | |} 47 | -------------------------------------------------------------------------------- /test/bag/stm_bag.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open STM 3 | module Bag = Saturn.Bag 4 | 5 | (* Only check that the size of the bag stays consistent. *) 6 | 7 | module Spec = struct 8 | type cmd = Push | Pop 9 | 10 | let show_cmd c = match c with Push -> "Push ()" | Pop -> "Pop" 11 | 12 | module Sint = Set.Make (Int) 13 | 14 | type state = int 15 | type sut = unit Bag.t 16 | 17 | let arb_cmd _s = 18 | QCheck.make ~print:show_cmd (Gen.oneof [ Gen.return Push; Gen.return Pop ]) 19 | 20 | let init_state = 0 21 | let init_sut () = Bag.create () 22 | let cleanup _ = () 23 | 24 | let next_state c s = 25 | match c with Push -> s + 1 | Pop -> if s > 0 then s - 1 else s 26 | 27 | let precond _ _ = true 28 | 29 | let run c d = 30 | match c with 31 | | Push -> Res (unit, Bag.push d ()) 32 | | Pop -> Res (option unit, Bag.pop_opt d) 33 | 34 | let postcond c (s : state) res = 35 | match (c, res) with 36 | | Push, Res ((Unit, _), _res) -> true 37 | | Pop, Res ((Option Unit, _), res) -> 38 | if s > 0 then res = Some () else res = None 39 | | _, _ -> false 40 | end 41 | 42 | let () = Stm_run.run ~name:"Saturn.Bag" (module Spec) |> exit 43 | -------------------------------------------------------------------------------- /test/ws_deque/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy ../../src/ArrayExtra.ml ArrayExtra.ml)) 4 | (package saturn)) 5 | 6 | (rule 7 | (action 8 | (copy ../../src/ws_deque.ml ws_deque.ml)) 9 | (package saturn)) 10 | 11 | (test 12 | (package saturn) 13 | (name ws_deque_dscheck) 14 | (libraries atomic dscheck alcotest backoff multicore-magic-dscheck) 15 | (build_if 16 | (>= %{ocaml_version} 5)) 17 | (modules ArrayExtra ws_deque ws_deque_dscheck) 18 | (flags 19 | (:standard -open Multicore_magic_dscheck))) 20 | 21 | (test 22 | (package saturn) 23 | (name test_ws_deque) 24 | (libraries saturn domain_shims) 25 | (modules test_ws_deque)) 26 | 27 | (test 28 | (package saturn) 29 | (name qcheck_ws_deque) 30 | (libraries 31 | barrier 32 | saturn 33 | qcheck 34 | qcheck-core 35 | qcheck-alcotest 36 | domain_shims 37 | alcotest) 38 | (enabled_if 39 | (not 40 | (and 41 | (= %{arch_sixtyfour} false) 42 | (= %{architecture} arm)))) 43 | (modules qcheck_ws_deque)) 44 | 45 | (test 46 | (package saturn) 47 | (name stm_ws_deque) 48 | (modules stm_ws_deque) 49 | (libraries 50 | saturn 51 | qcheck-core 52 | qcheck-multicoretests-util 53 | qcheck-stm.stm 54 | stm_run)) 55 | -------------------------------------------------------------------------------- /bench/bench_size.ml: -------------------------------------------------------------------------------- 1 | open Multicore_bench 2 | module Size = Saturn.Size 3 | 4 | let run_one ~budgetf ~n_domains ?(n_ops = 250 * n_domains * Util.iter_factor) () 5 | = 6 | let t = Size.create () in 7 | 8 | let n_ops_todo = Atomic.make 0 |> Multicore_magic.copy_as_padded in 9 | 10 | let init _ = Atomic.set n_ops_todo n_ops in 11 | let work _ () = 12 | let rec work () = 13 | let n = Util.alloc n_ops_todo in 14 | if n <> 0 then 15 | let rec loop n = 16 | if 0 < n then begin 17 | let incr = Size.new_once t Size.incr in 18 | Size.update_once t incr; 19 | let decr = Size.new_once t Size.decr in 20 | Size.update_once t decr; 21 | loop (n - 2) 22 | end 23 | else work () 24 | in 25 | loop n 26 | in 27 | work () 28 | in 29 | 30 | let config = 31 | Printf.sprintf "%d worker%s" n_domains (if n_domains = 1 then "" else "s") 32 | in 33 | Times.record ~budgetf ~n_domains ~init ~work () 34 | |> Times.to_thruput_metrics ~n:n_ops ~config ~singular:"operation" 35 | 36 | let run_suite ~budgetf = 37 | [ 1; 2; 4 ] 38 | |> List.concat_map @@ fun n_domains -> run_one ~n_domains ~budgetf () 39 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: main 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: 7 | - main 8 | schedule: 9 | # Prime the caches every Monday 10 | - cron: 0 1 * * MON 11 | 12 | jobs: 13 | windows: 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | ocaml-compiler: 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@v2 28 | 29 | - name: Set up OCaml 30 | uses: ocaml/setup-ocaml@v3.3.2 31 | with: 32 | opam-pin: false 33 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 34 | opam-repositories: | 35 | dra27: https://github.com/dra27/opam-repository.git#windows-5.0 36 | default: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset 37 | upstream: https://github.com/ocaml/opam-repository.git 38 | 39 | - name: Install dependencies 40 | run: opam install . --deps-only --with-test 41 | 42 | - name: Build 43 | run: opam exec -- dune build 44 | 45 | - name: Test 46 | run: opam exec -- dune runtest 47 | -------------------------------------------------------------------------------- /src/htbl/htbl.head_safe.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2023 Vesa Karvonen 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 9 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 11 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 12 | OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 13 | PERFORMANCE OF THIS SOFTWARE. *) 14 | 15 | module Atomic_array = struct 16 | type 'a t = 'a Atomic.t array 17 | 18 | let[@inline] at (xs : 'a t) i : 'a Atomic.t = Array.get xs i 19 | let[@inline] make n v = Array.init n @@ fun _ -> Atomic.make v 20 | 21 | external length : 'a array -> int = "%array_length" 22 | 23 | let unsafe_fenceless_get xs i = Atomic.get xs.(i) 24 | 25 | let[@inline] unsafe_compare_and_set xs i b a = 26 | Atomic.compare_and_set (at xs i) b a 27 | end 28 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.14) 2 | (name saturn) 3 | (generate_opam_files true) 4 | (implicit_transitive_deps false) 5 | (source (github ocaml-multicore/saturn)) 6 | (license ISC) 7 | (authors "KC Sivaramakrishnan") 8 | (maintainers "Carine Morel" "KC Sivaramakrishnan" "Sudha Parimala") 9 | (documentation "https://ocaml-multicore.github.io/saturn/") 10 | (using mdx 0.4) 11 | 12 | (package 13 | (name saturn) 14 | (synopsis "Collection of concurent-safe data structures for Multicore OCaml") 15 | (depends 16 | (ocaml (or (and (>= 4.14) (< 5.0.0)) (>= 5.2.0))) 17 | (backoff (>= 0.1.1)) 18 | (multicore-magic (>= 2.3.0)) 19 | (alcotest (and (>= 1.7.0) :with-test)) 20 | (domain_shims (and (>= 0.1.0) :with-test)) 21 | (dscheck (and (>= 0.5.0) :with-test)) 22 | (mdx (and (>= 0.4) :with-test)) 23 | (multicore-bench (and (>= 0.1.7) :with-test)) 24 | (multicore-magic-dscheck (and (>= 2.3.0) :with-test)) 25 | (qcheck (and (>= 0.21.3) :with-test)) 26 | (qcheck-alcotest (and (>= 0.21.3) :with-test)) 27 | (qcheck-core (and (>= 0.21.3) :with-test)) 28 | (qcheck-stm (and (>= 0.4) :with-test)) 29 | (qcheck-multicoretests-util (and (>= 0.4) :with-test)) 30 | (yojson (and (>= 2.0.2) :with-test)) 31 | (sherlodoc (and (>= 0.2) :with-doc)) 32 | (odoc (and (>= 2.4.1) :with-doc)))) 33 | -------------------------------------------------------------------------------- /test/spsc_queue/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy ../../src/spsc_queue/spsc_queue.ml spsc_queue.ml)) 4 | (package saturn)) 5 | 6 | (rule 7 | (action 8 | (copy ../../src/spsc_queue/spsc_queue_unsafe.ml spsc_queue_unsafe.ml)) 9 | (package saturn)) 10 | 11 | (rule 12 | (action 13 | (copy ../../src/spsc_queue/spsc_queue_intf.mli spsc_queue_intf.ml)) 14 | (package saturn)) 15 | 16 | (test 17 | (package saturn) 18 | (name spsc_queue_dscheck) 19 | (libraries alcotest atomic dscheck multicore-magic-dscheck) 20 | (build_if 21 | (>= %{ocaml_version} 5)) 22 | (modules spsc_queue spsc_queue_unsafe spsc_queue_intf spsc_queue_dscheck) 23 | (flags 24 | (:standard -open Multicore_magic_dscheck))) 25 | 26 | (test 27 | (package saturn) 28 | (name test_spsc_queue) 29 | (libraries spsc_queues domain_shims) 30 | (modules test_spsc_queue)) 31 | 32 | (test 33 | (package saturn) 34 | (name qcheck_spsc_queue) 35 | (libraries 36 | spsc_queues 37 | barrier 38 | qcheck 39 | qcheck-core 40 | qcheck-alcotest 41 | domain_shims 42 | alcotest) 43 | (modules qcheck_spsc_queue)) 44 | 45 | (test 46 | (package saturn) 47 | (name stm_spsc_queue) 48 | (modules stm_spsc_queue) 49 | (libraries 50 | spsc_queues 51 | qcheck-core 52 | qcheck-multicoretests-util 53 | qcheck-stm.stm 54 | stm_run)) 55 | -------------------------------------------------------------------------------- /.github/workflows/deploy-odoc.yml: -------------------------------------------------------------------------------- 1 | name: Deploy documentation to GitHub Pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | 8 | permissions: read-all 9 | 10 | concurrency: 11 | group: deploy-odoc 12 | cancel-in-progress: true 13 | 14 | jobs: 15 | deploy-odoc: 16 | name: Deploy odoc to GitHub Pages 17 | 18 | environment: 19 | name: github-pages 20 | url: ${{ steps.deployment.outputs.page_url }} 21 | 22 | permissions: 23 | contents: read 24 | id-token: write 25 | pages: write 26 | 27 | runs-on: ubuntu-latest 28 | 29 | steps: 30 | - name: Checkout tree 31 | uses: actions/checkout@v4 32 | 33 | - name: Set-up OCaml 34 | uses: ocaml/setup-ocaml@v3 35 | with: 36 | ocaml-compiler: "5.2.1" 37 | 38 | - name: Install dependencies 39 | run: opam install . --deps-only --with-doc 40 | 41 | - name: Build documentation 42 | run: opam exec -- dune build @doc 43 | 44 | - name: Set-up Pages 45 | uses: actions/configure-pages@v4 46 | 47 | - name: Upload artifact 48 | uses: actions/upload-pages-artifact@v2 49 | with: 50 | path: _build/default/_doc/_html 51 | 52 | - name: Deploy odoc to GitHub Pages 53 | id: deployment 54 | uses: actions/deploy-pages@v3 55 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | ## Contributing 2 | 3 | Any contributions are appreciated! Please create issues/PRs to this repo. 4 | 5 | ### Maintainers 6 | 7 | The current list of maintainers is as follows: 8 | 9 | - @kayceesrk KC Sivaramakrishnan 10 | - @lyrm Carine Morel 11 | - @Sudha247 Sudha Parimala 12 | 13 | ### Guidelines for new data structures implementation 14 | 15 | Reviewing most implementation takes times. Here are a few guidelines to make it 16 | easier for the reviewers : 17 | 18 | - the issue tracker has a good list of data structures to choose from 19 | - implement a well know algorithm (there are a lot !) 20 | - from a _reviewed_ paper, ideally with proof of main claimed properties (like 21 | lock-freedom, deadlock freedom etc..) 22 | - from a well known and used concurrent library (like `java.util.concurrent`) 23 | - write tests with **multiple** domains. All the following tests are expected to 24 | be provided before a proper review is done, especially for implementations 25 | that do not come from a well-know algorithm : 26 | - unitary tests and `qcheck tests` : with one and multiple domains. If domains 27 | have specific roles (producer, consumer, stealer, etc..), it should appear 28 | in the tests. 29 | - tests using `STM` from `multicoretest` 30 | - (_optional_) `dscheck` tests (for non-blocking implementation) 31 | -------------------------------------------------------------------------------- /test/bounded_queue/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy ../../src/bounded_queue/bounded_queue.ml bounded_queue.ml)) 4 | (package saturn)) 5 | 6 | (rule 7 | (action 8 | (copy 9 | ../../src/bounded_queue/bounded_queue_unsafe.ml 10 | bounded_queue_unsafe.ml)) 11 | (package saturn)) 12 | 13 | (rule 14 | (action 15 | (copy ../../src/bounded_queue/bounded_queue_intf.mli bounded_queue_intf.ml)) 16 | (package saturn)) 17 | 18 | (test 19 | (package saturn) 20 | (name dscheck_bounded_queue) 21 | (libraries alcotest atomic backoff dscheck multicore-magic-dscheck) 22 | (build_if 23 | (and 24 | (>= %{ocaml_version} 5) 25 | (not 26 | (and 27 | (= %{arch_sixtyfour} false) 28 | (= %{architecture} arm))))) 29 | (modules 30 | bounded_queue 31 | bounded_queue_unsafe 32 | bounded_queue_intf 33 | dscheck_bounded_queue) 34 | (flags 35 | (:standard -open Multicore_magic_dscheck))) 36 | 37 | (test 38 | (package saturn) 39 | (name stm_bounded_queue) 40 | (modules stm_bounded_queue) 41 | (libraries bounded_queues saturn qcheck-core qcheck-stm.stm stm_run) 42 | (enabled_if 43 | (= %{arch_sixtyfour} true))) 44 | 45 | (test 46 | (package saturn) 47 | (name qcheck_bounded_queue) 48 | (libraries 49 | bounded_queues 50 | saturn 51 | barrier 52 | qcheck 53 | qcheck-core 54 | qcheck-alcotest 55 | domain_shims 56 | alcotest) 57 | (modules qcheck_bounded_queue)) 58 | -------------------------------------------------------------------------------- /test/michael_scott_queue/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (action 3 | (copy 4 | ../../src/michael_scott_queue/michael_scott_queue.ml 5 | michael_scott_queue.ml)) 6 | (package saturn)) 7 | 8 | (rule 9 | (action 10 | (copy 11 | ../../src/michael_scott_queue/michael_scott_queue_unsafe.ml 12 | michael_scott_queue_unsafe.ml)) 13 | (package saturn)) 14 | 15 | (rule 16 | (action 17 | (copy 18 | ../../src/michael_scott_queue/michael_scott_queue_intf.mli 19 | michael_scott_queue_intf.ml)) 20 | (package saturn)) 21 | 22 | (test 23 | (package saturn) 24 | (name michael_scott_queue_dscheck) 25 | (libraries alcotest atomic backoff dscheck multicore-magic-dscheck) 26 | (build_if 27 | (and 28 | (>= %{ocaml_version} 5) 29 | (not 30 | (and 31 | (= %{arch_sixtyfour} false) 32 | (= %{architecture} arm))))) 33 | (modules 34 | michael_scott_queue 35 | michael_scott_queue_unsafe 36 | michael_scott_queue_unsafe_node 37 | michael_scott_queue_intf 38 | michael_scott_queue_dscheck) 39 | (flags 40 | (:standard -open Multicore_magic_dscheck))) 41 | 42 | (test 43 | (package saturn) 44 | (name qcheck_michael_scott_queue) 45 | (libraries 46 | ms_queues 47 | saturn 48 | barrier 49 | qcheck 50 | qcheck-core 51 | qcheck-alcotest 52 | domain_shims 53 | alcotest) 54 | (modules qcheck_michael_scott_queue)) 55 | 56 | (test 57 | (package saturn) 58 | (name stm_michael_scott_queue) 59 | (modules stm_michael_scott_queue) 60 | (libraries ms_queues saturn qcheck-core qcheck-stm.stm stm_run)) 61 | -------------------------------------------------------------------------------- /saturn.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Collection of concurent-safe data structures for Multicore OCaml" 4 | maintainer: ["Carine Morel" "KC Sivaramakrishnan" "Sudha Parimala"] 5 | authors: ["KC Sivaramakrishnan"] 6 | license: "ISC" 7 | homepage: "https://github.com/ocaml-multicore/saturn" 8 | doc: "https://ocaml-multicore.github.io/saturn/" 9 | bug-reports: "https://github.com/ocaml-multicore/saturn/issues" 10 | depends: [ 11 | "dune" {>= "3.14"} 12 | "ocaml" {>= "4.14" & < "5.0.0" | >= "5.2.0"} 13 | "backoff" {>= "0.1.1"} 14 | "multicore-magic" {>= "2.3.0"} 15 | "alcotest" {>= "1.7.0" & with-test} 16 | "domain_shims" {>= "0.1.0" & with-test} 17 | "dscheck" {>= "0.5.0" & with-test} 18 | "mdx" {>= "0.4" & with-test} 19 | "multicore-bench" {>= "0.1.7" & with-test} 20 | "multicore-magic-dscheck" {>= "2.3.0" & with-test} 21 | "qcheck" {>= "0.21.3" & with-test} 22 | "qcheck-alcotest" {>= "0.21.3" & with-test} 23 | "qcheck-core" {>= "0.21.3" & with-test} 24 | "qcheck-stm" {>= "0.4" & with-test} 25 | "qcheck-multicoretests-util" {>= "0.4" & with-test} 26 | "yojson" {>= "2.0.2" & with-test} 27 | "sherlodoc" {>= "0.2" & with-doc} 28 | "odoc" {>= "2.4.1" & with-doc} 29 | ] 30 | build: [ 31 | ["dune" "subst"] {dev} 32 | [ 33 | "dune" 34 | "build" 35 | "-p" 36 | name 37 | "-j" 38 | jobs 39 | "@install" 40 | "@runtest" {with-test} 41 | "@doc" {with-doc} 42 | ] 43 | ] 44 | dev-repo: "git+https://github.com/ocaml-multicore/saturn.git" 45 | -------------------------------------------------------------------------------- /test/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 | 47 | let default_count = 1_000 48 | let default_budgetf = 60.0 49 | -------------------------------------------------------------------------------- /src/bag.mli: -------------------------------------------------------------------------------- 1 | (** Randomized lock-free bag *) 2 | 3 | (** {1 API} *) 4 | 5 | type !'v t 6 | (** Represents a lock-free bag of elements of type 'v *) 7 | 8 | val create : unit -> 'v t 9 | (** [create ()] creates a new empty lock-free bag. *) 10 | 11 | val push : 'v t -> 'v -> unit 12 | (** [push bag elt] adds [elt] to the [bag]. *) 13 | 14 | exception Empty 15 | (** Raised when {!pop_exn} is applied to an empty bag. *) 16 | 17 | val pop_exn : 'v t -> 'v 18 | (** [pop_exn bag] removes and returns a random element of the [bag]. 19 | 20 | @raise Empty if the [bag] is empty. *) 21 | 22 | val pop_opt : 'v t -> 'v option 23 | (** [pop_opt bag] removes and returns [Some] of a random element of the [bag] 24 | and [None] if the [bag] is empty. *) 25 | 26 | (** {1 Example} 27 | 28 | {[ 29 | # Random.init 0 30 | - : unit = () 31 | # module Bag = Saturn.Bag 32 | module Bag = Saturn.Bag 33 | # let t : string Bag.t = Bag.create () 34 | val t : string Bag.t = 35 | 36 | # let planets = ["Mercury"; "Venus"; "Earth"; "Mars"; "Jupiter"; "Saturn"; "Uranus"; "Neptune"] 37 | val planets : string list = 38 | ["Mercury"; "Venus"; "Earth"; "Mars"; "Jupiter"; "Saturn"; "Uranus"; 39 | "Neptune"] 40 | # List.iter (Bag.push t) planets 41 | - : unit = () 42 | # Bag.pop_exn t 43 | - : string = "Neptune" 44 | # Bag.pop_opt t 45 | - : string option = Some "Saturn" 46 | # Bag.pop_exn t 47 | - : string = "Mercury" 48 | # Bag.pop_exn t 49 | - : string = "Mars" 50 | # Bag.pop_exn t 51 | - : string = "Earth" 52 | # Bag.pop_exn t 53 | - : string = "Venus" 54 | # Bag.pop_exn t 55 | - : string = "Uranus" 56 | # Bag.pop_exn t 57 | - : string = "Jupiter" 58 | # Bag.pop_exn t 59 | Exception: Saturn__Bag.Empty. 60 | ]} *) 61 | -------------------------------------------------------------------------------- /test/size/stm_size.ml: -------------------------------------------------------------------------------- 1 | module Linked_set = Linked_set.Make (Atomic) (Saturn.Size) 2 | 3 | module Spec = struct 4 | type cmd = Mem of int | Add of int | Remove of int | Length 5 | 6 | let show_cmd c = 7 | match c with 8 | | Mem i -> "Mem " ^ string_of_int i 9 | | Add i -> "Add " ^ string_of_int i 10 | | Remove i -> "Remove " ^ string_of_int i 11 | | Length -> "Length" 12 | 13 | module Sint = Set.Make (Int) 14 | 15 | type state = Sint.t 16 | type sut = int Linked_set.t 17 | 18 | let arb_cmd _s = 19 | QCheck.( 20 | make ~print:show_cmd 21 | (let int_gen = Gen.nat in 22 | Gen.oneof 23 | [ 24 | Gen.map (fun i -> Add i) int_gen; 25 | Gen.map (fun i -> Mem i) int_gen; 26 | Gen.map (fun i -> Remove i) int_gen; 27 | Gen.return Length; 28 | ])) 29 | 30 | let init_state = Sint.empty 31 | let init_sut () = Linked_set.create () 32 | let cleanup _ = () 33 | 34 | let next_state c s = 35 | match c with 36 | | Add i -> Sint.add i s 37 | | Remove i -> Sint.remove i s 38 | | Mem _ -> s 39 | | Length -> s 40 | 41 | let precond _ _ = true 42 | 43 | let run c d = 44 | let open STM in 45 | match c with 46 | | Add i -> Res (bool, Linked_set.try_add d i) 47 | | Remove i -> Res (bool, Linked_set.try_remove d i) 48 | | Mem i -> Res (bool, Linked_set.mem d i) 49 | | Length -> Res (int, Linked_set.length d) 50 | 51 | let postcond c (s : state) res = 52 | let open STM in 53 | match (c, res) with 54 | | Add i, Res ((Bool, _), res) -> Sint.mem i s = not res 55 | | Remove i, Res ((Bool, _), res) -> Sint.mem i s = res 56 | | Mem i, Res ((Bool, _), res) -> Sint.mem i s = res 57 | | Length, Res ((Int, _), res) -> Sint.cardinal s = res 58 | | _, _ -> false 59 | end 60 | 61 | let () = 62 | Stm_run.run ~count:1000 ~verbose:true ~name:"Saturn.Size" (module Spec) 63 | |> exit 64 | -------------------------------------------------------------------------------- /bench/bench_spsc_queue.ml: -------------------------------------------------------------------------------- 1 | open Multicore_bench 2 | 3 | module type BENCH = sig 4 | val run_suite : budgetf:float -> Metric.t list 5 | end 6 | 7 | module Make (Queue : Spsc_queue_intf.SPSC_queue) : BENCH = struct 8 | let run_one ~budgetf ?(size_exponent = 3) ?(n_msgs = 80 * Util.iter_factor) () 9 | = 10 | let init _ = () in 11 | let work, before = 12 | let t = Queue.create ~size_exponent in 13 | 14 | let before () = 15 | while Queue.length t <> 0 do 16 | Queue.pop_exn t |> ignore 17 | done; 18 | let n = Random.int ((1 lsl size_exponent) + 1) in 19 | for i = 1 to n do 20 | Queue.push_exn t (ref i) 21 | done 22 | in 23 | let work i () = 24 | if i = 0 then 25 | let rec loop n = 26 | if 0 < n then 27 | if Queue.try_push t (ref n) then loop (n - 1) 28 | else begin 29 | Domain.cpu_relax (); 30 | loop n 31 | end 32 | in 33 | loop n_msgs 34 | else 35 | let rec loop n = 36 | if 0 < n then 37 | match Queue.pop_opt t with 38 | | Some _ -> loop (n - 1) 39 | | None -> 40 | Domain.cpu_relax (); 41 | loop n 42 | in 43 | loop n_msgs 44 | in 45 | (work, before) 46 | in 47 | 48 | let config = 49 | Printf.sprintf "2 workers, capacity %d" (1 lsl size_exponent) 50 | in 51 | Times.record ~budgetf ~n_domains:2 ~before ~init ~work () 52 | |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config 53 | 54 | let run_suite ~budgetf = 55 | [ 0; 3; 6; 9; 12; 15 ] 56 | |> List.concat_map @@ fun size_exponent -> 57 | run_one ~budgetf ~size_exponent () 58 | end 59 | 60 | module Safe = Make (Saturn.Single_prod_single_cons_queue) 61 | module Unsafe = Make (Saturn.Single_prod_single_cons_queue_unsafe) 62 | -------------------------------------------------------------------------------- /test/skiplist/stm_skiplist.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open STM 3 | 4 | module Skiplist = struct 5 | include Saturn.Skiplist 6 | 7 | type nonrec 'a t = ('a, unit) t 8 | 9 | let try_add s k = try_add s k () 10 | end 11 | 12 | module Spec = struct 13 | type cmd = Mem of int | Add of int | Remove of int | Length 14 | 15 | let show_cmd c = 16 | match c with 17 | | Mem i -> "Mem " ^ string_of_int i 18 | | Add i -> "Add " ^ string_of_int i 19 | | Remove i -> "Remove " ^ string_of_int i 20 | | Length -> "Length" 21 | 22 | module Sint = Set.Make (Int) 23 | 24 | type state = Sint.t 25 | type sut = int Skiplist.t 26 | 27 | let arb_cmd _s = 28 | let int_gen = Gen.nat in 29 | QCheck.make ~print:show_cmd 30 | (Gen.oneof 31 | [ 32 | Gen.map (fun i -> Add i) int_gen; 33 | Gen.map (fun i -> Mem i) int_gen; 34 | Gen.map (fun i -> Remove i) int_gen; 35 | Gen.return Length; 36 | ]) 37 | 38 | let init_state = Sint.empty 39 | let init_sut () = Skiplist.create ~compare:Int.compare () 40 | let cleanup _ = () 41 | 42 | let next_state c s = 43 | match c with 44 | | Add i -> Sint.add i s 45 | | Remove i -> Sint.remove i s 46 | | Mem _ -> s 47 | | Length -> s 48 | 49 | let precond _ _ = true 50 | 51 | let run c d = 52 | match c with 53 | | Add i -> Res (bool, Skiplist.try_add d i) 54 | | Remove i -> Res (bool, Skiplist.try_remove d i) 55 | | Mem i -> Res (bool, Skiplist.mem d i) 56 | | Length -> Res (int, Skiplist.length d) 57 | 58 | let postcond c (s : state) res = 59 | match (c, res) with 60 | | Add i, Res ((Bool, _), res) -> Sint.mem i s = not res 61 | | Remove i, Res ((Bool, _), res) -> Sint.mem i s = res 62 | | Mem i, Res ((Bool, _), res) -> Sint.mem i s = res 63 | | Length, Res ((Int, _), res) -> Sint.cardinal s = res 64 | | _, _ -> false 65 | end 66 | 67 | let () = Stm_run.run ~name:"Saturn.Skiplist" (module Spec) |> exit 68 | -------------------------------------------------------------------------------- /src/saturn.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (*--------------------------------------------------------------------------- 8 | Copyright (c) 2016 KC Sivaramakrishnan 9 | 10 | Permission to use, copy, modify, and/or distribute this software for any 11 | purpose with or without fee is hereby granted, provided that the above 12 | copyright notice and this permission notice appear in all copies. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 15 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 16 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 17 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 18 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 19 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 20 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 21 | ---------------------------------------------------------------------------*) 22 | 23 | (* 24 | ######## 25 | Copyright (c) 2017, Nicolas ASSOUAD 26 | ######## 27 | *) 28 | 29 | module Queue = Michael_scott_queue 30 | module Queue_unsafe = Michael_scott_queue_unsafe 31 | module Bounded_queue = Bounded_queue 32 | module Bounded_queue_unsafe = Bounded_queue_unsafe 33 | module Stack = Treiber_stack 34 | module Bounded_stack = Bounded_stack 35 | module Work_stealing_deque = Ws_deque 36 | module Single_prod_single_cons_queue = Spsc_queue 37 | module Single_prod_single_cons_queue_unsafe = Spsc_queue_unsafe 38 | module Single_consumer_queue = Mpsc_queue 39 | module Size = Size 40 | module Skiplist = Skiplist 41 | module Htbl = Htbl 42 | module Htbl_unsafe = Htbl_unsafe 43 | module Bag = Bag 44 | -------------------------------------------------------------------------------- /bench/README.md: -------------------------------------------------------------------------------- 1 | # Benchmarks for Saturn 2 | 3 | Benchmarks are written using [multicore-bench](https://github.com/ocaml-multicore/multicore-bench). 4 | 5 | ## General Usage 6 | 7 | To execute benchmarks, you can run: 8 | ```shell 9 | make bench 10 | ``` 11 | 12 | Alternatively, you can use: 13 | ```shell 14 | dune exec -- ./bench/main.exe 15 | ``` 16 | 17 | It is recommended to run the benchmarks with a budget of at least `1` second (as done with `make bench`): 18 | ```shell 19 | dune exec -- ./bench/main.exe -budget 1 20 | ``` 21 | 22 | You can also print a brief version of the benchmarks with the `-brief` option. Additionally, it is possible to run only selected benchmarks by providing a part of the benchmark names. You can get the list of available benchmarks with the `--help` option. 23 | 24 | For example, running: 25 | ```shell 26 | dune exec -- ./bench/main.exe --help 27 | ``` 28 | returns: 29 | 30 | ``` 31 | Usage: main.exe