saturn-0.5.0/0000755000175000017500000000000014702247137011531 5ustar kylekylesaturn-0.5.0/src/0000755000175000017500000000000014661627530012323 5ustar kylekylesaturn-0.5.0/src/mpmc_relaxed_queue.ml0000644000175000017500000001204714661627530016525 0ustar kylekyleinclude Saturn_lockfree.Relaxed_queue module Spin = struct let push = push let pop = pop end (* [ccas] A slightly nicer CAS. Tries without taking microarch lock first. Use on indices. *) let ccas cell seen v = if Atomic.get cell != seen then false else Atomic.compare_and_set cell seen v module Not_lockfree = struct (* [spin_threshold] Number of times on spin on a slot before trying an exit strategy. *) let spin_threshold = 30 (* [try_other_exit_every_n] There is two strategies that push/pop can take to fix state ( to be able to return without completion). Generally, we want to try to do "rollback" more than "push forward", as the latter adds contention to the side that might already not be keeping up. *) let try_other_exit_every_n = 10 let time_to_try_push_forward n = n mod try_other_exit_every_n == 0 let push { array; tail; head; mask; _ } item = let tail_val = Atomic.fetch_and_add tail 1 in let index = tail_val land mask in let cell = Array.get array index in (* spin for a bit *) let i = ref 0 in while !i < spin_threshold && not (Atomic.compare_and_set cell None (Some item)) do i := !i + 1 done; (* define clean up function *) let rec take_or_rollback nth_attempt = if Atomic.compare_and_set cell None (Some item) then (* succedded to push *) true else if ccas tail (tail_val + 1) tail_val then (* rolled back tail *) false else if time_to_try_push_forward nth_attempt && ccas head tail_val (tail_val + 1) then (* pushed forward head *) false else begin Domain.cpu_relax (); (* retry *) take_or_rollback (nth_attempt + 1) end in (* if succeeded return true otherwise clean up *) if !i < spin_threshold then true else take_or_rollback 0 let take_item cell = let value = Atomic.get cell in if Option.is_some value && Atomic.compare_and_set cell value None then value else None let pop queue = let ({ array; head; tail; mask; _ } : 'a t) = queue in let head_value = Atomic.get head in let tail_value = Atomic.get tail in if head_value - tail_value >= 0 then None else let old_head = Atomic.fetch_and_add head 1 in let cell = Array.get array (old_head land mask) in (* spin for a bit *) let i = ref 0 in let item = ref None in while !i < spin_threshold && not (Option.is_some !item) do item := take_item cell; i := !i + 1 done; (* define clean up function *) let rec take_or_rollback nth_attempt = let value = Atomic.get cell in if Option.is_some value && Atomic.compare_and_set cell value None then (* dequeued an item, return it *) value else if ccas head (old_head + 1) old_head then (* rolled back head *) None else if time_to_try_push_forward nth_attempt && ccas tail old_head (old_head + 1) then (* pushed tail forward *) None else begin Domain.cpu_relax (); take_or_rollback (nth_attempt + 1) end in (* return if got item, clean up otherwise *) if Option.is_some !item then !item else take_or_rollback 0 module CAS_interface = struct let rec push ({ array; tail; head; mask; _ } as t) item = let tail_val = Atomic.get tail in let head_val = Atomic.get head in let size = mask + 1 in if tail_val - head_val >= size then false else if ccas tail tail_val (tail_val + 1) then begin let index = tail_val land mask in let cell = Array.get array index in (* Given that code above checks for overlap, is this CAS needed? Yes. Even though a thread cannot explicitely enter overlap, it can still occur just because enqueuer may theoretically be unscheduled for unbounded amount of time between incrementing index and filling the slot. I doubt we'd observe that case in real-life (outside some extreme circumstances), but this optimization has to be left for the user to decide. After all, algorithm would not pass model-checking without it. Incidentally, it also makes this method interoperable with standard interface. *) while not (Atomic.compare_and_set cell None (Some item)) do Domain.cpu_relax () done; true end else push t item let rec pop ({ array; tail; head; mask; _ } as t) = let tail_val = Atomic.get tail in let head_val = Atomic.get head in if head_val - tail_val >= 0 then None else if ccas head head_val (head_val + 1) then begin let index = head_val land mask in let cell = Array.get array index in let item = ref (Atomic.get cell) in while not (Option.is_some !item && Atomic.compare_and_set cell !item None) do Domain.cpu_relax (); item := Atomic.get cell done; !item end else pop t end end saturn-0.5.0/src/saturn.ml0000644000175000017500000000350514661627530014174 0ustar kylekyle(*--------------------------------------------------------------------------- Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved. Distributed under the ISC license, see terms at the end of the file. saturn 0.5.0 ---------------------------------------------------------------------------*) (*--------------------------------------------------------------------------- Copyright (c) 2016 KC Sivaramakrishnan Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ---------------------------------------------------------------------------*) (* ######## Copyright (c) 2017, Nicolas ASSOUAD ######## *) module Queue = Saturn_lockfree.Queue module Queue_unsafe = Saturn_lockfree.Queue_unsafe module Stack = Saturn_lockfree.Stack module Work_stealing_deque = Saturn_lockfree.Work_stealing_deque module Single_prod_single_cons_queue = Saturn_lockfree.Single_prod_single_cons_queue module Single_prod_single_cons_queue_unsafe = Saturn_lockfree.Single_prod_single_cons_queue_unsafe module Single_consumer_queue = Saturn_lockfree.Single_consumer_queue module Relaxed_queue = Mpmc_relaxed_queue module Skiplist = Saturn_lockfree.Skiplist saturn-0.5.0/src/domain.ocaml4.ml0000644000175000017500000000003514661627530015300 0ustar kylekylelet cpu_relax = Thread.yield saturn-0.5.0/src/mpmc_relaxed_queue.mli0000644000175000017500000000524714661627530016702 0ustar kylekyle(** A multi-producer, multi-consumer, thread-safe, bounded relaxed-FIFO queue. It exposes two interfaces: [Spin] and [Not_lockfree]. [Spin] is lock-free formally, but the property is achieved in a fairly counterintuitive way - - by using the fact that lock-freedom does not impose any constraints on partial methods. In simple words, an invocation of function that cannot logically terminate (`push` on full queue, `pop` on empty queue), it is allowed to *busy-wait* until the precondition is meet. Above interface is impractical outside specialized applications. Thus, [Mpmc_relaxed_queue] also exposes [Not_lockfree] interface. [Not_lockfree] contains non-lockfree paths. While formally a locked algorithm, it will often be the more practical solution as it allows having an overflow queue, etc. *) type 'a t = private { array : 'a Option.t Atomic.t Array.t; head : int Atomic.t; tail : int Atomic.t; mask : int; } (** A queue of items of type ['a]. Implementation exposed for testing. *) val create : size_exponent:int -> unit -> 'a t (** [create ~size_exponent:int] creates an empty queue of size [2^size_exponent]. *) module Spin : sig (** [Spin] exposes a formally lock-free interface as per the [A lock-free relaxed concurrent queue for fast work distribution] paper. Functions here busy-wait if the action cannot be completed (i.e. [push] on full queue, [pop] on empty queue). *) val push : 'a t -> 'a -> unit (** [push t x] adds [x] to the tail of the queue. If the queue is full, [push] busy-waits until another thread removes an item. *) val pop : 'a t -> 'a (** [pop t] removes an item from the head of the queue. If the queue is empty, [pop] busy-waits until an item appear. *) end module Not_lockfree : sig (** [Non_lockfree] exposes an interface that contains non-lockfree paths, i.e. threads may need to cooperate to terminate. It is often more practical than [Spin], in particular when using a fair OS scheduler. *) val push : 'a t -> 'a -> bool (** [push t x] adds [x] to the tail of the queue. Returns [false] if [t] is currently full. *) val pop : 'a t -> 'a option (** [pop t] removes the head item from [t] and returns it. Returns [None] if [t] is currently empty. *) module CAS_interface : sig (** Alternative interface, which may perform better on architectures without FAD instructions (e.g. AArch). CAS_interface should not be the default choice. It may be a little faster on ARM, but it is going to be a few times slower than standard on x86. *) val push : 'a t -> 'a -> bool val pop : 'a t -> 'a option end end saturn-0.5.0/src/saturn.mli0000644000175000017500000000363114661627530014345 0ustar kylekyle(*--------------------------------------------------------------------------- Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved. Distributed under the ISC license, see terms at the end of the file. saturn 0.5.0 ---------------------------------------------------------------------------*) (*--------------------------------------------------------------------------- Copyright (c) 2016 KC Sivaramakrishnan Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ---------------------------------------------------------------------------*) (* ######## Copyright (c) 2017, Nicolas ASSOUAD ######## *) (** Domain-safe data structures for Multicore OCaml *) (** {1 Data structures} *) module Queue = Saturn_lockfree.Queue module Queue_unsafe = Saturn_lockfree.Queue_unsafe module Stack = Saturn_lockfree.Stack module Work_stealing_deque = Saturn_lockfree.Work_stealing_deque module Single_prod_single_cons_queue = Saturn_lockfree.Single_prod_single_cons_queue module Single_prod_single_cons_queue_unsafe = Saturn_lockfree.Single_prod_single_cons_queue_unsafe module Single_consumer_queue = Saturn_lockfree.Single_consumer_queue module Relaxed_queue = Mpmc_relaxed_queue module Skiplist = Saturn_lockfree.Skiplist saturn-0.5.0/src/dune0000644000175000017500000000056714661627530013211 0ustar kylekyle(* -*- tuareg -*- *) let maybe_threads = if Jbuild_plugin.V1.ocaml_version < "5" then "threads.posix" else "" let () = Jbuild_plugin.V1.send @@ {| (library (name saturn) (public_name saturn) (libraries (re_export saturn_lockfree) |} ^ maybe_threads ^ {| )) (rule (enabled_if (< %{ocaml_version} 5.0.0)) (action (copy domain.ocaml4.ml domain.ml))) |} saturn-0.5.0/bench.Dockerfile0000644000175000017500000000057014661627530014606 0ustar kylekyleFROM ocaml/opam:debian-ocaml-5.2 RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam WORKDIR bench-dir RUN sudo chown opam . COPY *.opam ./ RUN opam remote add origin https://github.com/ocaml/opam-repository.git && \ opam update RUN opam pin -yn --with-version=dev . RUN opam install -y --deps-only --with-test . COPY . ./ RUN opam exec -- dune build --release bench/main.exe saturn-0.5.0/README.md0000644000175000017500000005713114661627530013022 0ustar kylekyle[API Reference](https://ocaml-multicore.github.io/saturn/) · [Benchmarks](https://bench.ci.dev/ocaml-multicore/saturn/branch/main?worker=pascal&image=bench.Dockerfile) · [Stdlib Benchmarks](https://bench.ci.dev/ocaml-multicore/multicore-bench/branch/main?worker=pascal&image=bench.Dockerfile) # Saturn — Parallelism-Safe Data Structures for Multicore OCaml This repository is a collection of parallelism-safe data structures for OCaml 5. They are contained in two packages: - **Saturn** that includes all data structures (including the lock-free ones) and should be used by default if you just want parallelism-safe data structures; - **Saturn_lockfree** that includes only lock-free data structures. It aims to provide an industrial-strength, well-tested (and possibly model-checked and verified in the future), well documented, and maintained parallelism-safe data structure library. We want to make it easier for Multicore OCaml users to find the right data structures for their uses. **Saturn** is published on [opam](https://opam.ocaml.org/packages/saturn/) and is distributed under the [ISC license](https://github.com/ocaml-multicore/saturn/blob/main/LICENSE.md). [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Fci.ocamllabs.io%2Fbadge%2Focaml-multicore%2Fsaturn%2Fmain&logo=ocaml&style=flat-square)](https://ci.ocamllabs.io/github/ocaml-multicore/saturn) [![GitHub release (latest by date)](https://img.shields.io/github/v/release/ocaml-multicore/saturn?style=flat-square&color=09aa89)](https://github.com/ocaml-multicore/saturn/releases/latest) [![docs](https://img.shields.io/badge/doc-online-blue.svg?style=flat-square)](https://ocaml-multicore.github.io/saturn/) # Contents - [Saturn — Parallelism-Safe Data Structures for Multicore OCaml](#saturn--parallelism-safe-data-structures-for-multicore-ocaml) - [Contents](#contents) - [Installation](#installation) - [Getting OCaml 5.0](#getting-ocaml-50) - [Getting Saturn](#getting-saturn) - [Introduction](#introduction) - [Provided data structures](#provided-data-structures) - [Motivation](#motivation) - [A note about races in OCaml](#a-note-about-races-in-ocaml) - [Safe and unsafe data structures](#safe-and-unsafe-data-structures) - [Usage](#usage) - [Data Structures With Domain Roles](#data-structures-with-domain-roles) - [About Composability](#about-composability) - [Extending Data Structures](#extending-data-structures) - [Composable Parallelism-Safe Data Structures](#composable-parallelism-safe-data-structures) - [Testing](#testing) - [Benchmarks](#benchmarks) - [Contributing](#contributing) # Installation ## Getting OCaml 5.0 You'll need OCaml 5.0.0 or later. Note that Saturn also works with OCaml 4.14 but only for compatibility reasons, as there is no need for parallelism-safe data structures without OCaml 5.0. To install OCaml 5.0 yourself, first make sure you have opam 2.1 or later. You can run this command to check: ```sh opam --version ``` Then use opam to install OCaml 5.0.0: ```sh opam switch create 5.0.0 ``` If you want a later version, you can run the following line to get a list of all available compiler versions: ```sh opam switch list-available ``` ## Getting Saturn `saturn` can be installed from `opam`: ```sh opam install saturn ``` or ```sh opam install saturn_lockfree ``` if you prefer to use only lock-free data structures. # Introduction ## Provided data structures | Name | Module in `Saturn`
(in `Saturn_lockfree`) | Description | Sources | | ------------------------------- | ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ | | Treiber Stack | [`Stack`](https://ocaml-multicore.github.io/saturn/saturn_lockfree/Lockfree/Stack/index.html) (same) | A classic multi-producer multi-consumer stack, robust and flexible. Recommended starting point when needing a LIFO structure | | | Michael-Scott Queue | [`Queue`](https://ocaml-multicore.github.io/saturn/saturn_lockfree/Lockfree/Queue/index.html) (same) | A classic multi-producer multi-consumer queue, robust and flexible. Recommended starting point when needing a FIFO structure. | [Simple, Fast, and Practical Non-Blocking and Blocking Concurrent Queue Algorithms](https://www.cs.rochester.edu/~scott/papers/1996_PODC_queues.pdf) | | Chase-Lev Work-Stealing Dequeue | [`Work_stealing_deque`](https://ocaml-multicore.github.io/saturn/saturn_lockfree/Lockfree/Work_stealing_deque/index.html) (same) | Single-producer, multi-consumer, dynamic-size, double-ended queue (deque). Ideal for throughput-focused scheduling using per-core work distribution. Note, `pop` and `steal` follow different ordering (respectively LIFO and FIFO) and have different linearisation contraints. | [Dynamic Circular Work-Stealing Deque](https://dl.acm.org/doi/10.1145/1073970.1073974) and [Correct and Efficient Work-Stealing for Weak Memory Models](https://dl.acm.org/doi/abs/10.1145/2442516.2442524)) | | SPSC Queue | [`Single_prod_single_`
`cons_queue`](https://ocaml-multicore.github.io/saturn/saturn_lockfree/Lockfree/Single_prod_single_cons_queue/index.html) (same) | Simple single-producer single-consumer fixed-size queue. Thread-safe as long as at most one thread acts as producer and at most one as consumer at any single point in time. | | | MPMC Bounded Relaxed Queue | [`Relaxed_queue`](https://ocaml-multicore.github.io/saturn/saturn/Saturn/Relaxed_queue/index.html) ([same](https://ocaml-multicore.github.io/saturn/saturn_lockfree/Lockfree/Relaxed_queue/index.html)) | Multi-producer, multi-consumer, fixed-size relaxed queue. Optimised for high number of threads. Not strictly FIFO. Note, it exposes two interfaces: a lockfree and a non-lockfree (albeit more practical) one. See the `mli` for details. | | | MPSC Queue | [`Single_consumer_queue`](https://ocaml-multicore.github.io/saturn/saturn_lockfree/Lockfree/Single_consumer_queue/index.html) (same) | A multi-producer, single-consumer, thread-safe queue without support for cancellation. This makes a good data structure for a scheduler's run queue. It is used in [Eio](https://github.com/ocaml-multicore/eio). | It is a single consumer version of the queue described in [Implementing Lock-Free Queues](https://people.cs.pitt.edu/~jacklange/teaching/cs2510-f12/papers/implementing_lock_free.pdf). | ## Motivation The following part is a beginner-friendly example to explain why we need data structures specifically designed for multicore programming. Let's write a classic mutable data structure : a queue. We are going to do a basic implementation the way it may be done for sequential use and show why it is not working well with multiple domains. ```ocaml type queue = int list ref let create () : queue = ref [] let push q a = q := a :: !q ``` What happens if we try to use this queue with multiple domains? First, let's define the work we want a single domain to do: each domain will push 10 times its `id` in the queue. ```ocaml let work id q = for i = 0 to 9 do push q id done ``` Then let's define our test : it spawns 2 domains that each execute `work` in parallel. `test` returns the content of the queue as well as its length, so we can easily see if it contains the 20 elements we expect. ```ocaml let test () = let q = create () in let domainA = Domain.spawn (fun () -> work 1 q) in let domainB = Domain.spawn (fun () -> work 2 q) in Domain.join domainA; Domain.join domainB; (List.length !q, !q) ``` Let's try it : ```ocaml # test () - : int * int list = (20, [2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1]) ``` Everything seems fine, right? Except, it is not running in parallel, as we can see from the consecutive `2` (pushed by `domainB`) and `1` pushed by `domainA`. This is because spawning a domain takes way more time than executing `work`, so `domainA` is long finished before `domainB` is even spawned. One way to overpass this issue is to increase the amount of work done in `work` (for example, by pushing more elements). Another way is to make sure the domains wait for each other before beginning their workload. We use a basic [barrier implementation](https://github.com/ocaml-multicore/saturn/blob/main/test/barrier/barrier.mli) to do that. Each domain will now wait for the other to reach the barrier before beginning to push. ```ocaml let work_par id barrier q = Barrier.await barrier; for i = 0 to 9 do push q id done ``` The `test` function is now: ```ocaml let test_par () = let barrier = Barrier.create 2 in let q = create () in let domainA = Domain.spawn (fun () -> work_par 1 barrier q) in let domainB = Domain.spawn (fun () -> work_par 2 barrier q) in Domain.join domainA; Domain.join domainB; (List.length !q, !q) ``` Let's run it: ```ocaml # test_par ();; - : int * int list = (18, [2; 1; 2; 1; 2; 1; 2; 1; 2; 1; 2; 2; 1; 1; 1; 1; 2; 1]) ``` Now, the `1` and the `2` are interleaved: domains are running in parallel. The resulting queue however only contains `18` elements whereas `20` were pushed. This is because we not only have a [race condition](https://en.wikipedia.org/wiki/Race_condition) here but also because `push` is a non-atomic operation. It requires first to read the content of the queue (`!q`) then to write in it (`q := ...`). So, for example, when two domains try to push in parallel into an empty queue the following sequence can happen: - domain A reads the queue : it is empty - domain B reads the queue : it is still empty - domain A pushes `1` on the empty queue it has read before - domain B pushes `2` on the empty queue it has read before. This sequence results in a queue containing only one element of value `2`. The element pushed by A is lost because B did not see it. This is a very common issue in parallel programming. To prevent it, functions need to be atomically consistent (aka linearisable), meaning they must have a linearisation point at which they appear to occur instantly. Such functions can be written with different techniques, including: - use of [`Atomic`](https://v2.ocaml.org/api/Atomic.html) for mutable variables, - use of a mutual exclusion mechanism like [`Mutex`](https://v2.ocaml.org/api/Mutex.html). However both solutions have their limits. Using mutexes or locks open the way to deadlock, livelock, priority inversion, etc; it also often restrics considerably the performance gained by using multiple cores as the parts of the code effectively running in parallel is limited. On the other hand, atomics are - without a complex algorithm to combine them - only a solution for a single shared variable. Let's try to replace references by atomics in our code to demonstrate this point: ```ocaml type queue = int list Atomic.t let create () : queue = Atomic.make [] let push (q : queue) a = let curr = Atomic.get q in let prev = a :: curr in Atomic.set q prev ``` We still need to read and write to fulfill the whole push operation. ```ocaml # test ();; - : int * int list = (15, [1; 1; 1; 1; 1; 2; 1; 1; 1; 2; 2; 2; 2; 1; 2]) ``` and, as expected it is not working. The interleaving scenario described previously can still happen, meaning our function is not linearisable (or atomically consistent). Note that, though it is not observable here, this is still better than the previous implementation, as we are now race-free (see [here](#a-note-about-races-in-ocaml) for a quick note about races in OCaml). As a matter of fact, writting a queue with `push` and `pop` functions that are both atomic and parallelism-safe is not as easy as it might sound and often requires advanced techniques to perform well. This is the type of algorithms Saturn_lockfree provided. To continue with our example, here is how it will be written using the queue provided in Saturn. ```ocaml let work_saturn id barrier q () = Barrier.await barrier; for i = 0 to 9 do Saturn.Queue.push q id done let test_saturn () = let barrier = Barrier.create 2 in let q = Saturn.Queue.create () in let d1 = Domain.spawn (work_saturn 1 barrier q) in let d2 = Domain.spawn (work_saturn 2 barrier q) in Domain.join d1; Domain.join d2; let rec pop_all acc = match Saturn.Queue.pop q with | None -> List.rev acc | Some elt -> pop_all (elt :: acc) in let res = pop_all [] in (List.length res, res) ``` Running it results in the expected result: ```ocaml # test_saturn ();; - : int * int list = (20, [2; 2; 1; 2; 2; 2; 2; 2; 2; 1; 2; 1; 2; 1; 1; 1; 1; 1; 1; 1]) ``` ### A note about races in OCaml Because of the great properties of OCaml 5 memory model (see the [OCaml Manual](https://v2.ocaml.org/manual/parallelism.html#s%3Apar_mm_easy) for more details), not a lot can go wrong here. At least, data corruption or segmentation fault won't happen like it can in other languages. ## Safe and unsafe data structures Some data structures are available in two versions: a normal version and a more optimized but **unsafe** version. The **unsafe** version utilizes `Obj.magic` in a way that may be unsafe with `flambda2` optimizations. The reason for providing the unsafe version is that certain optimizations require features that are currently not available in OCaml, such as arrays of atomics or atomic fields in records. We recommend using the normal version of a data structure unless its performance is not sufficient for your use case. In that case, you can try the unsafe version. Currently, there are two data structures with an unsafe version: - `Single_cons_single_prod_unsafe`: a single consumer single producer queue - `Queue_unsafe`: a Michael Scott queue # Usage This part describes how to use the provided data structures, and more exactly, what not to do with them. Two main points are discussed: - some data structures have restrictions on what operations can be performed in a single domain or a set of domains - the currently provided data structures are non-composable ## Data Structures With Domain Roles There are several provided data structures that are intended to be used in combination with a specific domain configuration. These restrictions make the corresponding implementation optimized but not respected them may break safety properties. Obviously, these restrictions are not only described in the documentation but also on the name of the data structure itself. For example, a single consumer queue can only have a single domain popping at any given time. Let's take the example of `Single_prod_single_cons_queue`. As suggested by the name, it should be used with only one domain performing `push` (a producer) and one domain performing `pop` (a consumer) at the same time. Having two or more domains simultaneously perform `pop` (or `push`) will break the safety properties of the `queue` and more likely result in unexpected behaviors. Let's say we give a bad alias to this queue and misuse it. ```ocaml module Queue = Saturn.Single_prod_single_cons_queue ``` Each domain is going to try to push 10 times in parallel. ```ocaml let work id barrier q = Barrier.await barrier; for i = 0 to 9 do Queue.push q id done ``` Our `test` function returns the queue after two domains try to simustaneously push. ```ocaml let test () = let q = Queue.create ~size_exponent:5 in let barrier = Barrier.create 2 in let d1 = Domain.spawn (fun () -> work 1 barrier q) in let d2 = Domain.spawn (fun () -> work 2 barrier q) in Domain.join d1; Domain.join d2; q ``` We can then inspect the content of the queue by popping it into a list. ```ocaml let get_content q = let rec loop acc = match Queue.pop q with | None -> acc | Some a -> loop (a :: acc) in loop [] |> List.rev ``` Let's run it : ```ocaml test () |> get_content;; - : int list = [2; 1; 1; 1; 1; 1; 1; 1; 1; 1; 2] ``` This run results in a queue with only 11 elements. 9 elements are lost because of the misuse of the single consumer single producer queue. ## About Composability Composability is the ability to compose functions while preserving their properties. For Saturn data structures, the properties one could expect to preserve are atomic consistency (or linearizability) and all eventual progress properties, like lock freedom. Unfortunately, Saturn's data structures are not composable. Let's illustrate that with an example. We want to write a slitting algorithm on Saturn's queue: several domains simultaneously slit a source queue into two destination queues in respect to a predicate. We expect our splitting function to be linearisable, which would manifest here by the source queue order is preserved in the destination queues. For example, `slit [0;1;2;3;4]`, with a predicate that returns `true` for even numbers and `false` otherwise, should returns `[0';2;4]` and `[1;3]`. Here is how we can write `slit` with the functions provided by Saturn's queue. ```ocaml let slit source pred true_dest false_dest : bool = match Queue.pop source with | None -> false | Some elt -> if pred elt then Queue.push true_dest elt else Queue.push false_dest elt; true ``` Domains run `split` until the source queue is empty: ```ocaml let work source pred true_dest false_dest = while split source pred true_dest false_dest do () done ``` Now to test it, we will run: ```ocaml let test input = (* Initialisation *) let true_dest = Queue.create () in let false_dest = Queue.create () in let source = Queue.create () in List.iter (Queue.push source) input; let barrier = Barrier.create 2 in (* Predicate : split by parity *) let pred elt = elt mod 2 = 0 in let d1 = Domain.spawn (fun () -> Barrier.await barrier; work source pred true_dest false_dest) in let d2 = Domain.spawn (fun () -> Barrier.await barrier; work source pred true_dest false_dest) in Domain.join d1; Domain.join d2; (get_content true_dest, get_content false_dest) ``` The expected result for `test [0; 1; 2; 3; 4]` is `([0; 2; 4], [1; 3])`. And if you try it, you will most probably get that result. Except it can also return in unsorted queues. As the chance of getting an unsorted queue, we write a `check` function that runs `test` multiple times and counts the number of times the result is not what we wanted. ```ocaml let check inputs max_round = let expected_even = List.filter (fun elt -> elt mod 2 = 0) inputs in let expected_odd = List.filter (fun elt -> elt mod 2 = 1) inputs in let rec loop round bugged = let even, odd = test inputs in if round >= max_round then bugged else if even <> expected_even || odd <> expected_odd then loop (round + 1) (bugged + 1) else loop (round + 1) bugged in Format.printf "%d/%d rounds are bugged.@." (loop 0 0) max_round ``` and try it: ```ocaml # check [0;1;2;3;4;5;6] 1000;; 35/1000 rounds are bugged. ``` As expected, it is not working, and the reason is simply because our `split` function is not linerisable. We could make it atomic by using mutex, but then we loose the progress properties of the composed functions. #### Extending Data Structures Note that in the case above, we transfer from and to a queue of the same `int Saturn.Queue.t` type. It is most likely possible to write a `val transfer : t -> t -> unit` function with the right properties and add it directly to `Saturn.Queue` module. If you think of any such functions, that is useful and missing, let's us know by creating an issue! #### Composable Parallelism-Safe Data Structures If you need composable parallelism-safe data structures, you can check [kcas_data](https://github.com/ocaml-multicore/kcas#programming-with-transactional-data-structures). # Testing One of the many difficulties of implementating parallelism-safe data structures is that in addition to providing the same safety properties as sequental ones, they may also have to observe some [liveness properties](https://en.wikipedia.org/wiki/Safety_and_liveness_properties) as well as additional safety properties specific to concurrent programming, like deadlock-freedom. In addition to the expected safety properties, the main properties we want to test for are: - linearisability - lock-freedom for all the lock-free data structures - no potentially harmful data races Here is a list of the tools we use to ensure them: - _safety_ : unitary tests and `qcheck` tests check semantics and expected behaviors with one and more domains. - _safety and liveness_ : `STM` tests check _linearisability_ for two domains (see [`multicoretests` library](https://github.com/ocaml-multicore/multicoretests)). - _liveness_ : `dscheck` checks _non-blocking_ property for as many domains as wanted (for two domains most of the time). See [dscheck](https://github.com/ocaml-multicore/dscheck). - _safety_ : no data race with [tsan](https://github.com/ocaml-multicore/ocaml-tsan) See [test/README.md](test/README.md) for more details. # Benchmarks There are a number of benchmarks in `bench` directory. You can run them with `make bench`. See [bench/README.md](bench/README.md) for more details. ## Contributing Contributions are appreciated! If you intend to add a new data structure, please read [this](CONTRIBUTING.md) before. saturn-0.5.0/dune-project0000644000175000017500000000336114661627530014061 0ustar kylekyle(lang dune 3.14) (name saturn) (version 0.5.0) (generate_opam_files true) (implicit_transitive_deps false) (source (github ocaml-multicore/saturn)) (license ISC) (authors "KC Sivaramakrishnan") (maintainers "Carine Morel" "KC Sivaramakrishnan" "Sudha Parimala") (documentation "https://ocaml-multicore.github.io/saturn/") (package (name saturn) (synopsis "Collection of parallelism-safe data structures for Multicore OCaml") (depends (ocaml (>= 4.13)) (domain_shims (and (>= 0.1.0) :with-test)) (saturn_lockfree (= :version)) (multicore-magic (and (>= 2.3.0) :with-test)) (multicore-bench (and (>= 0.1.2) :with-test)) (multicore-magic-dscheck (and (>= 2.3.0) :with-test)) (backoff (and (>= 0.1.0) :with-test)) (alcotest (and (>= 1.7.0) :with-test)) (qcheck (and (>= 0.21.3) :with-test)) (qcheck-stm (and (>= 0.3) :with-test)) (qcheck-alcotest (and (>= 0.21.3) :with-test)) (yojson (and (>= 2.0.2) :with-test)) (dscheck (and (>= 0.5.0) :with-test)) (sherlodoc (and (>= 0.2) :with-doc)) (odoc (and (>= 2.4.1) :with-doc)))) (package (name saturn_lockfree) (synopsis "Collection of lock-free data structures for Multicore OCaml") (depends (ocaml (>= 4.13)) (domain_shims (and (>= 0.1.0) :with-test)) (backoff (>= 0.1.0)) (multicore-magic (>= 2.3.0)) (multicore-magic-dscheck (and (>= 2.3.0) :with-test)) (alcotest (and (>= 1.7.0) :with-test)) (qcheck (and (>= 0.21.3) :with-test)) (qcheck-core (and (>= 0.21.3) :with-test)) (qcheck-stm (and (>= 0.3) :with-test)) (qcheck-multicoretests-util (and (>= 0.3) :with-test)) (qcheck-alcotest (and (>= 0.21.3) :with-test)) (yojson (and (>= 2.0.2) :with-test)) (dscheck (and (>= 0.5.0) :with-test)) (sherlodoc (and (>= 0.2) :with-doc)) (odoc (and (>= 2.4.1) :with-doc)))) saturn-0.5.0/CONTRIBUTING.md0000644000175000017500000000230714661627530013767 0ustar kylekyle## Contributing Any contributions are appreciated! Please create issues/PRs to this repo. ### Maintainers The current list of maintainers is as follows: - @kayceesrk KC Sivaramakrishnan - @lyrm Carine Morel - @Sudha247 Sudha Parimala ### Guidelines for new data structures implementation Reviewing most implementation takes times. Here are a few guidelines to make it easier for the reviewers : - the issue tracker has a good list of data structures to choose from - implement a well know algorithm (there are a lot !) - from a _reviewed_ paper, ideally with proof of main claimed properties (like lock-freedom, deadlock freedom etc..) - from a well known and used concurrent library (like `java.util.concurrent`) - write tests with **multiple** domains. All the following tests are expected to be provided before a proper review is done, especially for implementations that do not come from a well-know algorithm : - unitary tests and `qcheck tests` : with one and multiple domains. If domains have specific roles (producer, consumer, stealer, etc..), it should appear in the tests. - tests using `STM` from `multicoretest` - (_optional_) `dscheck` tests (for non-blocking implementation) saturn-0.5.0/.ocamlformat0000644000175000017500000000007214661627530014040 0ustar kylekyleprofile = default version = 0.26.2 exp-grouping=preserve saturn-0.5.0/bench/0000755000175000017500000000000014702247137012610 5ustar kylekylesaturn-0.5.0/bench/README.md0000644000175000017500000000042714661627530014075 0ustar kylekyleBenchmarks for Saturn # General usage Execute `make bench` from root of the repository to run the standard set of benchmarks. The output is in JSON, as it is intended to be consumed by [current-bench](https://bench.ci.dev/ocaml-multicore/saturn/branch/main/benchmark/default). saturn-0.5.0/bench/bench_ws_deque.ml0000644000175000017500000001102214661627530016114 0ustar kylekyleopen Multicore_bench module Ws_deque = Saturn_lockfree.Work_stealing_deque.M let run_as_scheduler ~budgetf ?(n_domains = 1) () = let spawns = Array.init n_domains @@ fun _ -> ref 0 |> Multicore_magic.copy_as_padded in let deques = Array.init n_domains @@ fun _ -> Ws_deque.create () in let exit = ref false |> Multicore_magic.copy_as_padded in let next i = let i = i + 1 in if i = n_domains then 0 else i in let rec try_own own = match Ws_deque.pop (Array.unsafe_get deques own) with | work -> work | exception Exit -> try_steal own (next own) and try_steal own other = if other = own then raise_notrace Exit else match Ws_deque.steal (Array.unsafe_get deques other) with | work -> work | exception Exit -> try_steal own (next other) in let rec run own = match try_own own with | work -> work own; run own | exception Exit -> if not !exit then begin Domain.cpu_relax (); run own end in let spawn own work = incr (Array.unsafe_get spawns own); let promise = ref (Obj.magic exit) in Ws_deque.push (Array.unsafe_get deques own) (fun own -> promise := work own); promise in let rec await own promise = let x = !promise in if x == Obj.magic exit then begin begin match try_own own with | exception Exit -> Domain.cpu_relax () | work -> work own end; await own promise end else x in let rec fib n worker = if n < 2 then n else let n2 = spawn worker (fib (n - 2)) in let n1 = fib (n - 1) worker in await worker n2 + n1 in let rec bits n = if n <= 1 then 0 else 1 + bits (n lsr 1) in let init own = Array.unsafe_get spawns own := 0; if own = 0 then begin exit := false; let n = 27 + bits n_domains in spawn own (fun own -> fib n own |> ignore; exit := true) |> ignore end in let work own () = run own in let config = Printf.sprintf "%d worker%s" n_domains (if n_domains = 1 then "" else "s") in let times = Times.record ~budgetf ~n_domains ~init ~work () in let n = Array.fold_left (fun n c -> n + !c) 0 spawns in Times.to_thruput_metrics ~n ~singular:"spawn" ~config times let run_as_one_domain ~budgetf ?(n_msgs = 150 * Util.iter_factor) order = let t = Ws_deque.create () in let op_lifo push = if push then Ws_deque.push t 101 else match Ws_deque.pop t with _ -> () | exception Exit -> () and op_fifo push = if push then Ws_deque.push t 101 else match Ws_deque.steal t with _ -> () | exception Exit -> () in let init _ = assert (match Ws_deque.steal t with _ -> false | exception Exit -> true); Util.generate_push_and_pop_sequence n_msgs in let work _ bits = Util.Bits.iter (match order with `FIFO -> op_fifo | `LIFO -> op_lifo) bits in let config = let label = match order with `FIFO -> "FIFO" | `LIFO -> "LIFO" in Printf.sprintf "one domain (%s)" label in Times.record ~budgetf ~n_domains:1 ~init ~work () |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config let run_as_spmc ~budgetf ~n_thiefs () = let n_domains = n_thiefs + 1 in let n_msgs = 70 * Util.iter_factor in let t = Ws_deque.create () in let n_msgs_to_steal = Atomic.make 0 |> Multicore_magic.copy_as_padded in let init _ = assert (match Ws_deque.steal t with _ -> false | exception Exit -> true); Atomic.set n_msgs_to_steal n_msgs in let work i () = if i < n_thiefs then let rec work () = let n = Util.alloc n_msgs_to_steal in if 0 < n then let rec loop n = if 0 < n then match Ws_deque.steal t with | exception Exit -> Domain.cpu_relax (); loop n | _ -> loop (n - 1) else work () in loop n in work () else for i = 1 to n_msgs do Ws_deque.push t i done in let config = Printf.sprintf "1 adder, %d taker%s" n_thiefs (if n_thiefs = 1 then "" else "s") in Times.record ~budgetf ~n_domains ~init ~work () |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config let run_suite ~budgetf = List.concat [ [ 1; 2; 4; 8 ] |> List.concat_map (fun n_domains -> run_as_scheduler ~budgetf ~n_domains ()); [ 1; 2; 4 ] |> List.concat_map (fun n_thiefs -> run_as_spmc ~budgetf ~n_thiefs ()); run_as_one_domain ~budgetf `FIFO; run_as_one_domain ~budgetf `LIFO; ] saturn-0.5.0/bench/bench_size.ml0000644000175000017500000000205214661627530015255 0ustar kylekyleopen Multicore_bench module Size = Saturn_lockfree.Size let run_one ~budgetf ~n_domains ?(n_ops = 250 * n_domains * Util.iter_factor) () = let t = Size.create () in let n_ops_todo = Atomic.make 0 |> Multicore_magic.copy_as_padded in let init _ = Atomic.set n_ops_todo n_ops in let work _ () = let rec work () = let n = Util.alloc n_ops_todo in if n <> 0 then let rec loop n = if 0 < n then begin let incr = Size.new_once t Size.incr in Size.update_once t incr; let decr = Size.new_once t Size.decr in Size.update_once t decr; loop (n - 2) end else work () in loop n in work () in let config = Printf.sprintf "%d worker%s" n_domains (if n_domains = 1 then "" else "s") in Times.record ~budgetf ~n_domains ~init ~work () |> Times.to_thruput_metrics ~n:n_ops ~config ~singular:"operation" let run_suite ~budgetf = [ 1; 2; 4 ] |> List.concat_map @@ fun n_domains -> run_one ~n_domains ~budgetf () saturn-0.5.0/bench/bench_spsc_queue.ml0000644000175000017500000000513014661627530016457 0ustar kylekyleopen Multicore_bench let run_one ~unsafe ~budgetf ?(size_exponent = 3) ?(n_msgs = 80 * Util.iter_factor) () = let init _ = () in let work, before = if unsafe then let module Queue = Saturn_lockfree.Single_prod_single_cons_queue_unsafe in let t = Queue.create ~size_exponent in let before () = while Queue.size t <> 0 do Queue.pop_exn t |> ignore done; let n = Random.int ((1 lsl size_exponent) + 1) in for i = 1 to n do Queue.push_exn t i done in let work i () = if i = 0 then let rec loop n = if 0 < n then if Queue.try_push t n then loop (n - 1) else begin Domain.cpu_relax (); loop n end in loop n_msgs else let rec loop n = if 0 < n then match Queue.pop_opt t with | Some _ -> loop (n - 1) | None -> Domain.cpu_relax (); loop n in loop n_msgs in (work, before) else let module Queue = Saturn_lockfree.Single_prod_single_cons_queue in let t = Queue.create ~size_exponent in let before () = while Queue.size t <> 0 do Queue.pop_exn t |> ignore done; let n = Random.int ((1 lsl size_exponent) + 1) in for i = 1 to n do Queue.push_exn t i done in let work i () = if i = 0 then let rec loop n = if 0 < n then if Queue.try_push t n then loop (n - 1) else begin Domain.cpu_relax (); loop n end in loop n_msgs else let rec loop n = if 0 < n then match Queue.pop_opt t with | Some _ -> loop (n - 1) | None -> Domain.cpu_relax (); loop n in loop n_msgs in (work, before) in let config = Printf.sprintf "2 workers, capacity %d%s" (1 lsl size_exponent) (if unsafe then " (unsafe)" else "") in Times.record ~budgetf ~n_domains:2 ~before ~init ~work () |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config let run_suite ~budgetf = let run ~unsafe = [ 0; 3; 6; 9; 12; 15 ] |> List.concat_map @@ fun size_exponent -> run_one ~budgetf ~size_exponent ~unsafe () in List.fold_right2 (fun safe unsafe acc -> safe :: unsafe :: acc) (run ~unsafe:false) (run ~unsafe:true) [] saturn-0.5.0/bench/bench_queue.ml0000644000175000017500000000417514661627530015437 0ustar kylekyleopen Multicore_bench module Queue = Saturn_lockfree.Queue let run_one_domain ~budgetf ?(n_msgs = 50 * Util.iter_factor) () = let t = Queue.create () in let op push = if push then Queue.push t 101 else Queue.pop_opt t |> ignore in let init _ = assert (Queue.is_empty t); Util.generate_push_and_pop_sequence n_msgs in let work _ bits = Util.Bits.iter op bits in Times.record ~budgetf ~n_domains:1 ~init ~work () |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config:"one domain" let run_one ~budgetf ?(n_adders = 2) ?(n_takers = 2) ?(n_msgs = 50 * Util.iter_factor) () = let n_domains = n_adders + n_takers in let t = Queue.create () in let n_msgs_to_take = Atomic.make 0 |> Multicore_magic.copy_as_padded in let n_msgs_to_add = Atomic.make 0 |> Multicore_magic.copy_as_padded in let init _ = assert (Queue.is_empty t); Atomic.set n_msgs_to_take n_msgs; Atomic.set n_msgs_to_add n_msgs in let work i () = if i < n_adders then let rec work () = let n = Util.alloc n_msgs_to_add in if 0 < n then begin for i = 1 to n do Queue.push t i done; work () end in work () else let rec work () = let n = Util.alloc n_msgs_to_take in if n <> 0 then let rec loop n = if 0 < n then begin match Queue.pop_opt t with | None -> Domain.cpu_relax (); loop n | Some _ -> loop (n - 1) end else work () in loop n in work () in let config = let format role n = Printf.sprintf "%d %s%s" n role (if n = 1 then "" else "s") in Printf.sprintf "%s, %s" (format "nb adder" n_adders) (format "nb taker" n_takers) in Times.record ~budgetf ~n_domains ~init ~work () |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config let run_suite ~budgetf = run_one_domain ~budgetf () @ (Util.cross [ 1; 2 ] [ 1; 2 ] |> List.concat_map @@ fun (n_adders, n_takers) -> run_one ~budgetf ~n_adders ~n_takers ()) saturn-0.5.0/bench/bench_relaxed_queue.ml0000644000175000017500000000643614661627530017145 0ustar kylekyleopen Multicore_bench module Queue = Saturn.Relaxed_queue module Spin = Queue.Spin module Not_lockfree = Queue.Not_lockfree module CAS_interface = Queue.Not_lockfree.CAS_interface let run_one ~budgetf ~n_adders ~n_takers ?(n_msgs = 50 * Util.iter_factor) ?(api = `Spin) () = let n_domains = n_adders + n_takers in let t = Queue.create ~size_exponent:10 () in let n_msgs_to_take = Atomic.make 0 |> Multicore_magic.copy_as_padded in let n_msgs_to_add = Atomic.make 0 |> Multicore_magic.copy_as_padded in let init _ = assert (Not_lockfree.pop t == None); Atomic.set n_msgs_to_take n_msgs; Atomic.set n_msgs_to_add n_msgs in let work i () = if i < n_adders then let rec work () = let n = Util.alloc n_msgs_to_add in if n <> 0 then begin match api with | `Spin -> for i = 1 to n do Spin.push t i done; work () | `Not_lockfree -> let rec loop n = if 0 < n then if Not_lockfree.push t i then loop (n - 1) else begin Domain.cpu_relax (); loop n end else work () in loop n | `CAS_interface -> let rec loop n = if 0 < n then if CAS_interface.push t i then loop (n - 1) else begin Domain.cpu_relax (); loop n end else work () in loop n end in work () else let rec work () = let n = Util.alloc n_msgs_to_take in if n <> 0 then match api with | `Spin -> for _ = 1 to n do Spin.pop t |> ignore done; work () | `Not_lockfree -> let rec loop n = if 0 < n then begin match Not_lockfree.pop t with | None -> Domain.cpu_relax (); loop n | Some _ -> loop (n - 1) end else work () in loop n | `CAS_interface -> let rec loop n = if 0 < n then begin match CAS_interface.pop t with | None -> Domain.cpu_relax (); loop n | Some _ -> loop (n - 1) end else work () in loop n in work () in let config = let plural role n = Printf.sprintf "%d %s%s" n role (if n = 1 then "" else "s") in Printf.sprintf "%s, %s (%s)" (plural "adder" n_adders) (plural "taker" n_takers) (match api with | `Spin -> "spin" | `Not_lockfree -> "not lf" | `CAS_interface -> "cas") in Times.record ~budgetf ~n_domains ~init ~work () |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config let run_suite ~budgetf = Util.cross [ `Spin; `Not_lockfree; `CAS_interface ] (Util.cross [ 1; 2 ] [ 1; 2 ]) |> List.concat_map @@ fun (api, (n_adders, n_takers)) -> run_one ~budgetf ~n_adders ~n_takers ~api () saturn-0.5.0/bench/main.ml0000644000175000017500000000077514661627530014102 0ustar kylekylelet benchmarks = [ ("Saturn Relaxed_queue", Bench_relaxed_queue.run_suite); ("Saturn_lockfree Queue", Bench_queue.run_suite); ("Saturn_lockfree Single_prod_single_cons_queue", Bench_spsc_queue.run_suite); ("Saturn_lockfree Size", Bench_size.run_suite); ("Saturn_lockfree Skiplist", Bench_skiplist.run_suite); ("Saturn_lockfree Stack", Bench_stack.run_suite); ("Saturn_lockfree Work_stealing_deque", Bench_ws_deque.run_suite); ] let () = Multicore_bench.Cmd.run ~benchmarks () saturn-0.5.0/bench/dune0000644000175000017500000000047614661627530013500 0ustar kylekyle(* -*- tuareg -*- *) let maybe_domain_shims = if Jbuild_plugin.V1.ocaml_version < "5" then "domain_shims" else "" let () = Jbuild_plugin.V1.send @@ {| (test (package saturn) (name main) (action (run %{test} -brief)) (libraries saturn multicore-bench multicore-magic |} ^ maybe_domain_shims ^ {| )) |} saturn-0.5.0/bench/bench_skiplist.ml0000644000175000017500000000411614661627530016150 0ustar kylekyleopen Multicore_bench module Skiplist = Saturn.Skiplist let run_one ~budgetf ~n_domains ?(n_ops = 20 * Util.iter_factor) ?(n_keys = 10000) ~percent_mem ?(percent_add = (100 - percent_mem + 1) / 2) ?(prepopulate = true) () = let percent_rem = 100 - (percent_mem + percent_add) in let limit_mem = percent_mem in let limit_add = percent_mem + percent_add in assert (0 <= limit_mem && limit_mem <= 100); assert (limit_mem <= limit_add && limit_add <= 100); let t = Skiplist.create ~compare:Int.compare () in if prepopulate then for _ = 1 to n_keys do let value = Random.bits () in let key = value mod n_keys in Skiplist.try_add t key value |> ignore done; let n_ops = (100 + percent_mem) * n_ops / 100 in let n_ops = n_ops * n_domains in let n_ops_todo = Atomic.make 0 |> Multicore_magic.copy_as_padded in let init _ = Atomic.set n_ops_todo n_ops; Random.State.make_self_init () in let work _ state = let rec work () = let n = Util.alloc n_ops_todo in if n <> 0 then let rec loop n = if 0 < n then let value = Random.State.bits state in let op = (value asr 20) mod 100 in let key = value mod n_keys in if op < limit_mem then begin Skiplist.mem t key |> ignore; loop (n - 1) end else if op < limit_add then begin Skiplist.try_add t key value |> ignore; loop (n - 1) end else begin Skiplist.try_remove t key |> ignore; loop (n - 1) end else work () in loop n in work () in let config = Printf.sprintf "%d workers, %d%% mem %d%% add %d%% rem" n_domains percent_mem percent_add percent_rem in Times.record ~budgetf ~n_domains ~init ~work () |> Times.to_thruput_metrics ~n:n_ops ~singular:"operation" ~config let run_suite ~budgetf = Util.cross [ 10; 50; 90 ] [ 1; 2; 4 ] |> List.concat_map @@ fun (percent_mem, n_domains) -> run_one ~budgetf ~n_domains ~percent_mem () saturn-0.5.0/bench/bench_stack.ml0000644000175000017500000000377114661627530015421 0ustar kylekyleopen Multicore_bench module Stack = Saturn_lockfree.Stack let run_one_domain ~budgetf ?(n_msgs = 50 * Util.iter_factor) () = let t = Stack.create () in let op push = if push then Stack.push t 101 else Stack.pop_opt t |> ignore in let init _ = assert (Stack.is_empty t); Util.generate_push_and_pop_sequence n_msgs in let work _ bits = Util.Bits.iter op bits in Times.record ~budgetf ~n_domains:1 ~init ~work () |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config:"one domain" let run_one ~budgetf ?(n_adders = 2) ?(n_takers = 2) ?(n_msgs = 50 * Util.iter_factor) () = let n_domains = n_adders + n_takers in let t = Stack.create () in let n_msgs_to_take = Atomic.make 0 |> Multicore_magic.copy_as_padded in let n_msgs_to_add = Atomic.make 0 |> Multicore_magic.copy_as_padded in let init _ = assert (Stack.is_empty t); Atomic.set n_msgs_to_take n_msgs; Atomic.set n_msgs_to_add n_msgs in let work i () = if i < n_adders then let rec work () = let n = Util.alloc n_msgs_to_add in if 0 < n then begin for i = 1 to n do Stack.push t i done; work () end in work () else let rec work () = let n = Util.alloc n_msgs_to_take in if n <> 0 then begin for _ = 1 to n do while Option.is_none (Stack.pop_opt t) do Domain.cpu_relax () done done; work () end in work () in let config = let format role n = Printf.sprintf "%d %s%s" n role (if n = 1 then "" else "s") in Printf.sprintf "%s, %s" (format "adder" n_adders) (format "taker" n_takers) in Times.record ~budgetf ~n_domains ~init ~work () |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config let run_suite ~budgetf = run_one_domain ~budgetf () @ (Util.cross [ 1; 2 ] [ 1; 2 ] |> List.concat_map @@ fun (n_adders, n_takers) -> run_one ~budgetf ~n_adders ~n_takers ()) saturn-0.5.0/LICENSE.md0000644000175000017500000000144414661627530013143 0ustar kylekyleCopyright (c) 2016 KC Sivaramakrishnan Copyright (C) 2022 Thomas Leonard Copyright (C) 2023 Vesa Karvonen Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. saturn-0.5.0/.prettierrc0000644000175000017500000000035114661627530013717 0ustar kylekyle{ "arrowParens": "avoid", "bracketSpacing": false, "printWidth": 80, "semi": false, "singleQuote": true, "proseWrap": "always", "overrides": [ { "files": ["*.md"], "excludeFiles": "_build/*" } ] } saturn-0.5.0/.dockerignore0000644000175000017500000000000714661627530014205 0ustar kylekyle_build saturn-0.5.0/saturn.opam0000644000175000017500000000242414661627530013730 0ustar kylekyleversion: "0.5.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Collection of parallelism-safe data structures for Multicore OCaml" maintainer: ["Carine Morel" "KC Sivaramakrishnan" "Sudha Parimala"] authors: ["KC Sivaramakrishnan"] license: "ISC" homepage: "https://github.com/ocaml-multicore/saturn" doc: "https://ocaml-multicore.github.io/saturn/" bug-reports: "https://github.com/ocaml-multicore/saturn/issues" depends: [ "dune" {>= "3.14"} "ocaml" {>= "4.13"} "domain_shims" {>= "0.1.0" & with-test} "saturn_lockfree" {= version} "multicore-magic" {>= "2.3.0" & with-test} "multicore-bench" {>= "0.1.2" & with-test} "multicore-magic-dscheck" {>= "2.3.0" & with-test} "backoff" {>= "0.1.0" & with-test} "alcotest" {>= "1.7.0" & with-test} "qcheck" {>= "0.21.3" & with-test} "qcheck-stm" {>= "0.3" & with-test} "qcheck-alcotest" {>= "0.21.3" & with-test} "yojson" {>= "2.0.2" & with-test} "dscheck" {>= "0.5.0" & with-test} "sherlodoc" {>= "0.2" & with-doc} "odoc" {>= "2.4.1" & with-doc} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/ocaml-multicore/saturn.git"saturn-0.5.0/.gitignore0000644000175000017500000000011714661627530013523 0ustar kylekyle_build tmp *~ \.\#* \#*# *.install *.native *.byte *.merlin *.json node_modulessaturn-0.5.0/src_lockfree/0000755000175000017500000000000014661627530014175 5ustar kylekylesaturn-0.5.0/src_lockfree/ArrayExtra.ml0000644000175000017500000000422414661627530016613 0ustar kylekyle(* The following code is taken from the library [sek] by Arthur Charguéraud and François Pottier. *) (** [blit_circularly_dst a1 i1 a2 i2 k] copies [k] elements from the array [a1], starting at index [i1], to the array [a2], starting at index [i2]. The destination array is regarded as circular, so it is permitted for the destination range to wrap around. *) let blit_circularly_dst a1 i1 a2 i2 k = (* The source range must be well-formed. *) assert (0 <= k && 0 <= i1 && i1 + k <= Array.length a1); (* The destination array must be large enough to hold the data. *) let n2 = Array.length a2 in assert (k <= n2); (* The destination index must be well-formed. *) assert (0 <= i2 && i2 < n2); (* We need either one or two blits. *) if i2 + k <= n2 then Array.blit a1 i1 a2 i2 k else let k1 = n2 - i2 in assert (0 < k1 && k1 < k); Array.blit a1 i1 a2 i2 k1; Array.blit a1 (i1 + k1) a2 0 (k - k1) (** [blit_circularly a1 i1 a2 i2 k] copies [k] elements from the array [a1], starting at index [i1], to the array [a2], starting at index [i2]. Both the source array and the destination array are regarded as circular, so it is permitted for the source range or destination range to wrap around. [i1] must be comprised between 0 included and [Array.length a1] excluded. [i2] must be comprised between 0 included and [Array.length a2] excluded. [k] must be comprised between 0 included and [Array.length a2] included. *) let blit_circularly a1 i1 a2 i2 k = let n1 = Array.length a1 in (* The source range must be well-formed. *) assert (0 <= i1 && i1 < n1); assert (0 <= k); (* The destination array must be large enough to hold the data. *) let n2 = Array.length a2 in assert (k <= n2); (* The destination index must be well-formed. *) assert (0 <= i2 && i2 < n2); (* We need either one or two calls to [blit_circularly_dst]. *) if i1 + k <= n1 then blit_circularly_dst a1 i1 a2 i2 k else let k1 = n1 - i1 in assert (0 < k1 && k1 < k); blit_circularly_dst a1 i1 a2 i2 k1; let i2 = i2 + k1 in let i2 = if i2 < n2 then i2 else i2 - n2 in blit_circularly_dst a1 0 a2 i2 (k - k1) saturn-0.5.0/src_lockfree/mpmc_relaxed_queue.ml0000644000175000017500000001276414661627530020405 0ustar kylekyle(* # General idea It is the easiest to explain the general idea on an array of infinite size. Let's start with that. Each element in such an array constitutes a single-use exchange slot. Enqueuer increments [tail] and treats prior value as index of its slot. Same for dequeuer and [head]. This effectively creates pairs (enqueuer, dequeuer) assigned to the same slot. Enqueuer leaves the value in the slot, dequer copies it out. Enqueuer never fails. It always gets a brand-new slot and places item in it. Dequeuer, on the other hand, may witness an empty slot. That's because [head] may jump behind [tail]. Remember, indices are implemented blindy. For now, assume dequeuer simply spins on the empty slot until an item appears. That's it. There's a few things flowing from this construction: * Slots are atomic. This is where paired enqueuer and dequeuer communicate. * [head] overshooting [tail] is a normal condition and that's good - we want to keep operations on [head] and [tail] independent. # Finite array Now, to make it work in real-world, simply treat finite array as circular, i.e. wrap around when reached the end. Slots are now re-used, so we need to be more careful. Firstly, if there's too many items, enqueuer may witness a full slot. Let's assume enqueuer simply spins on full slot until some dequeuer appears and takes the old value. Secondly, in the case of overlap, there can be more than 2 threads (1x enqueuer, 1x dequeuer) assigned to a single slot (imagine 10 enqueuers spinning on an 8-slot array). In fact, it could be any number. Thus, all operations on slot have to use CAS to ensure that no item is overwrriten on store and no item is dequeued by two threads at once. Above works okay in practise, and there is some relevant literature, e.g. (DOI: 10.1145/3437801.3441583) analyzed this particular design. There's also plenty older papers looking at similar approaches (e.g. DOI: 10.1145/2851141.2851168). Note, this design may violate FIFO (on overlap). The risk can be minimized by ensuring size of array >> number of threads but it's never zero. (github.com/rigtorp/MPMCQueue has a nice way of fixing this, we could add it). # Blocking (non-lockfree paths on full, empty) Up until now [push] and [pop] were allowed to block indefinitely on empty and full queue. Overall, what can be done in those states? 1. Busy wait until able to finish. 2. Rollback own index with CAS (unassign itself from slot). 3. Move forward other index with CAS (assign itself to the same slot as opposite action). 4. Mark slot as burned - dequeue only. Which one then? Let's optimize for stability, i.e. some reasonable latency that won't get much worse under heavy load. Busy wait is great because it does not cause any contention in the hotspots ([head], [tail]). Thus, start with busy wait (1). If queue is busy and moving fast, there is a fair chance that within, say, 30 spins, we'll manage to complete action without having to add contention elsewhere. Once N busy-loops happen and nothing changes, we probably want to return even if its costs. (2), (3) both allow that. (2) doesn't add contention to the other index like (3) does. Say, there's a lot more dequeuers than enqueuers, if all dequeurs did (3), they would add a fair amount of contention to the [tail] index and slow the already-outnumbered enqueuers further. So, (2) > (3) for that reason. However, with just (2), some dequeuers will struggle to return. If many dequeuers constatly try to pop an element and fail, they will form a chain. tl hd | | [.]-[A]-[B]-[C]-..-[X] For A to rollback, B has to rollback first. For B to rollback C has to rollback first. [A] is likely to experience a large latency spike. In such a case, it is easier for [A] to do (3) rather than hope all other active dequeuers will unblock it at some point. Thus, it's worthwile also trying to do (3) periodically. Thus, the current policy does (1) for a bit, then (1), (2) with periodic (3). What about burned slots (4)? It's present in the literature. Weakly I'm not a fan. If dequeuers are faster to remove items than enqueuers supply them, slots burned by dequeuers are going to make enqueuers do even more work. # Resizing The queue does not support resizing, but it can be simulated by wrapping it in a lockfree list. *) type 'a t = { array : 'a Option.t Atomic.t Array.t; head : int Atomic.t; tail : int Atomic.t; mask : int; } let create ~size_exponent () : 'a t = let size = 1 lsl size_exponent in let array = Array.init size (fun _ -> Atomic.make None) in let mask = size - 1 in let head = Atomic.make 0 in let tail = Atomic.make 0 in { array; head; tail; mask } (* [ccas] A slightly nicer CAS. Tries without taking microarch lock first. Use on indices. *) let ccas cell seen v = if Atomic.get cell != seen then false else Atomic.compare_and_set cell seen v let push { array; tail; mask; _ } item = let tail_val = Atomic.fetch_and_add tail 1 in let index = tail_val land mask in let cell = Array.get array index in while not (ccas cell None (Some item)) do Domain.cpu_relax () done let pop { array; head; mask; _ } = let head_val = Atomic.fetch_and_add head 1 in let index = head_val land mask in let cell = Array.get array index in let item = ref (Atomic.get cell) in while Option.is_none !item || not (ccas cell !item None) do Domain.cpu_relax (); item := Atomic.get cell done; Option.get !item saturn-0.5.0/src_lockfree/michael_scott_queue_unsafe.mli0000644000175000017500000000005214661627530022260 0ustar kylekyleinclude Michael_scott_queue_intf.MS_QUEUE saturn-0.5.0/src_lockfree/michael_scott_queue.ml0000644000175000017500000000633014661627530020553 0ustar kylekyle(* * Copyright (c) 2015, Théo Laurent * Copyright (c) 2015, KC Sivaramakrishnan * Copyright (c) 2023, Vesa Karvonen * * Permission to use, copy, modify, and/or distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) (* Michael-Scott queue *) type 'a node = Nil | Next of 'a * 'a node Atomic.t type 'a t = { head : 'a node Atomic.t Atomic.t; tail : 'a node Atomic.t Atomic.t; } let create () = let next = Atomic.make Nil in let head = Atomic.make_contended next in let tail = Atomic.make_contended next in { head; tail } let is_empty { head; _ } = Atomic.get (Atomic.get head) == Nil exception Empty type ('a, _) poly = Option : ('a, 'a option) poly | Value : ('a, 'a) poly let rec pop_as : type a r. a node Atomic.t Atomic.t -> Backoff.t -> (a, r) poly -> r = fun head backoff poly -> let old_head = Atomic.get head in match Atomic.get old_head with | Nil -> begin match poly with Value -> raise Empty | Option -> None end | Next (value, next) -> if Atomic.compare_and_set head old_head next then begin match poly with Value -> value | Option -> Some value end else let backoff = Backoff.once backoff in pop_as head backoff poly let pop_exn t = pop_as t.head Backoff.default Value let pop_opt t = pop_as t.head Backoff.default Option let peek_as : type a r. a node Atomic.t Atomic.t -> (a, r) poly -> r = fun head poly -> let old_head = Atomic.get head in match Atomic.get old_head with | Nil -> begin match poly with Value -> raise Empty | Option -> None end | Next (value, _) -> ( match poly with Value -> value | Option -> Some value) let peek_opt t = peek_as t.head Option let peek_exn t = peek_as t.head Value let rec fix_tail tail new_tail = let old_tail = Atomic.get tail in if Atomic.get new_tail == Nil && not (Atomic.compare_and_set tail old_tail new_tail) then fix_tail tail new_tail let push { tail; _ } value = let rec find_tail_and_enq curr_end node = if not (Atomic.compare_and_set curr_end Nil node) then match Atomic.get curr_end with | Nil -> find_tail_and_enq curr_end node | Next (_, n) -> find_tail_and_enq n node in let new_tail = Atomic.make Nil in let newnode = Next (value, new_tail) in let old_tail = Atomic.get tail in if not (Atomic.compare_and_set old_tail Nil newnode) then begin match Atomic.get old_tail with | Nil -> find_tail_and_enq old_tail newnode | Next (_, n) -> find_tail_and_enq n newnode end; if not (Atomic.compare_and_set tail old_tail new_tail) then fix_tail tail new_tail saturn-0.5.0/src_lockfree/skiplist.mli0000644000175000017500000000354714661627530016553 0ustar kylekyle(** A lock-free skiplist. *) type (!'k, !'v) t (** The type of a lock-free skiplist containing bindings of keys of type ['k] to values of type ['v]. *) val create : ?max_height:int -> compare:('k -> 'k -> int) -> unit -> ('k, 'v) t (** [create ~compare ()] creates a new empty skiplist where keys are ordered based on the given [compare] function. Note that the polymorphic [Stdlib.compare] function has relatively high overhead and it is usually better to use a type specific [compare] function such as [Int.compare] or [String.compare]. The optional [max_height] argument determines the maximum height of nodes in the skiplist and directly affects the performance of the skiplist. The current implementation does not adjust height automatically. *) val max_height_of : ('k, 'v) t -> int (** [max_height_of s] returns the maximum height of nodes of the skiplist [s] as specified to {!create}. *) val find_opt : ('k, 'v) t -> 'k -> 'v option (** [find_opt s k] tries to find a binding of [k] to [v] from the skiplist [s] and returns [Some v] in case such a binding was found or return [None] in case no such binding was found. *) val mem : ('k, 'v) t -> 'k -> bool (** [mem s k] determines whether the skiplist [s] contained a binding of [k]. *) val try_add : ('k, 'v) t -> 'k -> 'v -> bool (** [try_add s k v] tries to add a new binding of [k] to [v] into the skiplist [s] and returns [true] on success. Otherwise the skiplist already contained a binding of [k] and [false] is returned. *) val try_remove : ('k, 'v) t -> 'k -> bool (** [try_remove s k] tries to remove a binding of [k] from the skiplist and returns [true] on success. Otherwise the skiplist did not contain a binding of [k] and [false] is returned. *) val length : ('k, 'v) t -> int (** [length s] computes the number of bindings in the skiplist [s]. *) saturn-0.5.0/src_lockfree/ws_deque.ml0000644000175000017500000001241314661627530016344 0ustar kylekyle(* * Copyright (c) 2015, Théo Laurent * Copyright (c) 2015, KC Sivaramakrishnan * Copyright (c) 2017, Nicolas ASSOUAD * Copyright (c) 2021, Tom Kelly * * Permission to use, copy, modify, and/or distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) (* Work Stealing Queue * * See: * Dynamic circular work-stealing deque * https://dl.acm.org/doi/10.1145/1073970.1073974 * & * Correct and efficient work-stealing for weak memory models * https://dl.acm.org/doi/abs/10.1145/2442516.2442524 *) module type S = sig type 'a t val create : unit -> 'a t val push : 'a t -> 'a -> unit val pop : 'a t -> 'a val pop_opt : 'a t -> 'a option val steal : 'a t -> 'a val steal_opt : 'a t -> 'a option end module CArray = struct type 'a t = 'a array let rec log2 n = if n <= 1 then 0 else 1 + log2 (n asr 1) let create sz v = (* [sz] must be a power of two. *) assert (0 < sz && sz = Int.shift_left 1 (log2 sz)); assert (Int.logand sz (sz - 1) == 0); Array.make sz v let size t = Array.length t [@@inline] let mask t = size t - 1 [@@inline] let index i t = (* Because [size t] is a power of two, [i mod (size t)] is the same as [i land (size t - 1)], that is, [i land (mask t)]. *) Int.logand i (mask t) [@@inline] let get t i = Array.unsafe_get t (index i t) [@@inline] let put t i v = Array.unsafe_set t (index i t) v [@@inline] let transfer src dst top num = ArrayExtra.blit_circularly (* source array and index: *) src (index top src) (* target array and index: *) dst (index top dst) (* number of elements: *) num [@@inline] let grow t top bottom = let sz = size t in assert (bottom - top = sz); let dst = create (2 * sz) (Obj.magic ()) in transfer t dst top sz; dst let shrink t top bottom = let sz = size t in assert (bottom - top <= sz / 2); let dst = create (sz / 2) (Obj.magic ()) in transfer t dst top (bottom - top); dst end module M : S = struct let min_size = 32 let shrink_const = 3 type 'a t = { top : int Atomic.t; bottom : int Atomic.t; tab : 'a ref CArray.t Atomic.t; mutable next_shrink : int; } let create () = { top = Atomic.make 1; bottom = Atomic.make 1; tab = Atomic.make (CArray.create min_size (Obj.magic ())); next_shrink = 0; } let set_next_shrink q = let sz = CArray.size (Atomic.get q.tab) in if sz <= min_size then q.next_shrink <- 0 else q.next_shrink <- sz / shrink_const let grow q t b = Atomic.set q.tab (CArray.grow (Atomic.get q.tab) t b); set_next_shrink q let size q = let b = Atomic.get q.bottom in let t = Atomic.get q.top in b - t let push q v = let v' = ref v in let b = Atomic.get q.bottom in let t = Atomic.get q.top in let a = Atomic.get q.tab in let size = b - t in let a = if size = CArray.size a then ( grow q t b; Atomic.get q.tab) else a in CArray.put a b v'; Atomic.set q.bottom (b + 1) let release ptr = let res = !ptr in (* we know this ptr will never be dereferenced, but want to break the reference to ensure that the contents of the deque array get garbage collected *) ptr := Obj.magic (); res [@@inline] let pop q = if size q = 0 then raise Exit else let b = Atomic.get q.bottom - 1 in Atomic.set q.bottom b; let t = Atomic.get q.top in let a = Atomic.get q.tab in let size = b - t in if size < 0 then ( (* empty queue *) Atomic.set q.bottom (b + 1); raise Exit) else let out = CArray.get a b in if b = t then (* single last element *) if Atomic.compare_and_set q.top t (t + 1) then ( Atomic.set q.bottom (b + 1); release out) else ( Atomic.set q.bottom (b + 1); raise Exit) else ( (* non-empty queue *) if q.next_shrink > size then ( Atomic.set q.tab (CArray.shrink a t b); set_next_shrink q); release out) let pop_opt q = try Some (pop q) with Exit -> None let rec steal backoff q = let t = Atomic.get q.top in let b = Atomic.get q.bottom in let size = b - t in if size <= 0 then raise Exit else let a = Atomic.get q.tab in let out = CArray.get a t in if Atomic.compare_and_set q.top t (t + 1) then release out else steal (Backoff.once backoff) q let steal q = steal Backoff.default q let steal_opt q = try Some (steal q) with Exit -> None end saturn-0.5.0/src_lockfree/saturn_lockfree.ml0000644000175000017500000000327114661627530017720 0ustar kylekyle(*--------------------------------------------------------------------------- Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved. Distributed under the ISC license, see terms at the end of the file. saturn 0.5.0 ---------------------------------------------------------------------------*) (*--------------------------------------------------------------------------- Copyright (c) 2016 KC Sivaramakrishnan Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ---------------------------------------------------------------------------*) (* ######## Copyright (c) 2017, Nicolas ASSOUAD ######## *) module Queue = Michael_scott_queue module Queue_unsafe = Michael_scott_queue_unsafe module Stack = Treiber_stack module Work_stealing_deque = Ws_deque module Single_prod_single_cons_queue = Spsc_queue module Single_prod_single_cons_queue_unsafe = Spsc_queue_unsafe module Single_consumer_queue = Mpsc_queue module Relaxed_queue = Mpmc_relaxed_queue module Size = Size module Skiplist = Skiplist saturn-0.5.0/src_lockfree/michael_scott_queue_unsafe.ml0000644000175000017500000000746414661627530022125 0ustar kylekyle(* * Copyright (c) 2015, Théo Laurent * Copyright (c) 2015, KC Sivaramakrishnan * Copyright (c) 2023, Vesa Karvonen * * Permission to use, copy, modify, and/or distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) module Node = Michael_scott_queue_unsafe_node module Atomic = Node.Atomic type 'a t = { head : ('a, [ `Next ]) Node.t Atomic.t; tail : ('a, [ `Next ]) Node.t Atomic.t; } let create () = let node = Node.make (Obj.magic ()) in let head = Atomic.make node |> Multicore_magic.copy_as_padded in let tail = Atomic.make node |> Multicore_magic.copy_as_padded in { head; tail } |> Multicore_magic.copy_as_padded let is_empty t = Atomic.get (Node.as_atomic (Atomic.get t.head)) == Nil exception Empty type ('a, _) poly = Option : ('a, 'a option) poly | Value : ('a, 'a) poly let rec pop_as : type a r. (a, [ `Next ]) Node.t Atomic.t -> Backoff.t -> (a, r) poly -> r = fun head backoff poly -> let old_head = Atomic.get head in match Atomic.get (Node.as_atomic old_head) with | Nil -> begin match poly with Value -> raise Empty | Option -> None end | Next r as new_head -> if Atomic.compare_and_set head old_head new_head then begin match poly with | Value -> let value = r.value in r.value <- Obj.magic (); value | Option -> let value = r.value in r.value <- Obj.magic (); Some value end else let backoff = Backoff.once backoff in pop_as head backoff poly let pop_opt t = pop_as t.head Backoff.default Option let pop_exn t = pop_as t.head Backoff.default Value let rec peek_as : type a r. (a, [ `Next ]) Node.t Atomic.t -> (a, r) poly -> r = fun head poly -> let old_head = Atomic.get head in match Atomic.get (Node.as_atomic old_head) with | Nil -> begin match poly with Value -> raise Empty | Option -> None end | Next r -> let value = r.value in if Atomic.get head == old_head then match poly with Value -> value | Option -> Some value else peek_as head poly let peek_opt t = peek_as t.head Option let peek_exn t = peek_as t.head Value let rec fix_tail tail new_tail backoff = let old_tail = Atomic.get tail in if Atomic.get (Node.as_atomic new_tail) == Nil && not (Atomic.compare_and_set tail old_tail new_tail) then fix_tail tail new_tail (Backoff.once backoff) let rec push tail link (Next _ as new_node : (_, [ `Next ]) Node.t) backoff = match Atomic.get link with | Node.Nil -> if Atomic.compare_and_set link Node.Nil new_node then begin fix_tail tail new_node Backoff.default end else let backoff = Backoff.once backoff in push tail link new_node backoff | Next _ as next -> push tail (Node.as_atomic next) new_node backoff let push { tail; _ } value = let (Next _ as new_node : (_, [ `Next ]) Node.t) = Node.make value in let old_tail = Atomic.get tail in let link = Node.as_atomic old_tail in if Atomic.compare_and_set link Nil new_node then Atomic.compare_and_set tail old_tail new_node |> ignore else let backoff = Backoff.once Backoff.default in push tail link new_node backoff saturn-0.5.0/src_lockfree/spsc_queue.ml0000644000175000017500000000676514661627530016721 0ustar kylekyle(* * Copyright (c) 2022, Bartosz Modelski * Copyright (c) 2024, Vesa Karvonen * * Permission to use, copy, modify, and/or distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) (* Single producer single consumer queue * * The algorithms here are inspired by: * https://dl.acm.org/doi/pdf/10.1145/3437801.3441583 *) module Padded_int_ref = struct type t = int array let[@inline] make s i : t = Array.make s i let[@inline] get (t : t) = Array.unsafe_get t 0 let[@inline] set (t : t) v = Array.unsafe_set t 0 v end type 'a t = { array : 'a Option.t Array.t; tail : int Atomic.t; tail_cache : Padded_int_ref.t; head : int Atomic.t; head_cache : Padded_int_ref.t; } exception Full let create ~size_exponent = if size_exponent < 0 || Sys.int_size - 2 < size_exponent then invalid_arg "size_exponent out of range"; let size = 1 lsl size_exponent in let array = Array.make size None in let tail = Atomic.make_contended 0 in let s = Obj.size (Obj.repr tail) in let tail_cache = Padded_int_ref.make s 0 in let head = Atomic.make_contended 0 in let head_cache = Padded_int_ref.make s 0 in { array; tail; tail_cache; head; head_cache } type _ mono = Unit : unit mono | Bool : bool mono let push_as (type r) t element (mono : r mono) : r = let size = Array.length t.array in let tail = Atomic.get t.tail in let head_cache = Padded_int_ref.get t.head_cache in if head_cache == tail - size && let head = Atomic.get t.head in Padded_int_ref.set t.head_cache head; head == head_cache then match mono with Unit -> raise_notrace Full | Bool -> false else begin Array.unsafe_set t.array (tail land (size - 1)) (Some element); Atomic.incr t.tail; match mono with Unit -> () | Bool -> true end let push_exn t element = push_as t element Unit let try_push t element = push_as t element Bool exception Empty type ('a, _) poly = Option : ('a, 'a option) poly | Value : ('a, 'a) poly type op = Peek | Pop let pop_or_peek_as (type a r) (t : a t) op (poly : (a, r) poly) : r = let head = Atomic.get t.head in let tail_cache = Padded_int_ref.get t.tail_cache in if head == tail_cache && let tail = Atomic.get t.tail in Padded_int_ref.set t.tail_cache tail; tail_cache == tail then match poly with Value -> raise_notrace Empty | Option -> None else let index = head land (Array.length t.array - 1) in let v = Array.unsafe_get t.array index in begin match op with | Pop -> Array.unsafe_set t.array index None; Atomic.incr t.head | Peek -> () end; match poly with Value -> Option.get v | Option -> v let pop_exn t = pop_or_peek_as t Pop Value let pop_opt t = pop_or_peek_as t Pop Option let peek_exn t = pop_or_peek_as t Peek Value let peek_opt t = pop_or_peek_as t Peek Option let size t = let tail = Atomic.get t.tail in let head = Atomic.get t.head in tail - head saturn-0.5.0/src_lockfree/treiber_stack.ml0000644000175000017500000000202714661627530017351 0ustar kylekyle(** Treiber's Lock Free stack *) type 'a node = Nil | Cons of { value : 'a; tail : 'a node } type 'a t = 'a node Atomic.t let create () = Atomic.make Nil |> Multicore_magic.copy_as_padded let is_empty t = Atomic.get t == Nil let rec push t value backoff = let tail = Atomic.get t in let cons = Cons { value; tail } in if not (Atomic.compare_and_set t tail cons) then push t value (Backoff.once backoff) let push t value = push t value Backoff.default exception Empty type ('a, _) poly = Option : ('a, 'a option) poly | Value : ('a, 'a) poly let rec pop_as : type a r. a t -> Backoff.t -> (a, r) poly -> r = fun t backoff poly -> match Atomic.get t with | Nil -> begin match poly with Option -> None | Value -> raise Empty end | Cons cons_r as cons -> if Atomic.compare_and_set t cons cons_r.tail then match poly with Option -> Some cons_r.value | Value -> cons_r.value else pop_as t (Backoff.once backoff) poly let pop t = pop_as t Backoff.default Value let pop_opt t = pop_as t Backoff.default Option saturn-0.5.0/src_lockfree/spsc_queue_unsafe.ml0000644000175000017500000000705214661627530020250 0ustar kylekyle(* * Copyright (c) 2022, Bartosz Modelski * Copyright (c) 2024, Vesa Karvonen * * Permission to use, copy, modify, and/or distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) (* Single producer single consumer queue * * The algorithms here are inspired by: * https://dl.acm.org/doi/pdf/10.1145/3437801.3441583 *) module Atomic = Multicore_magic.Transparent_atomic type not_float = [ `Not_float of not_float ] type 'a t = { array : not_float Array.t; tail : int Atomic.t; tail_cache : int ref; head : int Atomic.t; head_cache : int ref; } exception Full let create ~size_exponent = if size_exponent < 0 || Sys.int_size - 2 < size_exponent then invalid_arg "size_exponent out of range"; let size = 1 lsl size_exponent in let array = Array.make size (Obj.magic ()) in let tail = Atomic.make_contended 0 in let tail_cache = ref 0 |> Multicore_magic.copy_as_padded in let head = Atomic.make_contended 0 in let head_cache = ref 0 |> Multicore_magic.copy_as_padded in { array; tail; tail_cache; head; head_cache } |> Multicore_magic.copy_as_padded type _ mono = Unit : unit mono | Bool : bool mono (* NOTE: Uses of [@inline never] prevent Flambda from noticing that we might be storing float values into a non-float array. *) let[@inline never] push_as (type r) t element (mono : r mono) : r = let size = Array.length t.array in let tail = Atomic.fenceless_get t.tail in let head_cache = !(t.head_cache) in if head_cache == tail - size && let head = Atomic.get t.head in t.head_cache := head; head == head_cache then match mono with Unit -> raise_notrace Full | Bool -> false else begin Array.unsafe_set t.array (tail land (size - 1)) (Obj.magic element); Atomic.incr t.tail; match mono with Unit -> () | Bool -> true end let push_exn t element = push_as t element Unit let try_push t element = push_as t element Bool exception Empty type ('a, _) poly = Option : ('a, 'a option) poly | Value : ('a, 'a) poly type op = Peek | Pop let[@inline never] pop_or_peek_as (type a r) t op (poly : (a, r) poly) : r = let head = Atomic.fenceless_get t.head in let tail_cache = !(t.tail_cache) in if head == tail_cache && let tail = Atomic.get t.tail in t.tail_cache := tail; tail_cache == tail then match poly with Value -> raise_notrace Empty | Option -> None else let index = head land (Array.length t.array - 1) in let v = Array.unsafe_get t.array index |> Obj.magic in begin match op with | Pop -> Array.unsafe_set t.array index (Obj.magic ()); Atomic.incr t.head | Peek -> () end; match poly with Value -> v | Option -> Some v let pop_exn t = pop_or_peek_as t Pop Value let pop_opt t = pop_or_peek_as t Pop Option let peek_exn t = pop_or_peek_as t Peek Value let peek_opt t = pop_or_peek_as t Peek Option let size t = let tail = Atomic.get t.tail in let head = Atomic.fenceless_get t.head in tail - head saturn-0.5.0/src_lockfree/domain.ocaml4.ml0000644000175000017500000000003514661627530017152 0ustar kylekylelet cpu_relax = Thread.yield saturn-0.5.0/src_lockfree/mpmc_relaxed_queue.mli0000644000175000017500000000252614661627530020551 0ustar kylekyle(** A multi-producer, multi-consumer, thread-safe, bounded relaxed-FIFO queue. This interface is a subset of the one in `Saturn.Relaxed_queue` that exposes a formally lock-free interface as per the [A lock-free relaxed concurrent queue for fast work distribution] paper. [push] and [pop] are said to be `lock-free formally`, because the property is achieved in a fairly counterintuitive way - by using the fact that lock-freedom does not impose any constraints on partial methods. In simple words, an invocation of function that cannot logically terminate (`push` on full queue, `pop` on empty queue), it is allowed to *busy-wait* until the precondition is meet. *) type 'a t = private { array : 'a Option.t Atomic.t Array.t; head : int Atomic.t; tail : int Atomic.t; mask : int; } (** A queue of items of type ['a]. Implementation exposed for testing. *) val create : size_exponent:int -> unit -> 'a t (** [create ~size_exponent:int] creates an empty queue of size [2^size_exponent]. *) val push : 'a t -> 'a -> unit (** [push t x] adds [x] to the tail of the queue. If the queue is full, [push] busy-waits until another thread removes an item. *) val pop : 'a t -> 'a (** [pop t] removes an item from the head of the queue. If the queue is empty, [pop] busy-waits until an item appear. *) saturn-0.5.0/src_lockfree/mpsc_queue.mli0000644000175000017500000000401114661627530017042 0ustar kylekyle(** Lock-free multi-producer, single-consumer, domain-safe queue without support for cancellation. This makes a good data structure for a scheduler's run queue and is currently (September 2022) used for Eio's scheduler. *) type 'a t (** A queue of items of type ['a]. *) exception Closed val create : unit -> 'a t (** [create ()] returns a new empty queue. *) val is_empty : 'a t -> bool (** [is_empty q] is [true] if calling [pop] would return [None]. @raise Closed if [q] is closed and empty. *) val close : 'a t -> unit (** [close q] marks [q] as closed, preventing any further items from being pushed by the producers (i.e. with {!push}). @raise Closed if [q] has already been closed. *) val push : 'a t -> 'a -> unit (** [push q v] adds the element [v] at the end of the queue [q]. This can be used safely by multiple producer domains, in parallel with the other operations. @raise Closed if [q] is closed. *) (** {2 Consumer-only functions} *) exception Empty (** Raised when {!pop} or {!peek} is applied to an empty queue. *) val pop : 'a t -> 'a (** [pop q] removes and returns the first element in queue [q]. @raise Empty if [q] is empty. @raise Closed if [q] is closed and empty. *) val pop_opt : 'a t -> 'a option (** [pop_opt q] removes and returns the first element in queue [q] or returns [None] if the queue is empty. @raise Closed if [q] is closed and empty. *) val peek : 'a t -> 'a (** [peek q] returns the first element in queue [q]. @raise Empty if [q] is empty. @raise Closed if [q] is closed and empty. *) val peek_opt : 'a t -> 'a option (** [peek_opt q] returns the first element in queue [q] or returns [None] if the queue is empty. @raise Closed if [q] is closed and empty. *) val push_head : 'a t -> 'a -> unit (** [push_head q v] adds the element [v] at the head of the queue [q]. This can only be used by the consumer (if run in parallel with {!pop}, the item might be skipped). @raise Closed if [q] is closed and empty. *) saturn-0.5.0/src_lockfree/spsc_queue.mli0000644000175000017500000000004314661627530017051 0ustar kylekyleinclude Spsc_queue_intf.SPSC_queue saturn-0.5.0/src_lockfree/spsc_queue_intf.ml0000644000175000017500000000532314661627530017726 0ustar kylekylemodule type SPSC_queue = sig (** Single producer single consumer queue. *) type 'a t (** Type of single-producer single-consumer non-resizable domain-safe queue that works in FIFO order. *) val create : size_exponent:int -> 'a t (** [create ~size_exponent:int] returns a new queue of maximum size [2^size_exponent] and initially empty. *) val size : 'a t -> int (** [size] returns the size of the queue. This method linearizes only when called from either consumer or producer domain. Otherwise, it is safe to call but provides only an *indication* of the size of the structure. *) (** {1 Producer functions} *) exception Full (** Raised when {!push_exn} is applied to a full queue. This exception is meant to avoid allocations required by an option type. As such, it does not register backtrace information and it is recommended to use the following pattern to catch it. {[ match push_exn q v with | () -> (* ... *) | exception Full -> (* ... *) ]} *) val push_exn : 'a t -> 'a -> unit (** [push q v] adds the element [v] at the end of the queue [q]. This method can be used by at most one domain at a time. @raise Full if the queue is full. *) val try_push : 'a t -> 'a -> bool (** [try_push q v] tries to add the element [v] at the end of the queue [q]. It fails it the queue [q] is full. This method can be used by at most one domain at a time. *) (** {2 Consumer functions} *) exception Empty (** Raised when {!pop_exn} or {!peek_exn} is applied to an empty queue. This exception is meant to avoid allocations required by an option type. As such, it does not register backtrace information and it is recommended to use the following pattern to catch it. {[ match pop_exn q with | value -> (* ... *) | exception Empty -> (* ... *) ]} *) val pop_exn : 'a t -> 'a (** [pop_exn q] removes and returns the first element in queue [q]. This method can be used by at most one domain at a time. @raise Empty if [q] is empty. *) val pop_opt : 'a t -> 'a option (** [pop_opt q] removes and returns the first element in queue [q], or returns [None] if the queue is empty. This method can be used by at most one domain at a time. *) val peek_exn : 'a t -> 'a (** [peek_exn q] returns the first element in queue [q]. This method can be used by at most one domain at a time. @raise Empty if [q] is empty. *) val peek_opt : 'a t -> 'a option (** [peek_opt q] returns the first element in queue [q], or [None] if the queue is empty. This method can be used by at most one domain at a time. *) end saturn-0.5.0/src_lockfree/michael_scott_queue_intf.ml0000644000175000017500000000424514661627530021576 0ustar kylekylemodule type MS_QUEUE = sig (* * Copyright (c) 2015, Théo Laurent * Copyright (c) 2015, KC Sivaramakrishnan * * Permission to use, copy, modify, and/or distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) (** Michael-Scott classic multi-producer multi-consumer queue. All functions are lockfree. It is the recommended starting point when needing FIFO structure. It is inspired by {{: https://www.cs.rochester.edu/~scott/papers/1996_PODC_queues.pdf} Simple, Fast, and Practical Non-Blocking and Blocking Concurrent Queue Algorithms}. *) type 'a t (** The type of lock-free queue. *) val create : unit -> 'a t (** [create ()] returns a new queue, initially empty. *) val is_empty : 'a t -> bool (** [is_empty q] returns empty if [q] is empty. *) val push : 'a t -> 'a -> unit (** [push q v] adds the element [v] at the end of the queue [q]. *) exception Empty (** Raised when {!pop} or {!peek} is applied to an empty queue. *) val pop_exn : 'a t -> 'a (** [pop q] removes and returns the first element in queue [q]. @raise Empty if [q] is empty. *) val pop_opt : 'a t -> 'a option (** [pop_opt q] removes and returns the first element in queue [q], or returns [None] if the queue is empty. *) val peek_exn : 'a t -> 'a (** [peek q] returns the first element in queue [q]. @raise Empty if [q] is empty. *) val peek_opt : 'a t -> 'a option (** [peek_opt q] returns the first element in queue [q], or returns [None] if the queue is empty. *) end saturn-0.5.0/src_lockfree/saturn_lockfree.mli0000644000175000017500000000341314661627530020067 0ustar kylekyle(*--------------------------------------------------------------------------- Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved. Distributed under the ISC license, see terms at the end of the file. saturn 0.5.0 ---------------------------------------------------------------------------*) (*--------------------------------------------------------------------------- Copyright (c) 2016 KC Sivaramakrishnan Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ---------------------------------------------------------------------------*) (* ######## Copyright (c) 2017, Nicolas ASSOUAD ######## *) (** Lock-free data structures for Multicore OCaml *) (** {1 Data structures} *) module Queue = Michael_scott_queue module Queue_unsafe = Michael_scott_queue_unsafe module Stack = Treiber_stack module Work_stealing_deque = Ws_deque module Single_prod_single_cons_queue = Spsc_queue module Single_prod_single_cons_queue_unsafe = Spsc_queue_unsafe module Single_consumer_queue = Mpsc_queue module Relaxed_queue = Mpmc_relaxed_queue module Skiplist = Skiplist module Size = Size saturn-0.5.0/src_lockfree/atomic.without_contended.ml0000644000175000017500000000006114661627530021525 0ustar kylekyleinclude Stdlib.Atomic let make_contended = make saturn-0.5.0/src_lockfree/michael_scott_queue.mli0000644000175000017500000000005214661627530020717 0ustar kylekyleinclude Michael_scott_queue_intf.MS_QUEUE saturn-0.5.0/src_lockfree/dune0000644000175000017500000000076014661627530015056 0ustar kylekyle(* -*- tuareg -*- *) let maybe_threads = if Jbuild_plugin.V1.ocaml_version < "5" then "threads.posix" else "" let () = Jbuild_plugin.V1.send @@ {| (library (name saturn_lockfree) (public_name saturn_lockfree) (libraries backoff multicore-magic |} ^ maybe_threads ^ {| )) (rule (enabled_if (< %{ocaml_version} 5.0.0)) (action (copy domain.ocaml4.ml domain.ml))) (rule (enabled_if (< %{ocaml_version} 5.2.0)) (action (copy atomic.without_contended.ml atomic.ml))) |} saturn-0.5.0/src_lockfree/michael_scott_queue_unsafe_node.ml0000644000175000017500000000055414661627530023123 0ustar kylekylemodule Atomic = Multicore_magic.Transparent_atomic type ('a, _) t = | Nil : ('a, [> `Nil ]) t | Next : { mutable next : ('a, [ `Nil | `Next ]) t; mutable value : 'a; } -> ('a, [> `Next ]) t let[@inline] make value = Next { next = Nil; value } external as_atomic : ('a, [ `Next ]) t -> ('a, [ `Nil | `Next ]) t Atomic.t = "%identity" saturn-0.5.0/src_lockfree/ws_deque.mli0000644000175000017500000000366414661627530016525 0ustar kylekyle(** Lock-free single-producer, multi-consumer dynamic-size double-ended queue (deque). The main strength of deque in a typical work-stealing setup with per-core structure is efficient work distribution. Owner uses [push] and [pop] method to operate at one end of the deque, while other (free) cores can efficiently steal work on the other side. This approach is great for throughput. Stealers and owner working on different sides reduces contention in work distribution. Further, local LIFO order runs related tasks one after one improves locality. On the other hand, the local LIFO order does not offer any fairness guarantees. Thus, it is not the best choice when tail latency matters. *) module type S = sig type 'a t (** Type of work-stealing queue *) val create : unit -> 'a t (** [create ()] returns a new empty work-stealing queue. *) (** {1 Queue owner functions} *) val push : 'a t -> 'a -> unit (** [push t v] adds [v] to the front of the queue [q]. It should only be invoked by the domain which owns the queue [q]. *) val pop : 'a t -> 'a (** [pop q] removes and returns the first element in queue [q].It should only be invoked by the domain which owns the queue [q]. @raise Exit if the queue is empty. *) val pop_opt : 'a t -> 'a option (** [pop_opt q] removes and returns the first element in queue [q], or returns [None] if the queue is empty. *) (** {1 Stealers function} *) val steal : 'a t -> 'a (** [steal q] removes and returns the last element from queue [q]. It should only be invoked by domain which doesn't own the queue [q]. @raise Exit if the queue is empty. *) val steal_opt : 'a t -> 'a option (** [steal_opt q] removes and returns the last element from queue [q], or returns [None] if the queue is empty. It should only be invoked by domain which doesn't own the queue [q]. *) end module M : S saturn-0.5.0/src_lockfree/mpsc_queue.ml0000644000175000017500000001230214661627530016673 0ustar kylekyle(* A lock-free multi-producer, single-consumer, thread-safe queue without support for cancellation. This makes a good data structure for a scheduler's run queue. See: "Implementing lock-free queues" https://people.cs.pitt.edu/~jacklange/teaching/cs2510-f12/papers/implementing_lock_free.pdf It is simplified slightly because we don't need multiple consumers. Therefore [head] is not atomic. *) exception Closed module Node : sig type 'a t = { next : 'a opt Atomic.t; mutable value : 'a } and +'a opt val make : next:'a opt -> 'a -> 'a t val none : 'a opt (** [t.next = none] means that [t] is currently the last node. *) val closed : 'a opt (** [t.next = closed] means that [t] will always be the last node. *) val some : 'a t -> 'a opt val fold : 'a opt -> none:(unit -> 'b) -> some:('a t -> 'b) -> 'b end = struct (* https://github.com/ocaml/RFCs/pull/14 should remove the need for magic here *) type +'a opt (* special | 'a t *) type 'a t = { next : 'a opt Atomic.t; mutable value : 'a } type special = Nothing | Closed let none : 'a. 'a opt = Obj.magic Nothing let closed : 'a. 'a opt = Obj.magic Closed let some (t : 'a t) : 'a opt = Obj.magic t let fold (opt : 'a opt) ~none:n ~some = if opt == none then n () else if opt == closed then raise Closed else some (Obj.magic opt : 'a t) let make ~next value = { value; next = Atomic.make next } end type 'a t = { tail : 'a Node.t Atomic.t; mutable head : 'a Node.t } (* [head] is the last node dequeued (or a dummy node, initially). [head.next] gives the real first node, if not [Node.none]. If [tail.next] is [none] then it is the last node in the queue. Otherwise, [tail.next] is a node that is closer to the tail. *) let push t x = let node = Node.(make ~next:none) x in let rec aux () = let p = Atomic.get t.tail in (* While [p.next == none], [p] is the last node in the queue. *) if Atomic.compare_and_set p.next Node.none (Node.some node) then (* [node] has now been added to the queue (and possibly even consumed). Update [tail], unless someone else already did it for us. *) ignore (Atomic.compare_and_set t.tail p node : bool) else (* Someone else added a different node first ([p.next] is not [none]). Make [t.tail] more up-to-date, if it hasn't already changed, and try again. *) Node.fold (Atomic.get p.next) ~none:(fun () -> assert false) ~some:(fun p_next -> ignore (Atomic.compare_and_set t.tail p p_next : bool); aux ()) in aux () let rec push_head t x = let p = t.head in let next = Atomic.get p.next in if next == Node.closed then raise Closed; let node = Node.make ~next x in if Atomic.compare_and_set p.next next (Node.some node) then if (* We don't want to let [tail] get too far behind, so if the queue was empty, move it to the new node. *) next == Node.none then ignore (Atomic.compare_and_set t.tail p node : bool) else ( (* If the queue wasn't empty, there's nothing to do. Either tail isn't at head or there is some [push] thread working to update it. Either [push] will update it directly to the new tail, or will update it to [node] and then retry. Either way, it ends up at the real tail. *) ) else ( (* Someone else changed it first. This can only happen if the queue was empty. *) assert (next == Node.none); push_head t x) let rec close (t : 'a t) = (* Mark the tail node as final. *) let p = Atomic.get t.tail in if not (Atomic.compare_and_set p.next Node.none Node.closed) then (* CAS failed because [p] is no longer the tail (or is already closed). *) Node.fold (Atomic.get p.next) ~none:(fun () -> assert false) (* Can't switch from another state to [none] *) ~some:(fun p_next -> (* Make [tail] more up-to-date if it hasn't changed already *) ignore (Atomic.compare_and_set t.tail p p_next : bool); (* Retry *) close t) let pop_opt t = let p = t.head in (* [p] is the previously-popped item. *) let node = Atomic.get p.next in Node.fold node ~none:(fun () -> None) ~some:(fun node -> t.head <- node; let v = node.value in node.value <- Obj.magic (); (* So it can be GC'd *) Some v) exception Empty let pop t = let p = t.head in (* [p] is the previously-popped item. *) let node = Atomic.get p.next in Node.fold node ~none:(fun () -> raise Empty) ~some:(fun node -> t.head <- node; let v = node.value in node.value <- Obj.magic (); (* So it can be GC'd *) v) let peek_opt t = let p = t.head in (* [p] is the previously-popped item. *) let node = Atomic.get p.next in Node.fold node ~none:(fun () -> None) ~some:(fun node -> Some node.value) let peek t = let p = t.head in (* [p] is the previously-popped item. *) let node = Atomic.get p.next in Node.fold node ~none:(fun () -> raise Empty) ~some:(fun node -> node.value) let is_empty t = Node.fold (Atomic.get t.head.next) ~none:(fun () -> true) ~some:(fun _ -> false) let create () = let dummy = { Node.value = Obj.magic (); next = Atomic.make Node.none } in { tail = Atomic.make dummy; head = dummy } saturn-0.5.0/src_lockfree/size.ml0000644000175000017500000001601214661627530015501 0ustar kylekyle(* Copyright (c) 2023 Vesa Karvonen Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) (** ⚠️ Beware that this implementation uses a bunch of low level data representation tricks to minimize overheads. *) module Atomic = Multicore_magic.Transparent_atomic let max_value = Int.max_int module Snapshot = struct type t = int Atomic.t array (** We use an optimized flat representation where the first element of the array holds the status of the snapshot. +--------+---------+---------+---------+- - - | status | counter | counter | counter | ... +--------+---------+---------+---------+- - - The status is either {!collecting}, {!computing}, or a non-negative value. The counter snapshot values are initialized to a negative value and after collecting they will all be non-negative. *) let zero = [| Atomic.make 0 |] let collecting = -1 let computing = -2 let[@inline] is_collecting (s : t) = Atomic.get (Array.unsafe_get s 0) = collecting let create n = Array.init n @@ fun _ -> Atomic.make collecting let[@inline] set s i after = let snap = Array.unsafe_get s i in let after = after land max_value in let before = Atomic.get snap in if before = collecting || (* NOTE: The condition below accounts for overflow. *) (after - before - 1) land max_value < max_value / 2 then Atomic.compare_and_set snap before after |> ignore let[@inline] forward s i after = let snap = Array.unsafe_get s i in let after = after land max_value in while let before = Atomic.get snap in (before = collecting || (* NOTE: The condition below accounts for overflow. *) (after - before - 1) land max_value < max_value / 2) && not (Atomic.compare_and_set snap before after) do () done let rec compute s sum i = if 0 < i then (* NOTE: Operations below are in specific order for performance. *) let decr = Array.unsafe_get s i in let incr = Array.unsafe_get s (i + 1) in let decr = Atomic.get decr in let incr = Atomic.get incr in compute s (sum - decr + incr) (i - 2) else sum land max_value let compute s = compute s 0 (Array.length s - 2) let compute s = let status = Array.unsafe_get s 0 in if Atomic.get status = collecting then Atomic.compare_and_set status collecting computing |> ignore; if Atomic.get status = computing then begin let computed = compute s in if Atomic.get status = computing then Atomic.compare_and_set status computing computed |> ignore end; Atomic.get status end type _ state = | Open : { mutable index : int } -> [ `Open ] state | Used : [ `Used ] state let used_index = 0 type tx = { value : int; once : [ `Open ] state } type t = tx Atomic.t array Atomic.t (** We use an optimized flat representation where the first element of the array holds a reference to the snapshot and the other elements are the counters. +----------+------+------+------+------+- - - | snapshot | decr | incr | decr | incr | ... +----------+------+------+------+------+- - - Counters at odd numbered indices are for [decr]ements and the counters at even numbered indices are for [incr]ements. A counter refers to a unique [tx] record. *) let[@inline] snapshot_of txs : Snapshot.t Atomic.t = Obj.magic (Array.unsafe_get txs 0) (* *) let zero = { value = 0; once = Open { index = used_index } } let create () = Array.init ((1 * 2) + 1) (fun i -> Atomic.make (if i = 0 then Obj.magic Snapshot.zero else zero) |> Multicore_magic.copy_as_padded) |> Atomic.make |> Multicore_magic.copy_as_padded (* *) type once = Once : _ state -> once [@@unboxed] let get_index (Open r) = r.index let use_index (Open r) = r.index <- used_index (* *) let used_once = Once Used (* *) type update = int let decr = 1 let incr = 2 let rec new_once t update = let index = (Multicore_magic.instantaneous_domain_index () * 2) + update in let txs = Atomic.fenceless_get t in let n = Array.length txs in if index < n then Once (Open { index }) else let txs_new = (* The length of [txs_new] will be a power of two minus 1, which means the whole heap block will have a power of two number of words, which may help to keep it cache line aligned. *) Array.init ((n * 2) + 1) @@ fun i -> if i = 0 then Obj.magic (Multicore_magic.copy_as_padded @@ Atomic.make Snapshot.zero) else if i < n then Array.unsafe_get txs i else Multicore_magic.copy_as_padded (Atomic.make zero) in Atomic.compare_and_set t txs txs_new |> ignore; new_once t update let new_once t update = let index = (Multicore_magic.instantaneous_domain_index () * 2) + update in let txs = Atomic.fenceless_get t in if index < Array.length txs then Once (Open { index }) else new_once t update (* *) let rec update_once txs once counter = let before = Atomic.get counter in let index = get_index once in if index != used_index && before.once != once then begin use_index before.once; let after = { value = before.value + 1; once } in if Atomic.compare_and_set counter before after then begin let snapshot = Atomic.get (snapshot_of txs) in if Snapshot.is_collecting snapshot then Snapshot.forward snapshot index after.value end else update_once txs once (Array.unsafe_get txs index) end let update_once t = function | Once Used -> () | Once (Open _ as once) -> let index = get_index once in if index != used_index then let txs = Atomic.fenceless_get t in update_once txs once (Array.unsafe_get txs index) (* *) let get_collecting_snapshot txs = let snapshot = snapshot_of txs in let before = Atomic.get snapshot in if Snapshot.is_collecting before then before else let after = Snapshot.create (Array.length txs) in if Atomic.compare_and_set snapshot before after then after else Atomic.get snapshot let rec collect txs snapshot i = if 0 < i then begin let after = Atomic.get (Array.unsafe_get txs i) in Snapshot.set snapshot i after.value; collect txs snapshot (i - 1) end let rec get t = let txs = Atomic.fenceless_get t in let snapshot = get_collecting_snapshot txs in collect txs snapshot (Array.length txs - 1); let size = Snapshot.compute snapshot in if Atomic.fenceless_get t == txs then size else get t saturn-0.5.0/src_lockfree/spsc_queue_unsafe.mli0000644000175000017500000000004314661627530020412 0ustar kylekyleinclude Spsc_queue_intf.SPSC_queue saturn-0.5.0/src_lockfree/size.mli0000644000175000017500000001301014661627530015645 0ustar kylekyle(** Wait-free size counter for lock-free data structures This is inspired by the paper {{:https://arxiv.org/pdf/2209.07100.pdf} Concurrent Size} by Gal Sela and Erez Petrank and users may find the paper and, in particular, the figure 3 of a transformed data structure in the paper enlightening. The algorithm used by this module differs from {{:https://arxiv.org/pdf/2209.07100.pdf} the paper} in some important ways. First of all, unlike in the paper, the algorithm does not require the number of threads to be limited and given unique integer indices to ensure correctness. Instead, the algorithm uses a lock-free transactional approach to performing the counter {{!update_once} updates at most once}. Another difference is that the algorithm is also designed to give correct answer in case of internal counter overflow. Consider the following singly linked list representation and internal [try_find] operation: {[ type 'a node = | Null | Node of { next : 'a node Atomic.t; datum : 'a; } | Mark of { node : 'a node; } type 'a t = { head : 'a node Atomic.t; } let rec try_find t prev datum = function | Mark _ -> try_find t t.head datum (Atomic.get t.head) | Null -> Null | Node r as node -> begin match Atomic.get r.next with | Mark r -> if Atomic.compare_and_set prev node r.node then try_find t prev datum r.node else try_find t prev datum (Atomic.get prev) | (Null | Node _) as next -> if r.datum == datum then node else try_find t r.next datum next end ]} To enhance the list with size, a [size] counter is added to the list, an [incr] update is added to nodes, a [decr] update is added to marked links from nodes to be removed, and [try_find] is enhanced to perform the updates once after witnessing the updates while traversing the data structure: {[ type 'a node = | Null | Node of { next : 'a node Atomic.t; datum : 'a; mutable incr : Size.once; (* ADDED *) } | Mark of { node : 'a node; decr : Size.once; (* ADDED *) } type 'a t = { head : 'a node Atomic.t; size : Size.t; (* ADDED *) } let rec try_find t prev datum = function | Mark _ -> try_find t t.head datum (Atomic.get t.head) | Null -> Null | Node r as node -> begin match Atomic.get r.next with | Mark r -> Size.update_once t.size r.decr; (* ADDED *) if Atomic.compare_and_set prev node r.node then try_find t prev datum r.node else try_find t prev datum (Atomic.get prev) | (Null | Node _) as next -> if r.datum == datum then begin if r.incr != Size.used_once then begin Size.update_once t.size r.incr; (* ADDED *) r.incr <- Size.used_once end; node end else try_find t r.next datum next end ]} Notice how the mutable [incr] field is tested against and overwritten with {!used_once} after being performed. This can improve performance as nodes are potentially witnessed many times over their lifetime unlike the marked links which are removed as soon as possible. All operations that witness a particular node or the removal of a node must perform the updates of the size counter. This ensures that the commit point of the operations becomes the update of the size counter. This approach is general enough to enhance many kinds of lock-free data structures with a correct (linearizable) size. *) type t (** The type of a size counter. *) val create : unit -> t (** [create ()] allocates a new size counter. The initial value of the size counter will be [0]. *) type once (** The type of an at most once update of a size counter. *) val used_once : once (** [used_once] is a constant for an at most {!once} update that has already been used. *) type update [@@immediate] (** The type of an update on a size counter. *) val decr : update (** [decr] is an update that decrements a size counter. *) val incr : update (** [incr] is an update that increments a size counter. *) val new_once : t -> update -> once (** [new_once size update] creates a new at most {!once} update that, when passed to {!update_once}, will perform the [update] on the [size] counter. ⚠️ When calling {!update_once} the same [size] counter must be used. *) val update_once : t -> once -> unit (** [update_once size once] performs the update, increment or decrement, of the [size] counter at most [once]. ⚠️ The [once] update must be either {!used_once} or must have been created by {!new_once} with the same [size] counter. *) val max_value : int (** [max_value] is the maximum value of a counter. *) val get : t -> int (** [get size] computes and returns the current value of the size counter. The value will always be a non-negative value between [0] and [max_value]. The computation is done in a wait-free manner, which means that parallel updates of the size counter cannot force [get size] to starve nor can parallel computations of the size force counter updates to starve. *) saturn-0.5.0/src_lockfree/treiber_stack.mli0000644000175000017500000000152714661627530017526 0ustar kylekyle(** Classic multi-producer multi-consumer Treiber stack. All function are lockfree. It is the recommended starting point when needing LIFO structure. *) type 'a t (** Type of Treiber stack holding items of type [t]. *) val create : unit -> 'a t (** [create ()] returns a new and empty Treiber stack. *) val is_empty : 'a t -> bool (** [is_empty s] checks whether stack [s] is empty. *) val push : 'a t -> 'a -> unit (** [push s v] adds the element [v] at the top of stack [s]. *) exception Empty (** Raised when {!pop} is applied to an empty queue. *) val pop : 'a t -> 'a (** [pop s] removes and returns the topmost element in the stack [s]. @raise Empty if [a] is empty. *) val pop_opt : 'a t -> 'a option (** [pop_opt s] removes and returns the topmost element in the stack [s], or returns [None] if the stack is empty. *) saturn-0.5.0/src_lockfree/skiplist.ml0000644000175000017500000003242114661627530016373 0ustar kylekyle(* Copyright (c) 2023 Vesa Karvonen Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) (* This implementation has been written from scratch with inspiration from a lock-free skiplist implementation in PR https://github.com/ocaml-multicore/saturn/pull/65 by Sooraj Srinivasan ( https://github.com/sooraj-srini ) including tests and changes by Carine Morel ( https://github.com/lyrm ). *) (* TODO: Grow and possibly shrink the skiplist or e.g. adjust search and node generation based on the dynamic number of bindings. *) module Atomic = Multicore_magic.Transparent_atomic (* OCaml doesn't allow us to use one of the unused (always 0) bits in pointers for the marks and an indirection is needed. This representation avoids the indirection except for marked references in nodes to be removed. A GADT with polymorphic variants is used to disallow nested [Mark]s. *) type ('k, 'v, _) node = | Null : ('k, 'v, [> `Null ]) node | Node : { key : 'k; value : 'v; next : ('k, 'v) links; mutable incr : Size.once; } -> ('k, 'v, [> `Node ]) node | Mark : { node : ('k, 'v, [< `Null | `Node ]) node; decr : Size.once; } -> ('k, 'v, [> `Mark ]) node (* The implementation relies on this existential being unboxed. More specifically, it is assumed that [Link node == Link node] meaning that the [Link] constructor does not allocate. *) and ('k, 'v) link = | Link : ('k, 'v, [< `Null | `Node | `Mark ]) node -> ('k, 'v) link [@@unboxed] and ('k, 'v) links = ('k, 'v) link Atomic.t array type 'k compare = 'k -> 'k -> int (* Encoding the [compare] function using an algebraic type would allow the overhead of calling a closure to be avoided for selected primitive types like [int]. *) type ('k, 'v) t = { compare : 'k compare; root : ('k, 'v) links; size : Size.t } (* *) (** [get_random_height max_height] gives a random value [n] in the range from [1] to [max_height] with the desired distribution such that [n] is twice as likely as [n + 1]. *) let rec get_random_height max_height = let m = (1 lsl max_height) - 1 in let x = Random.bits () land m in if x = 1 then (* We reject [1] to get the desired distribution. *) get_random_height max_height else (* We do a binary search for the highest 1 bit. Techniques in Using de Bruijn Sequences to Index a 1 in a Computer Word by Leiserson, Prokop, and Randall could perhaps speed this up a bit, but this is likely not performance critical. *) let n = 0 in let n, x = if 0xFFFF < x then (n + 0x10, x lsr 0x10) else (n, x) in let n, x = if 0x00FF < x then (n + 0x08, x lsr 0x08) else (n, x) in let n, x = if 0x000F < x then (n + 0x04, x lsr 0x04) else (n, x) in let n, x = if 0x0003 < x then (n + 0x02, x lsr 0x02) else (n, x) in let n, _ = if 0x0001 < x then (n + 0x01, x lsr 0x01) else (n, x) in max_height - n (* *) let[@inline] is_marked = function | Link (Mark _) -> true | Link (Null | Node _) -> false (* *) (** [find_path t key preds succs lowest] tries to find the node with the specified [key], updating [preds] and [succs] and removing nodes with marked references along the way, and always descending down to [lowest] level. The boolean return value is only meaningful when [lowest] is given as [0]. *) let rec find_path t key preds succs lowest = let prev = t.root in let level = Array.length prev - 1 in let prev_at_level = Array.unsafe_get prev level in find_path_rec t key prev prev_at_level preds succs level lowest (Atomic.get prev_at_level) and find_path_rec t key prev prev_at_level preds succs level lowest = function | Link Null -> if level < Array.length preds then begin Array.unsafe_set preds level prev_at_level; Array.unsafe_set succs level Null end; lowest < level && let level = level - 1 in let prev_at_level = Array.unsafe_get prev level in find_path_rec t key prev prev_at_level preds succs level lowest (Atomic.get prev_at_level) | Link (Node r as curr) -> begin let next_at_level = Array.unsafe_get r.next level in match Atomic.get next_at_level with | Link (Null | Node _) as next -> let c = t.compare key r.key in if 0 < c then find_path_rec t key r.next next_at_level preds succs level lowest next else begin if level < Array.length preds then begin Array.unsafe_set preds level (Array.unsafe_get prev level); Array.unsafe_set succs level curr end; if lowest < level then let level = level - 1 in let prev_at_level = Array.unsafe_get prev level in find_path_rec t key prev prev_at_level preds succs level lowest (Atomic.get prev_at_level) else begin if level = 0 && r.incr != Size.used_once then begin Size.update_once t.size r.incr; r.incr <- Size.used_once end; 0 = c end end | Link (Mark r) -> (* The [curr_node] is being removed from the skiplist and we help with that. *) if level = 0 then Size.update_once t.size r.decr; find_path_rec t key prev prev_at_level preds succs level lowest (let after = Link r.node in if Atomic.compare_and_set prev_at_level (Link curr) after then after else Atomic.get prev_at_level) end | Link (Mark _) -> (* The node corresponding to [prev] is being removed from the skiplist. This means we might no longer have an up-to-date view of the skiplist and so we must restart the search. *) find_path t key preds succs lowest (* *) (** [find_node t key] tries to find the node with the specified [key], removing nodes with marked references along the way, and stopping as soon as the node is found. *) let rec find_node t key = let prev = t.root in let level = Array.length prev - 1 in let prev_at_level = Array.unsafe_get prev level in find_node_rec t key prev prev_at_level level (Atomic.get prev_at_level) and find_node_rec t key prev prev_at_level level : _ -> (_, _, [< `Null | `Node ]) node = function | Link Null -> if 0 < level then let level = level - 1 in let prev_at_level = Array.unsafe_get prev level in find_node_rec t key prev prev_at_level level (Atomic.get prev_at_level) else Null | Link (Node r as curr) -> begin let next_at_level = Array.unsafe_get r.next level in match Atomic.get next_at_level with | Link (Null | Node _) as next -> let c = t.compare key r.key in if 0 < c then find_node_rec t key r.next next_at_level level next else if 0 = c then begin (* At this point we know the node was not removed, because removal is done in order of descending levels. *) if r.incr != Size.used_once then begin Size.update_once t.size r.incr; r.incr <- Size.used_once end; curr end else if 0 < level then let level = level - 1 in let prev_at_level = Array.unsafe_get prev level in find_node_rec t key prev prev_at_level level (Atomic.get prev_at_level) else Null | Link (Mark r) -> if level = 0 then Size.update_once t.size r.decr; find_node_rec t key prev prev_at_level level (let after = Link r.node in if Atomic.compare_and_set prev_at_level (Link curr) after then after else Atomic.get prev_at_level) end | Link (Mark _) -> find_node t key (* *) let create ?(max_height = 10) ~compare () = (* The upper limit of [30] comes from [Random.bits ()] as well as from limitations with 32-bit implementations. It should not be a problem in practice. *) if max_height < 1 || 30 < max_height then invalid_arg "Skiplist: max_height must be in the range [1, 30]"; let root = Array.init max_height @@ fun _ -> Atomic.make (Link Null) in let size = Size.create () in { compare; root; size } let max_height_of t = Array.length t.root (* *) let find_opt t key = match find_node t key with Null -> None | Node r -> Some r.value (* *) let mem t key = match find_node t key with Null -> false | Node _ -> true (* *) let rec try_add t key value preds succs = (not (find_path t key preds succs 0)) && let (Node r as node : (_, _, [ `Node ]) node) = let next = Array.map (fun succ -> Atomic.make (Link succ)) succs in let incr = Size.new_once t.size Size.incr in Node { key; value; incr; next } in if let succ = Link (Array.unsafe_get succs 0) in Atomic.compare_and_set (Array.unsafe_get preds 0) succ (Link node) then begin if r.incr != Size.used_once then begin Size.update_once t.size r.incr; r.incr <- Size.used_once end; (* The node is now considered as added to the skiplist. *) let rec update_levels level = if Array.length r.next = level then begin if is_marked (Atomic.get (Array.unsafe_get r.next (level - 1))) then begin (* The node we finished adding has been removed concurrently. To ensure that no references we added to the node remain, we call [find_node] which will remove nodes with marked references along the way. *) find_node t key |> ignore end; true end else if let succ = Link (Array.unsafe_get succs level) in Atomic.compare_and_set (Array.unsafe_get preds level) succ (Link node) then update_levels (level + 1) else let _found = find_path t key preds succs level in let rec update_nexts level' = if level' < level then update_levels level else let next = Array.unsafe_get r.next level' in match Atomic.get next with | Link (Null | Node _) as before -> let succ = Link (Array.unsafe_get succs level') in if before != succ then (* It is possible for a concurrent remove operation to have marked the link. *) if Atomic.compare_and_set next before succ then update_nexts (level' - 1) else update_levels level else update_nexts (level' - 1) | Link (Mark _) -> (* The node we were trying to add has been removed concurrently. To ensure that no references we added to the node remain, we call [find_node] which will remove nodes with marked references along the way. *) find_node t key |> ignore; true in update_nexts (Array.length r.next - 1) in update_levels 1 end else try_add t key value preds succs let try_add t key value = let height = get_random_height (Array.length t.root) in let preds = (* Init with [Obj.magic ()] is safe as the array is fully overwritten by [find_path] called at the start of the recursive [try_add]. *) Array.make height (Obj.magic ()) in let succs = Array.make height Null in try_add t key value preds succs (* *) let rec try_remove t key next level link = function | Link (Mark r) -> if level = 0 then begin Size.update_once t.size r.decr; false end else let level = level - 1 in let link = Array.unsafe_get next level in try_remove t key next level link (Atomic.get link) | Link ((Null | Node _) as succ) -> let decr = if level = 0 then Size.new_once t.size Size.decr else Size.used_once in let marked_succ = Mark { node = succ; decr } in if Atomic.compare_and_set link (Link succ) (Link marked_succ) then if level = 0 then (* We have finished marking references on the node. To ensure that no references to the node remain, we call [find_node] which will remove nodes with marked references along the way. *) let _node = find_node t key in true else let level = level - 1 in let link = Array.unsafe_get next level in try_remove t key next level link (Atomic.get link) else try_remove t key next level link (Atomic.get link) let try_remove t key = match find_node t key with | Null -> false | Node { next; _ } -> let level = Array.length next - 1 in let link = Array.unsafe_get next level in try_remove t key next level link (Atomic.get link) (* *) let length t = Size.get t.size saturn-0.5.0/test/0000755000175000017500000000000014661627530012513 5ustar kylekylesaturn-0.5.0/test/README.md0000644000175000017500000000720314661627530013774 0ustar kylekyle### Introduction Several kind of tests are provided for each data structure: - unitary tests and `qcheck` tests: check semantics and expected behaviors with one and more domains; - `STM` tests: also check semantics as well as _linearizability_ for two domains (see [multicoretests library](https://github.com/ocaml-multicore/multicoretests)); - `dscheck` (for lockfree data structures): checks lock-freedom for as many domains as wanted (for two domains most of the time). It is limited to the paths explored by the tests. ### Unitary parallel tests and `QCheck` tests Every data structure should have separate parallel tests for all core operations and for most useful combinations of them to make sure things work the way you expected them to, even in parallel. Inside the parallel tests, it's important to ensure there's a high chance of actual parallel execution. Keep in mind that spawning a domain is an expensive operation: if a domain only launches a few simple operations, it will most likely run in isolation. Here are a few tricks to ensure your tests actually runs with parallelism: - make a domain repeat its operations. In particular, that usually works well when testing a single function. - use the provided [barrier](barrier/barrier.mli) module to make all domains wait for each other before starting (see [these tests for example) ](ws_deque/qcheck_ws_deque.ml)). - if you are still not sure your tests have a good chance to run in parallel, try it in the top level, and use print or outputs to understand what is happening. ### Linearizability test with `STM` (see [multicoretests](https://github.com/ocaml-multicore/multicoretests)) #### How to write `STM` tests ? `STM` tests work by comparing the results of two domains each executing a random list of method calls to a sequential model provided by the user. Most of the time, these tests are easy and quick to write and can catch a lot of bugs. If all domains can use every functions of the tested data structure, you can have a look to [stm test for Treiber's stack](treiber_stack/stm_treiber_stack.ml). If domains have specific roles (producer/consumer/stealer etc..), [this one](ws_deque/stm_ws_deque.ml) is for a work-stealing deque and is a better example. ### Lock-free property with [`dscheck`](https://github.com/ocaml-multicore/dscheck). `dscheck` is a model checker. Each provided test is run multiple times, each time exploring a different interleaving between atomic operations. This checks that there is no `blocking` paths in the ones explored by these tests (if a trace is blocking, the test does not end) #### How is `Atomic` library shadowed ? Dscheck tests need to use dscheck `TracedAtomic` library, which adds effects to `Stdlib.Atomic` to track calls to atomic functions. To make it work, every datastructure implementation is copied in its respective tests directory and compiled using the `dscheck` [atomic library](atomic/atomic.ml). For example, in [ws_deque/dune](ws_deque/dune) : ``` ; Copy implementation file and its dependencies (rule (copy ../../src/ArrayExtra.ml ArrayExtra.ml)) (rule (copy ../../src/ws_deque.ml ws_deque.ml)) ; rule to build dscheck tests (test (name ws_deque_dscheck) (libraries atomic dscheck alcotest) (modules ArrayExtra ws_deque ws_deque_dscheck)) ``` We can see that `dscheck` test compilation does not depend on `lockfree` (since the data structure code is copy-paste in the test directory) but require `atomic` which is the shadowing atomic library. #### What about other progress properties ? Right now, `dscheck` only checks for lock-freedom. In a near future, it should also be able to deal with lock and checks for deadlock-freedom. saturn-0.5.0/test/seqtest/0000755000175000017500000000000014661627530014203 5ustar kylekylesaturn-0.5.0/test/seqtest/README.md0000644000175000017500000000104414661627530015461 0ustar kylekyle## A sequential test of the work-stealing queue This test exercises the work-stealing queue in `Ws_deque` in a purely sequential mode. To compile this test, type `make` or `dune build --profile seqtest`. To run this test, type `make random` or `dune exec --profile seqtest ./seqtest.exe`. The test runs until it is interrupted. This test requires the `monolith` package. Because we do not wish to create a hard dependency on `monolith`, the code in this directory is built by `dune` only when `--profile seqtest` is passed on the command line. saturn-0.5.0/test/seqtest/seqtest.ml0000644000175000017500000000415714661627530016234 0ustar kylekyleopen Monolith open Saturn_lockfree.Work_stealing_deque (* This sequential implementation of stacks serves as a reference. *) (* For efficiency, we implement a bounded deque inside an array. *) (* [bound] is both the maximum size of the deque in the reference implementation and the maximum length of the test scenarios that we use. *) let bound = 1050 module R (* Reference *) = struct (* To avoid difficuties with initialization problem, we specialize our deque: its elements are integers. This is good enough for our purposes. *) type deque = { mutable top : int; mutable bottom : int; data : int array } let default = -1 let create () = let top = 0 and bottom = 0 and data = Array.make bound default in { top; bottom; data } let push deque x = (* The capacity of the array cannot be exceeded because our test scenarios are sufficiently short. *) assert (deque.bottom < bound); deque.data.(deque.bottom) <- x; deque.bottom <- deque.bottom + 1 let pop deque = assert (deque.top <= deque.bottom); if deque.top = deque.bottom then raise Exit else ( deque.bottom <- deque.bottom - 1; let x = deque.data.(deque.bottom) in x) let steal deque = assert (deque.top <= deque.bottom); if deque.top = deque.bottom then raise Exit else let x = deque.data.(deque.top) in deque.top <- deque.top + 1; x end (* The work-stealing queue is the candidate implementation. *) module C (* Candidate *) = M (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. *) let element = sequential () (* Declare an abstract type [stack]. *) let stack = declare_abstract_type () (* Declare the operations. *) let () = let spec = unit ^> stack in declare "create" spec R.create C.create; let spec = stack ^> element ^> unit in declare "push" spec R.push C.push; let spec = stack ^!> element in declare "pop" spec R.pop C.pop; let spec = stack ^!> element in declare "steal" spec R.steal C.steal (* Start the engine! *) let () = let fuel = bound in main fuel saturn-0.5.0/test/seqtest/.gitignore0000644000175000017500000000004014661627530016165 0ustar kylekyleinput output dune-workspace.afl saturn-0.5.0/test/seqtest/Makefile.monolith0000644000175000017500000002617514661627530017506 0ustar kylekyle# This Makefile is used by each of the demos. # Let's use a fixed shell. SHELL := bash # The following variables can be overridden via the command line or in a # Makefile that includes this Makefile. # The variable SWITCH must refer to a version of OCaml that has been # compiled with support for afl instrumentation. ifndef SWITCH SWITCH := 4.11.1+afl endif # The variable SEED_SIZE determines the size (in bytes) of the random # data that we use as an initial input. ifndef SEED_SIZE SEED_SIZE := 16 endif # The variable EXE represents the path of the executable file that must # be tested relative to the current directory (the one where [make] is # run). ifndef EXE EXE := Main.exe endif # The variable WHERE is the directory where the input/ and output/ # subdirectories are created. ifndef WHERE WHERE := . endif # dune options. ifndef DUNEFLAGS DUNEFLAGS := endif DUNEBUILD := dune build --no-print-directory --display quiet $(DUNEFLAGS) # The variable TIMEOUT_COMMAND specifies the name of the timeout command. # We wish to use GNU timeout. We assume that it must be named either # gtimeout or just timeout. TIMEOUT_COMMAND := $(shell \ if command -v gtimeout >/dev/null ; then echo gtimeout ; \ else echo timeout ; fi) # ---------------------------------------------------------------------------- # Go up to the root of the dune project, and compute the location of the # build subdirectory that corresponds to the current directory. BUILD := $(shell \ up=""; down=""; switch="$(SWITCH)"; \ while ! [ -f dune-project ] ; do \ up="../"$$up ; down=/$$(basename $$(pwd))$$down ; \ cd .. ; \ done ; \ path=$$up"_build/"$${switch-default}$$down ; \ echo $$path \ ) # ---------------------------------------------------------------------------- # [make all] compiles the code in an appropriate opam switch. .PHONY: all all: @ $(DUNEBUILD) @check # build src/.merlin, etc. @(echo "(lang dune 2.0)" && \ echo "(context (opam (switch $(SWITCH))))" \ ) > dune-workspace.afl @ $(DUNEBUILD) --workspace dune-workspace.afl . # ---------------------------------------------------------------------------- # [make setup] creates the required opam switch (if necessary) and installs # Monolith in it (if necessary). .PHONY: setup setup: @ if opam switch list | grep '$(SWITCH) ' >/dev/null ; then \ echo "The switch $(SWITCH) already exists." ; \ else \ echo "Creating switch $(SWITCH)..." ; \ opam switch create $(SWITCH) --no-switch ; \ fi ; \ echo "Installing monolith in the switch $(SWITCH)..." ; \ opam install --yes monolith --switch $(SWITCH) # ---------------------------------------------------------------------------- # [make clean] cleans up. .PHONY: clean clean: @ dune clean @ rm -rf $(INPUT) $(OUTPUT) $(OUTPUT).* @ rm -f dune-workspace.afl # ---------------------------------------------------------------------------- # Settings. # Directories for input and output files. INPUT := $(WHERE)/input OUTPUT := $(WHERE)/output CRASHES := \ $(wildcard $(OUTPUT)/crashes/dummy) \ $(wildcard $(OUTPUT)/crashes/id*) \ $(wildcard $(OUTPUT)/*/crashes/id*) \ # This is where dune places the executable file. BINARY := $(BUILD)/$(EXE) # On MacOS, the highest stack size that seems permitted is 65532. STACK := ulimit -s 65532 # ---------------------------------------------------------------------------- # [make prepare] makes preparations for running afl-fuzz. PATTERN := /proc/sys/kernel/core_pattern GOVERNOR := /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor .PHONY: prepare prepare: @ if [[ "$$OSTYPE" == "linux-gnu" ]]; then \ if grep -v -w --quiet core $(PATTERN) || \ grep -v -w --quiet performance $(GOVERNOR) ; then \ echo "Disabling the crash reporter, and changing CPU settings" ; \ echo "so as to maximize performance." ; \ echo "(This uses sudo; you may be asked for your password.)" ; \ sudo bash -c \ 'echo core >$(PATTERN) && \ (echo performance | tee $(GOVERNOR) >/dev/null)' ; \ fi \ fi @ rm -rf $(INPUT) $(OUTPUT) @ mkdir -p $(INPUT) $(OUTPUT)/crashes @ dd if=/dev/urandom bs=$(SEED_SIZE) count=1 > $(INPUT)/dummy 2>/dev/null # ---------------------------------------------------------------------------- # [make test] runs afl-fuzz. # afl-fuzz must be interrupted by Ctrl-C after it has found some crashes # (or after it has run long enough). # afl-fuzz refuses to run if the dummy input file $(INPUT)/dummy happens # to cause a crash right away. This is why we run $(BINARY) once before # attempting to launch afl-fuzz. If this initial run fails, then we copy # $(INPUT)/dummy to $(OUTPUT)/crashes, so as to let [make show] and # [make min] work normally. .PHONY: test test: all prepare @ make test_nodep .PHONY: test_nodep test_nodep: @ if $(BINARY) $(INPUT)/dummy ; then \ $(STACK) && afl-fuzz -i $(INPUT) -o $(OUTPUT) $(BINARY) @@ ; \ else \ exitcode=$$? ; \ cp $(INPUT)/dummy $(OUTPUT)/crashes ; \ exit $$exitcode ; \ fi # ---------------------------------------------------------------------------- # [make random] runs random tests (without using afl-fuzz). # When no file name is given, $(BINARY) reads from /dev/urandom. # It runs in an infinite loop and saves the scenarios that it finds # in the directory output/crashes, in a human-readable form. There # is no need to use [make show] to decode them. .PHONY: random random: all prepare @ make random_nodep .PHONY: random_nodep random_nodep: @ $(BINARY) # ---------------------------------------------------------------------------- # [make unattended] runs either [make test] or [make random], according to the # variable MODE, and interrupts it after a while (TIMEOUT). # It then checks that the outcome is as expected, i.e., some bugs were found, # or no bugs were found, depending on EXPECTING_BUGS (which should be defined # as 0 or 1). TIMEOUT := 20 EXPECTING_BUGS := 0 MODE := test # or: random RED = \033[0;31m NORMAL = \033[0m .PHONY: unattended unattended: all prepare @ echo " $$(pwd)" @ echo " Running unattended for at most $(TIMEOUT) seconds..." @ (($(TIMEOUT_COMMAND) --signal=INT $(TIMEOUT) make $(MODE)_nodep >/dev/null 2>&1) || true) \ | grep -v "aborting" || true @ crashes=`ls $(OUTPUT)/crashes | grep -v README | wc -l` && \ if (( $$crashes > 0 )) ; then \ if (( $(EXPECTING_BUGS) > 0 )) ; then \ echo "[OK] Found $$crashes faults, great." ; \ else \ printf "$(RED)[KO] Found $$crashes faults, but none were expected!\n$(NORMAL)" ; \ exit 1 ; \ fi \ else \ if (( $(EXPECTING_BUGS) > 0 )) ; then \ printf "$(RED)[KO] Found no faults in $(TIMEOUT) seconds, yet some were expected!\n$(NORMAL)" ; \ exit 1 ; \ else \ echo "[OK] Found no faults, great." ; \ fi \ fi # ---------------------------------------------------------------------------- # [make multicore] launches several instances of afl-fuzz in parallel. # Therefore, it is usually faster than [make test]. # The following is a hopefully portable way of finding how many cores we have. CORES := $(shell \ nproc 2>/dev/null || \ sysctl -n hw.ncpu 2>/dev/null || \ getconf _NPROCESSORS_ONLN 2>/dev/null || \ echo 1) # Choose a heuristic number of slaves. SLAVES := $(shell expr $(CORES) - 1) .PHONY: check_enough_cores check_enough_cores: @ echo "We have $(CORES) cores." @ if [[ "$(SLAVES)" -le "0" ]]; then \ echo "Not enough cores! Run 'make test' instead."; exit 1; fi .PHONY: multicore multicore: all prepare check_enough_cores # Run one instance in master mode, and many instances in slave mode. # The only difference between masters and slaves is that the master # performs additional deterministic checks. # All processes are launched in the background. @ $(STACK) && \ echo "Launching $(SLAVES) slave instances..." ; \ for i in `seq $(SLAVES)` ; do \ (afl-fuzz -i $(INPUT) -o $(OUTPUT) -S slave$$i $(BINARY) @@ >/dev/null &) ; \ done ; \ echo "Launching one master instance..." ; \ (afl-fuzz -i $(INPUT) -o $(OUTPUT) -M master $(BINARY) @@ >/dev/null &) ; \ # In the foreground, provide periodic progress reports. while true ; do afl-whatsup $(OUTPUT) ; sleep 3 ; done # [make tmux] runs in multicore mode and uses tmux to show all GUIs at # once in a terminal window. (A large window and a small font size are # needed.) # Repeating [tmux select-layout tiled] after every step seems required; # otherwise, tmux can refuse to split a window, arguing that there is # not enough space. .PHONY: tmux tmux: all prepare check_enough_cores @ $(STACK) && \ tmux new-session -s monolith -d "afl-fuzz -i $(INPUT) -o $(OUTPUT) -S master $(BINARY) @@" ; \ tmux select-layout tiled ; \ for i in `seq $(SLAVES)` ; do \ tmux split-window "afl-fuzz -i $(INPUT) -o $(OUTPUT) -S slave$$i $(BINARY) @@" ; \ tmux select-layout tiled ; \ done ; \ tmux select-layout tiled ; \ tmux attach-session .PHONY: whatsup whatsup: afl-whatsup $(OUTPUT) # ---------------------------------------------------------------------------- # [make show] displays the problems found by afl-fuzz in the previous run. .PHONY: show show: @ $(STACK) && \ (for f in $(CRASHES) ; do \ echo "(* $$f *)"; \ tmp=`mktemp /tmp/crash.XXXX` && \ ($(BINARY) $$f > $$tmp 2>&1 || true) >/dev/null 2>&1 ; \ cat $$tmp ; \ rm $$tmp ; \ echo ; \ done) | more # ---------------------------------------------------------------------------- # [make summary] is like [make show], but postprocesses its output so as to # keep only the last instruction before the crash, and sorts these lines, so # as to determine the length of the shortest instruction sequence that causes # a problem. # If you determine that a crash can be obtained in (say) 4 instructions, then # typing [make show] and searching for "@04: Failure" will allow you to # inspect the scenario that caused this crash. .PHONY: summary summary: @ $(STACK) && \ parallel '$(BINARY) {} 2>/dev/null | grep "Failure" | head -n 1' ::: $(CRASHES) \ | sort -r # ---------------------------------------------------------------------------- # [make min] attempts to minimize the problematic inputs found by # afl-fuzz in the previous run. .PHONY: min min: @ COPY=`mktemp -d $(OUTPUT).XXXX` && rm -rf $(COPY) && \ echo "Saving un-minimized output to $$COPY." && \ cp -rf $(OUTPUT) $$COPY @ $(STACK) && \ parallel 'afl-tmin -i {} -o {} -- $(BINARY) @@' ::: $(CRASHES) # ---------------------------------------------------------------------------- # [make unload] turns off the MacOS Crash Reporter utility. # [make load] turns it on again. # This utility should be OFF for afl-fuzz to work correctly. SL := /System/Library PL := com.apple.ReportCrash .PHONY: unload unload: launchctl unload -w $(SL)/LaunchAgents/$(PL).plist sudo launchctl unload -w $(SL)/LaunchDaemons/$(PL).Root.plist .PHONY: load load: launchctl load -w $(SL)/LaunchAgents/$(PL).plist sudo launchctl load -w $(SL)/LaunchDaemons/$(PL).Root.plist # ---------------------------------------------------------------------------- # [make switch] prints the value of SWITCH. .PHONY: switch switch: @ echo $(SWITCH) # [make binary] prints the value of BINARY. .PHONY: binary binary: @ echo $(BINARY) saturn-0.5.0/test/seqtest/dune0000644000175000017500000000016414661627530015062 0ustar kylekyle(executable (name seqtest) (libraries monolith saturn) (modules seqtest) (enabled_if (= %{profile} seqtest))) saturn-0.5.0/test/seqtest/Makefile0000644000175000017500000000016214661627530015642 0ustar kylekyleSWITCH := $(shell opam switch show) EXE := seqtest.exe DUNEFLAGS := --profile seqtest include ./Makefile.monolith saturn-0.5.0/test/mpmc_relaxed_queue/0000755000175000017500000000000014661627530016357 5ustar kylekylesaturn-0.5.0/test/mpmc_relaxed_queue/test_mpmc_relaxed_queue.ml0000644000175000017500000001263314661627530023621 0ustar kylekylemodule Relaxed_queue = Saturn.Relaxed_queue let smoke_test (push, pop) () = let queue = Relaxed_queue.create ~size_exponent:2 () in (* enqueue 4 *) for i = 1 to 4 do Alcotest.(check bool) "there should be space in the queue" (push queue i) true done; assert (not (push queue 0)); let ({ tail; head; _ } : 'a Relaxed_queue.t) = queue in assert (Atomic.get tail = 4); assert (Atomic.get head = 0); (* dequeue 4 *) for i = 1 to 4 do Alcotest.(check (option int)) "items should come out in FIFO order" (Some i) (pop queue) done; Alcotest.(check (option int)) "queue should be empty" None (pop queue) let two_threads_test (push, pop) () = let queue = Relaxed_queue.create ~size_exponent:2 () in let num_of_elements = 1_000_000 in (* start dequeuer *) let dequeuer = Domain.spawn (fun () -> let i = ref 0 in while !i < num_of_elements do match pop queue with | Some item -> Alcotest.(check int) "popped items should follow FIFO order" item !i; i := !i + 1 | None -> Domain.cpu_relax () done) in (* enqueue *) let i = ref 0 in while !i < num_of_elements do if push queue !i then i := !i + 1 else Domain.cpu_relax () done; Domain.join dequeuer |> ignore; () module Wait_for_others = struct type t = { currently : int Atomic.t; total_expected : int } let init ~total_expected = { currently = Atomic.make 0; total_expected } let wait { currently; total_expected } = Atomic.incr currently; while Atomic.get currently < total_expected do Domain.cpu_relax () done end let taker wfo queue num_of_elements () = Wait_for_others.wait wfo; let i = ref 0 in while !i < num_of_elements do if Option.is_some (Relaxed_queue.Not_lockfree.pop queue) then i := !i + 1 else Domain.cpu_relax () done let pusher wfo queue num_of_elements () = Wait_for_others.wait wfo; let i = ref 0 in while !i < num_of_elements do if Relaxed_queue.Not_lockfree.push queue !i then i := !i + 1 else Domain.cpu_relax () done let run_test num_takers num_pushers () = let queue = Relaxed_queue.create ~size_exponent:3 () in let num_of_elements = 4_000_000 in let wfo = Wait_for_others.init ~total_expected:(num_takers + num_pushers) in let _ = let takers = assert (num_of_elements mod num_takers == 0); let items_per_taker = num_of_elements / num_takers in List.init num_takers (fun _ -> Domain.spawn (taker wfo queue items_per_taker)) in let pushers = assert (num_of_elements mod num_pushers == 0); let items_per_pusher = num_of_elements / num_pushers in List.init num_pushers (fun _ -> Domain.spawn (pusher wfo queue items_per_pusher)) in Sys.opaque_identity (List.map Domain.join (pushers @ takers)) in let ({ array; head; tail; _ } : 'a Relaxed_queue.t) = queue in let head_val = Atomic.get head in let tail_val = Atomic.get tail in Alcotest.(check int) "hd an tl match" head_val tail_val; Array.iter (fun item -> Alcotest.(check (option int)) "ghost item in the queue!" None (Atomic.get item)) array let smoke_test_spinning () = let queue = Relaxed_queue.create ~size_exponent:2 () in (* enqueue 4 *) for i = 1 to 4 do Relaxed_queue.Spin.push queue i done; assert (not (Relaxed_queue.Not_lockfree.push queue 0)); let ({ tail; head; _ } : 'a Relaxed_queue.t) = queue in assert (Atomic.get tail = 4); assert (Atomic.get head = 0); (* dequeue 4 *) for i = 1 to 4 do Alcotest.(check (option int)) "items should come out in FIFO order" (Some i) (Relaxed_queue.Not_lockfree.pop queue) done; Alcotest.(check (option int)) "queue should be empty" None (Relaxed_queue.Not_lockfree.pop queue) let two_threads_spin_test () = let queue = Relaxed_queue.create ~size_exponent:2 () in let num_of_elements = 1_000_000 in (* start dequeuer *) let dequeuer = Domain.spawn (fun () -> for i = 1 to num_of_elements do assert (Relaxed_queue.Spin.pop queue == i) done) in (* enqueue *) for i = 1 to num_of_elements do Relaxed_queue.Spin.push queue i done; Domain.join dequeuer |> ignore; () let doms1 = if Sys.word_size >= 64 then 4 else 1 let doms2 = if Sys.word_size >= 64 then 8 else 1 let () = let open Alcotest in run "Mpmc_queue" (let open Relaxed_queue.Not_lockfree in [ ( "single-thread", [ test_case "is it a queue" `Quick (smoke_test (push, pop)) ] ); ( "validate items", [ test_case "1 prod. 1 cons." `Quick (two_threads_test (push, pop)) ] ); ( "validate indices under load", [ test_case " 4 prod. 4 cons." `Slow (run_test doms1 doms1); test_case " 8 prod. 1 cons." `Slow (run_test doms2 1); test_case " 1 prod. 8 cons." `Slow (run_test 1 doms2); ] ); ] @ let open Relaxed_queue.Not_lockfree.CAS_interface in [ ( "single-thread-CAS-intf", [ test_case "is it a queue" `Quick (smoke_test (push, pop)) ] ); ( "validate items-CAS-intf", [ test_case "1 prod. 1 cons." `Quick (two_threads_test (push, pop)) ] ); ] @ [ ( "single-thread-spinning", [ test_case "is it a queue" `Quick smoke_test_spinning ] ); ( "validate-items-spinning", [ test_case "1 prod. 1 cons" `Quick two_threads_spin_test ] ); ]) saturn-0.5.0/test/mpmc_relaxed_queue/dune0000644000175000017500000000021314661627530017231 0ustar kylekyle(test (package saturn) (name test_mpmc_relaxed_queue) (libraries saturn unix alcotest domain_shims) (modules test_mpmc_relaxed_queue)) saturn-0.5.0/test/stm_run/0000755000175000017500000000000014661627530014202 5ustar kylekylesaturn-0.5.0/test/stm_run/empty.ocaml4.ml0000644000175000017500000000000014661627530017036 0ustar kylekylesaturn-0.5.0/test/stm_run/empty.ocaml5.ml0000644000175000017500000000000014661627530017037 0ustar kylekylesaturn-0.5.0/test/stm_run/stm_run.ocaml4.ml0000644000175000017500000000070614661627530017404 0ustar kylekyleinclude Intf let run ~verbose ~count ~name ?make_domain (module Spec : STM.Spec) = let module Seq = STM_sequential.Make (Spec) in let module Con = STM_thread.Make (Spec) [@alert "-experimental"] in [ [ Seq.agree_test ~count ~name:(name ^ " sequential") ]; (match make_domain with | None -> [ Con.agree_test_conc ~count ~name:(name ^ " concurrent") ] | Some _ -> []); ] |> List.concat |> QCheck_base_runner.run_tests ~verbose saturn-0.5.0/test/stm_run/stm_run.ocaml5.ml0000644000175000017500000000140414661627530017401 0ustar kylekyleinclude Intf let run (type cmd state sut) ~verbose ~count ~name ?make_domain (module Spec : STM.Spec with type cmd = cmd and type state = state and type sut = sut) = let module Seq = STM_sequential.Make (Spec) in let module Dom = struct module Spec = Spec include STM_domain.Make (Spec) end in [ [ Seq.agree_test ~count ~name:(name ^ " sequential") ]; (match make_domain with | None -> [ Dom.agree_test_par ~count ~name:(name ^ " parallel") ] | Some make_domain -> make_domain ~count ~name (module Dom : STM_domain with type Spec.cmd = cmd and type Spec.state = state and type Spec.sut = sut)); ] |> List.concat |> QCheck_base_runner.run_tests ~verbose saturn-0.5.0/test/stm_run/intf.ml0000644000175000017500000000265214661627530015501 0ustar kylekylemodule type STM_domain = sig module Spec : STM.Spec val check_obs : (Spec.cmd * STM.res) list -> (Spec.cmd * STM.res) list -> (Spec.cmd * STM.res) list -> Spec.state -> bool val all_interleavings_ok : Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool val arb_cmds_triple : int -> int -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary val arb_triple : int -> int -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary val arb_triple_asym : int -> int -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary val interp_sut_res : Spec.sut -> Spec.cmd list -> (Spec.cmd * STM.res) list val agree_prop_par : Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool val agree_prop_par_asym : Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool val agree_test_par : count:int -> name:string -> QCheck.Test.t val neg_agree_test_par : count:int -> name:string -> QCheck.Test.t val agree_test_par_asym : count:int -> name:string -> QCheck.Test.t val neg_agree_test_par_asym : count:int -> name:string -> QCheck.Test.t end saturn-0.5.0/test/stm_run/dune0000644000175000017500000000070214661627530015057 0ustar kylekyle(rule (enabled_if %{lib-available:qcheck-stm.domain}) (action (copy stm_run.ocaml5.ml stm_run.ml))) (rule (enabled_if (not %{lib-available:qcheck-stm.domain})) (action (copy stm_run.ocaml4.ml stm_run.ml))) (library (name stm_run) (libraries qcheck-core qcheck-core.runner qcheck-stm.stm qcheck-stm.sequential qcheck-stm.thread (select empty.ml from (qcheck-stm.domain -> empty.ocaml5.ml) (-> empty.ocaml4.ml)))) saturn-0.5.0/test/barrier/0000755000175000017500000000000014661627530014141 5ustar kylekylesaturn-0.5.0/test/barrier/barrier.mli0000644000175000017500000000377714661627530016310 0ustar kylekyle(** A barrier is a synchronisation tool. A barrier of capacity [n] blocks domains until [n] of them are waiting. Then these [n] domains can pass. Then the barrier is reset. Note that this barrier is not starvation-free if there is more domains trying to pass it than its capacity. This module has been written to help make sure that in `qcheck` tests and unitary tests, multiple domains are actually running in parallel. If you try this : {[ let example nb_domain = let printer i () = Format.printf "Domain spawn in %dth position@." i in let domains = List.init nb_domain (fun i -> Domain.spawn (printer i)) in List.iter Domain.join domains ]} you are most likely going to get the number in order (or almost), because printing a line is way much cheaper than spawning a domain. Whereas with the barrier, you should get a random order : {[ let example_with_barrier nb_domain = let barrier = Barrier.create nb_domain in let printer i () = Barrier.await barrier; Format.printf "Domain spawn in %dth position@." i in let domains = List.init nb_domain (fun i -> Domain.spawn (printer i)) in List.iter Domain.join domains ]} It also enables to have rounds such as a domain can not begin a new round before all other domains have finished the previous one. This can be easily observed by changing the printer function in the previous example by this one : {[ let printer i () = Barrier.await barrier; Format.printf "First round - Domain spawn in %dth position@." i; Barrier.await barrier; Format.printf "Second round - Domain spawn in %dth position@." i ]} *) type t val create : int -> t (** [create c] returns a barrier of capacity [c]. *) val await : t -> unit (** A domain calling [await barrier] will only be able to progress past this function once the number of domains waiting at the barrier is egal to its capacity . *) saturn-0.5.0/test/barrier/dune0000644000175000017500000000006414661627530015017 0ustar kylekyle(library (name barrier) (libraries domain_shims)) saturn-0.5.0/test/barrier/barrier.ml0000644000175000017500000000070714661627530016125 0ustar kylekyletype t = { waiters : int Atomic.t; size : int; passed : int Atomic.t } let create n = { waiters = Atomic.make n; size = n; passed = Atomic.make 0 } let await { waiters; size; passed } = if Atomic.fetch_and_add passed 1 = size - 1 then ( Atomic.set passed 0; Atomic.set waiters 0); while Atomic.get waiters = size do Domain.cpu_relax () done; Atomic.incr waiters; while Atomic.get waiters < size do Domain.cpu_relax () done saturn-0.5.0/test/michael_scott_queue/0000755000175000017500000000000014661627530016535 5ustar kylekylesaturn-0.5.0/test/michael_scott_queue/stm_michael_scott_queue.ml0000644000175000017500000000404014661627530023772 0ustar kylekyle(** Sequential and Parallel model-based tests of michael_scott_queue *) module STM_ms_queue (Queue : Ms_queues.MS_queue_tests) = struct open QCheck open STM module Ms_queue = Saturn_lockfree.Queue module Spec = struct type cmd = Push of int | Pop | Peek | Is_empty let show_cmd c = match c with | Push i -> "Push " ^ string_of_int i | Pop -> "Pop" | Peek -> "Peek" | Is_empty -> "Is_empty" type state = int list type sut = int Ms_queue.t let arb_cmd _s = let int_gen = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [ Gen.map (fun i -> Push i) int_gen; Gen.return Pop; Gen.return Peek; Gen.return Is_empty; ]) let init_state = [] let init_sut () = Ms_queue.create () let cleanup _ = () let next_state c s = match c with | Push i -> i :: s | Pop -> ( match List.rev s with [] -> s | _ :: s' -> List.rev s') | Peek | Is_empty -> s let precond _ _ = true let run c d = match c with | Push i -> Res (unit, Ms_queue.push d i) | Pop -> Res (result int exn, protect Ms_queue.pop_exn d) | Peek -> Res (result int exn, protect Ms_queue.peek_exn d) | Is_empty -> Res (bool, Ms_queue.is_empty d) let postcond c (s : state) res = match (c, res) with | Push _, Res ((Unit, _), _) -> true | (Pop | Peek), Res ((Result (Int, Exn), _), res) -> ( match List.rev s with | [] -> res = Error Ms_queue.Empty | j :: _ -> res = Ok j) | Is_empty, Res ((Bool, _), res) -> res = (s = []) | _, _ -> false end let run () = Stm_run.run ~count:500 ~verbose:true ~name:("Saturn_lockfree." ^ Queue.name) (module Spec) end let () = let module Safe = STM_ms_queue (Ms_queues.Michael_scott_queue) in let exit_code = Safe.run () in if exit_code <> 0 then exit exit_code else let module Unsafe = STM_ms_queue (Ms_queues.Michael_scott_queue_unsafe) in Unsafe.run () |> exit saturn-0.5.0/test/michael_scott_queue/michael_scott_queue_dscheck.ml0000644000175000017500000001305714661627530024603 0ustar kylekylemodule Atomic = Dscheck.TracedAtomic module Dscheck_ms_queue (Michael_scott_queue : Michael_scott_queue_intf.MS_QUEUE) = struct let drain queue = let remaining = ref 0 in while not (Michael_scott_queue.is_empty queue) do remaining := !remaining + 1; assert (Option.is_some (Michael_scott_queue.pop_opt queue)) done; !remaining let producer_consumer () = Atomic.trace (fun () -> let queue = Michael_scott_queue.create () in let items_total = 4 in (* producer *) Atomic.spawn (fun () -> for i = 1 to items_total do Michael_scott_queue.push queue i done); (* consumer *) let popped = ref 0 in Atomic.spawn (fun () -> for _ = 1 to items_total do match Michael_scott_queue.pop_opt queue with | None -> () | Some v -> assert (v == !popped + 1); popped := !popped + 1 done); (* checks*) Atomic.final (fun () -> Atomic.check (fun () -> let remaining = drain queue in !popped + remaining = items_total))) let producer_consumer_peek () = Atomic.trace (fun () -> let queue = Michael_scott_queue.create () in let items_total = 1 in let pushed = List.init items_total (fun i -> i) in (* producer *) Atomic.spawn (fun () -> List.iter (fun elt -> Michael_scott_queue.push queue elt) pushed); (* consumer *) let popped = ref [] in let peeked = ref [] in Atomic.spawn (fun () -> for _ = 1 to items_total do peeked := Michael_scott_queue.peek_opt queue :: !peeked; popped := Michael_scott_queue.pop_opt queue :: !popped done); (* checks*) Atomic.final (fun () -> Atomic.check (fun () -> let rec check pushed peeked popped = match (pushed, peeked, popped) with | _, [], [] -> true | _, None :: peeked, None :: popped -> check pushed peeked popped | push :: pushed, None :: peeked, Some pop :: popped when push = pop -> check pushed peeked popped | push :: pushed, Some peek :: peeked, Some pop :: popped when push = peek && push = pop -> check pushed peeked popped | _, _, _ -> false in check pushed (List.rev !peeked) (List.rev !popped)); Atomic.check (fun () -> let remaining = drain queue in let popped = List.filter Option.is_some !popped in List.length popped + remaining = items_total))) let two_producers () = Atomic.trace (fun () -> let queue = Michael_scott_queue.create () in let items_total = 4 in (* producers *) for _ = 1 to 2 do Atomic.spawn (fun () -> for _ = 1 to items_total / 2 do Michael_scott_queue.push queue 0 done) done; (* checks*) Atomic.final (fun () -> Atomic.check (fun () -> let remaining = drain queue in remaining = items_total))) let two_domains () = Atomic.trace (fun () -> let stack = Michael_scott_queue.create () in let n1, n2 = (2, 1) in (* two producers *) let lists = [ (List.init n1 (fun i -> i), ref []); (List.init n2 (fun i -> i + n1), ref []); ] in List.iter (fun (lpush, lpop) -> Atomic.spawn (fun () -> List.iter (fun elt -> (* even nums belong to thr 1, odd nums to thr 2 *) Michael_scott_queue.push stack elt; lpop := Option.get (Michael_scott_queue.pop_opt stack) :: !lpop) lpush) |> ignore) lists; (* checks*) Atomic.final (fun () -> let lpop1 = !(List.nth lists 0 |> snd) in let lpop2 = !(List.nth lists 1 |> snd) in (* got the same number of items out as in *) Atomic.check (fun () -> List.length lpop1 = n1); Atomic.check (fun () -> List.length lpop2 = n2); (* no element are missing *) Atomic.check (fun () -> let l1 = List.filter (fun i -> i < n1) lpop1 in let l2 = List.filter (fun i -> i >= n1) lpop1 in let l3 = List.filter (fun i -> i < n2) lpop2 in let l4 = List.filter (fun i -> i >= n2) lpop2 in let is_sorted l = List.sort (fun a b -> -compare a b) l = l in is_sorted l1 && is_sorted l2 && is_sorted l3 && is_sorted l4))) let tests name = let open Alcotest in [ ( "basic_" ^ name, [ test_case "1-producer-1-consumer" `Slow producer_consumer; test_case "1-producer-1-consumer-peek" `Slow producer_consumer_peek; test_case "2-producers" `Slow two_producers; test_case "2-domains" `Slow two_domains; ] ); ] end let () = let module Safe = Dscheck_ms_queue (Michael_scott_queue) in let safe_test = Safe.tests "safe" in let module Unsafe = Dscheck_ms_queue (Michael_scott_queue_unsafe) in let unsafe_test = Unsafe.tests "unsafe" in let open Alcotest in run "michael_scott_queue_dscheck" (safe_test @ unsafe_test) saturn-0.5.0/test/michael_scott_queue/ms_queues/0000755000175000017500000000000014661627530020543 5ustar kylekylesaturn-0.5.0/test/michael_scott_queue/ms_queues/dune0000644000175000017500000000030314661627530021415 0ustar kylekyle(rule (action (copy ../../../src_lockfree/michael_scott_queue_intf.ml michael_scott_queue_intf.ml)) (package saturn_lockfree)) (library (name ms_queues) (libraries saturn_lockfree)) saturn-0.5.0/test/michael_scott_queue/ms_queues/ms_queues.ml0000644000175000017500000000057414661627530023111 0ustar kylekylemodule type MS_queue_tests = sig include Michael_scott_queue_intf.MS_QUEUE val name : string end module Michael_scott_queue : MS_queue_tests = struct include Saturn_lockfree.Queue let name = "michael_scott_queue_safe" end module Michael_scott_queue_unsafe : MS_queue_tests = struct include Saturn_lockfree.Queue_unsafe let name = "michael_scott_queue_unsafe" end saturn-0.5.0/test/michael_scott_queue/dune0000644000175000017500000000244114661627530017414 0ustar kylekyle(rule (action (copy ../../src_lockfree/michael_scott_queue.ml michael_scott_queue.ml)) (package saturn_lockfree)) (rule (action (copy ../../src_lockfree/michael_scott_queue_unsafe.ml michael_scott_queue_unsafe.ml)) (package saturn_lockfree)) (rule (action (copy ../../src_lockfree/michael_scott_queue_intf.ml michael_scott_queue_intf.ml)) (package saturn_lockfree)) (test (package saturn_lockfree) (name michael_scott_queue_dscheck) (libraries alcotest atomic backoff dscheck multicore-magic-dscheck) (build_if (and (>= %{ocaml_version} 5) (not (and (= %{arch_sixtyfour} false) (= %{architecture} arm))))) (modules michael_scott_queue michael_scott_queue_unsafe michael_scott_queue_unsafe_node michael_scott_queue_intf michael_scott_queue_dscheck) (flags (:standard -open Multicore_magic_dscheck))) (test (package saturn_lockfree) (name qcheck_michael_scott_queue) (libraries ms_queues saturn_lockfree barrier qcheck qcheck-core qcheck-alcotest domain_shims alcotest) (modules qcheck_michael_scott_queue)) (test (package saturn_lockfree) (name stm_michael_scott_queue) (modules stm_michael_scott_queue) (libraries ms_queues saturn_lockfree qcheck-core qcheck-stm.stm stm_run) (enabled_if (= %{arch_sixtyfour} true))) saturn-0.5.0/test/michael_scott_queue/michael_scott_queue_unsafe_node.ml0000644000175000017500000000056614661627530025466 0ustar kylekyleopen Multicore_magic_dscheck module Atomic = Multicore_magic.Transparent_atomic type ('a, _) t = | Nil : ('a, [> `Nil ]) t | Next : { next : ('a, [ `Nil | `Next ]) t Atomic.t; mutable value : 'a; } -> ('a, [> `Next ]) t let[@inline] make value = Next { next = Atomic.make Nil; value } let[@inline] as_atomic (Next r : ('a, [ `Next ]) t) = r.next saturn-0.5.0/test/michael_scott_queue/qcheck_michael_scott_queue.ml0000644000175000017500000002526414661627530024440 0ustar kylekylemodule Qcheck_ms_queue (Queue : Ms_queues.MS_queue_tests) = struct let tests_sequential = QCheck. [ (* TEST 1: push *) Test.make ~name:"push" (list int) (fun lpush -> assume (lpush <> []); (* Building a random queue *) let queue = Queue.create () in List.iter (Queue.push queue) lpush; (* Testing property *) not (Queue.is_empty queue)); (* TEST 2 - push, pop until empty *) Test.make ~name:"push_pop_opt_until_empty" (list int) (fun lpush -> (* Building a random queue *) let queue = Queue.create () in List.iter (Queue.push queue) lpush; (* Popping until [is_empty q] is true *) let count = ref 0 in while not (Queue.is_empty queue) do incr count; ignore (Queue.pop_opt queue) done; (* Testing property *) Queue.pop_opt queue = None && !count = List.length lpush); (* TEST 3 - push, pop_opt, check FIFO *) Test.make ~name:"fifo" (list int) (fun lpush -> (* Building a random queue *) let queue = Queue.create () in List.iter (Queue.push queue) lpush; let out = ref [] in let insert v = out := v :: !out in for _ = 1 to List.length lpush do match Queue.pop_opt queue with | None -> assert false | Some v -> insert v done; (* Testing property *) lpush = List.rev !out); (* TEST 3 - push, pop_opt, peek_opt check FIFO *) Test.make ~name:"fifo_peek_opt" (list int) (fun lpush -> (* Building a random queue *) let queue = Queue.create () in List.iter (Queue.push queue) lpush; let pop = ref [] in let peek = ref [] in let insert out v = out := v :: !out in for _ = 1 to List.length lpush do match Queue.peek_opt queue with | None -> assert false | Some v -> ( insert peek v; match Queue.pop_opt queue with | None -> assert false | Some v -> insert pop v) done; (* Testing property *) lpush = List.rev !pop && lpush = List.rev !peek); ] let tests_one_consumer_one_producer = QCheck. [ (* TEST 1 - one consumer one producer: Parallel [push] and [pop_opt]. *) Test.make ~name:"parallel_fifo" (list int) (fun lpush -> (* Initialization *) let queue = Queue.create () in let barrier = Barrier.create 2 in (* Producer pushes. *) let producer = Domain.spawn (fun () -> Barrier.await barrier; List.iter (Queue.push queue) lpush) in Barrier.await barrier; let fifo = List.fold_left (fun acc item -> let rec pop_one () = match Queue.pop_opt queue with | None -> Domain.cpu_relax (); pop_one () | Some item' -> acc && item = item' in pop_one ()) true lpush in let empty = Queue.is_empty queue in (* Ensure nothing is left behind. *) Domain.join producer; fifo && empty); (* TEST 2 - one consumer one producer: Parallel [push] and [peek_opt] and [pop_opt]. *) Test.make ~name:"parallel_peek" (list int) (fun pushed -> (* Initialization *) let npush = List.length pushed in let queue = Queue.create () in let barrier = Barrier.create 2 in (* Producer pushes. *) let producer = Domain.spawn (fun () -> Barrier.await barrier; List.iter (Queue.push queue) pushed) in let peeked = ref [] in let popped = ref [] in Barrier.await barrier; for _ = 1 to npush do peeked := Queue.peek_opt queue :: !peeked; popped := Queue.pop_opt queue :: !popped done; Domain.join producer; let rec check = function | _, [], [] -> true | pushed, None :: peeked, None :: popped -> check (pushed, peeked, popped) | push :: pushed, None :: peeked, Some pop :: popped when push = pop -> check (pushed, peeked, popped) | push :: pushed, Some peek :: peeked, Some pop :: popped when push = peek && push = pop -> check (pushed, peeked, popped) | _, _, _ -> false in check (pushed, List.rev @@ !peeked, List.rev @@ !popped)); ] let tests_two_domains = QCheck. [ (* TEST 1 - two domains doing multiple times one push then one pop_opt. Parallel [push] and [pop_opt]. *) Test.make ~name:"parallel_pop_opt_push" (pair small_nat small_nat) (fun (npush1, npush2) -> (* Initialization *) let queue = Queue.create () in let barrier = Barrier.create 2 in (* Using these lists instead of a random one enables to check for more properties. *) let lpush1 = List.init npush1 (fun i -> i) in let lpush2 = List.init npush2 (fun i -> i + npush1) in let work lpush = List.map (fun elt -> Queue.push queue elt; Domain.cpu_relax (); Queue.pop_opt queue) lpush in let domain1 = Domain.spawn (fun () -> Barrier.await barrier; work lpush1) in let popped2 = Barrier.await barrier; work lpush2 in (* As a domain always pushs before popping, all pops succeeds. *) let popped1 = Domain.join domain1 |> List.map Option.get in let popped2 = popped2 |> List.map Option.get in (* Check 1 : no elements are missing (everyting is popped). *) let all_elt_in = List.sort compare (popped1 @ popped2) = lpush1 @ lpush2 in (* filter the elements pushed and popped by domain 1 *) let push1_pop1 = List.filter (fun elt -> elt < npush1) popped1 in (* filter the elements pushed by domain 2 and popped by domain 1 *) let push2_pop1 = List.filter (fun elt -> elt >= npush1) popped1 in (* filter the elements pushed by domain 1 and popped by domain 2 *) let push1_pop2 = List.filter (fun elt -> elt < npush1) popped2 in (* filter the elements pushed and popped by domain 2 *) let push2_pop2 = List.filter (fun elt -> elt >= npush1) popped2 in (* all these lists must be sorted *) let is_sorted list = List.sort compare list = list in all_elt_in && is_sorted push1_pop1 && is_sorted push1_pop2 && is_sorted push2_pop1 && is_sorted push2_pop2); (* TEST 2 - Parallel [push] and [pop_opt] with two domains Two domains randomly pushs and pops in parallel. They stop as soon as they have finished pushing a list of element to push. *) Test.make ~name:"parallel_pop_opt_push_random" (pair small_nat small_nat) (fun (npush1, npush2) -> (* Initialization *) let queue = Queue.create () in let barrier = Barrier.create 2 in let lpush1 = List.init npush1 (fun i -> i) in let lpush2 = List.init npush2 (fun i -> i + npush1) in let work lpush = let consecutive_pop = ref 0 in let rec loop lpush popped = let what_to_do = Random.int 2 in if what_to_do = 0 || !consecutive_pop > 10 then ( (* randomly choosing between pushing and popping except if too many consecutive pops have already occurred *) consecutive_pop := 0; match lpush with | [] -> popped | elt :: xs -> Queue.push queue elt; loop xs popped) else ( incr consecutive_pop; let p = Queue.pop_opt queue in loop lpush (p :: popped)) in loop lpush [] in let domain1 = Domain.spawn (fun () -> Barrier.await barrier; work lpush1) in let popped2 = Barrier.await barrier; work lpush2 in let popped1 = Domain.join domain1 |> List.filter (function None -> false | _ -> true) |> List.map Option.get in let popped2 = popped2 |> List.filter (function None -> false | _ -> true) |> List.map Option.get in (* Pop everything that is still on the queue *) let popped3 = let rec loop popped = match Queue.pop_opt queue with | None -> popped | Some v -> loop (v :: popped) in loop [] in (* Check that no element is missing. *) let all_n_elt_in = List.sort compare (popped1 @ popped2 @ popped3) = lpush1 @ lpush2 in all_n_elt_in); ] end let () = let to_alcotest = List.map QCheck_alcotest.to_alcotest in let module Safe = Qcheck_ms_queue (Ms_queues.Michael_scott_queue) in let name = "safe" in let safe_tests = [ ("test_sequential_" ^ name, to_alcotest Safe.tests_sequential); ( "one_cons_one_prod_" ^ name, to_alcotest Safe.tests_one_consumer_one_producer ); ("two_domains_" ^ name, to_alcotest Safe.tests_two_domains); ] in let module Unsafe = Qcheck_ms_queue (Ms_queues.Michael_scott_queue_unsafe) in let name = "unsafe" in let unsafe_tests = [ ("test_sequential_" ^ name, to_alcotest Unsafe.tests_sequential); ( "one_cons_one_prod_" ^ name, to_alcotest Unsafe.tests_one_consumer_one_producer ); ("two_domains_" ^ name, to_alcotest Unsafe.tests_two_domains); ] in Alcotest.run "Michael_scott_queue" (safe_tests @ unsafe_tests) saturn-0.5.0/test/skiplist/0000755000175000017500000000000014661627530014355 5ustar kylekylesaturn-0.5.0/test/skiplist/stm_skiplist.ml0000644000175000017500000000327014661627530017436 0ustar kylekyleopen QCheck open STM module Skiplist = struct include Saturn_lockfree.Skiplist type nonrec 'a t = ('a, unit) t let try_add s k = try_add s k () end module Spec = struct type cmd = Mem of int | Add of int | Remove of int | Length let show_cmd c = match c with | Mem i -> "Mem " ^ string_of_int i | Add i -> "Add " ^ string_of_int i | Remove i -> "Remove " ^ string_of_int i | Length -> "Length" module Sint = Set.Make (Int) type state = Sint.t type sut = int Skiplist.t let arb_cmd _s = let int_gen = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [ Gen.map (fun i -> Add i) int_gen; Gen.map (fun i -> Mem i) int_gen; Gen.map (fun i -> Remove i) int_gen; Gen.return Length; ]) let init_state = Sint.empty let init_sut () = Skiplist.create ~compare:Int.compare () let cleanup _ = () let next_state c s = match c with | Add i -> Sint.add i s | Remove i -> Sint.remove i s | Mem _ -> s | Length -> s let precond _ _ = true let run c d = match c with | Add i -> Res (bool, Skiplist.try_add d i) | Remove i -> Res (bool, Skiplist.try_remove d i) | Mem i -> Res (bool, Skiplist.mem d i) | Length -> Res (int, Skiplist.length d) let postcond c (s : state) res = match (c, res) with | Add i, Res ((Bool, _), res) -> Sint.mem i s = not res | Remove i, Res ((Bool, _), res) -> Sint.mem i s = res | Mem i, Res ((Bool, _), res) -> Sint.mem i s = res | Length, Res ((Int, _), res) -> Sint.cardinal s = res | _, _ -> false end let () = Stm_run.run ~count:1000 ~verbose:true ~name:"Lockfree.Skiplist" (module Spec) |> exit saturn-0.5.0/test/skiplist/qcheck_skiplist.ml0000644000175000017500000001432014661627530020067 0ustar kylekylemodule Skiplist = struct include Saturn_lockfree.Skiplist let try_add s k = try_add s k () end module IntSet = Set.Make (Int) let[@tail_mod_cons] rec uniq ?(seen = IntSet.empty) = function | [] -> [] | x :: xs -> if IntSet.mem x seen then uniq ~seen xs else x :: uniq ~seen:(IntSet.add x seen) xs let tests_sequential = QCheck. [ (* TEST 1: add*) Test.make ~name:"add" (list int) (fun lpush -> let sl = Skiplist.create ~compare:Int.compare () in let rec add_all_elems seen l = match l with | h :: t -> if Skiplist.try_add sl h <> IntSet.mem h seen then add_all_elems (IntSet.add h seen) t else false | [] -> true in add_all_elems IntSet.empty lpush); (*TEST 2: add_remove*) Test.make ~name:"add_remove" (list int) (fun lpush -> let lpush = uniq lpush in let sl = Skiplist.create ~compare:Int.compare () in List.iter (fun key -> ignore (Skiplist.try_add sl key)) lpush; let rec remove_all_elems l = match l with | h :: t -> if Skiplist.try_remove sl h then remove_all_elems t else false | [] -> true in remove_all_elems lpush); (*TEST 3: add_find*) Test.make ~name:"add_find" (list int) (fun lpush -> let lpush = uniq lpush in let lpush = Array.of_list lpush in let sl = Skiplist.create ~compare:Int.compare () in let len = Array.length lpush in let pos = Array.sub lpush 0 (len / 2) in let neg = Array.sub lpush (len / 2) (len / 2) in Array.iter (fun key -> ignore @@ Skiplist.try_add sl key) pos; let rec check_pos index = if index < len / 2 then if Skiplist.mem sl pos.(index) then check_pos (index + 1) else false else true in let rec check_neg index = if index < len / 2 then if not @@ Skiplist.mem sl neg.(index) then check_neg (index + 1) else false else true in check_pos 0 && check_neg 0); (* TEST 4: add_remove_find *) Test.make ~name:"add_remove_find" (list int) (fun lpush -> let lpush = uniq lpush in let sl = Skiplist.create ~compare:Int.compare () in List.iter (fun key -> ignore @@ Skiplist.try_add sl key) lpush; List.iter (fun key -> ignore @@ Skiplist.try_remove sl key) lpush; let rec not_find_all_elems l = match l with | h :: t -> if not @@ Skiplist.mem sl h then not_find_all_elems t else false | [] -> true in not_find_all_elems lpush); ] let tests_two_domains = QCheck. [ (* TEST 1: Two domains doing multiple adds *) Test.make ~name:"parallel_add" (pair small_nat small_nat) (fun (npush1, npush2) -> let sl = Skiplist.create ~compare:Int.compare () in let barrier = Barrier.create 2 in let lpush1 = List.init npush1 (fun i -> i) in let lpush2 = List.init npush2 (fun i -> i + npush1) in let work lpush = List.map (Skiplist.try_add sl) lpush in let domain1 = Domain.spawn @@ fun () -> Barrier.await barrier; work lpush1 in let popped2 = Barrier.await barrier; work lpush2 in let popped1 = Domain.join domain1 in let rec compare_all_true l = match l with | true :: t -> compare_all_true t | false :: _ -> false | [] -> true in compare_all_true popped1 && compare_all_true popped2); (* TEST 2: Two domains doing multiple one push and one pop in parallel *) Test.make ~count:10000 ~name:"parallel_add_remove" (pair small_nat small_nat) (fun (npush1, npush2) -> let sl = Skiplist.create ~compare:Int.compare () in let barrier = Barrier.create 2 in let lpush1 = List.init npush1 (fun i -> i) in let lpush2 = List.init npush2 (fun i -> i + npush1) in let work lpush = List.iter (fun elt -> assert (Skiplist.try_add sl elt); assert (Skiplist.try_remove sl elt)) lpush in let domain1 = Domain.spawn @@ fun () -> Barrier.await barrier; work lpush1 in let () = Barrier.await barrier; work lpush2 in let () = Domain.join domain1 in let rec check_none_present l = match l with | h :: t -> if Skiplist.mem sl h then false else check_none_present t | [] -> true in check_none_present lpush1 && check_none_present lpush2); (* TEST 3: Parallel push and pop using the same elements in two domains *) Test.make ~name:"parallel_add_remove_same_list" (list int) (fun lpush -> let sl = Skiplist.create ~compare:Int.compare () in let barrier = Barrier.create 2 in let add_all_elems l = List.iter (fun elt -> Skiplist.try_add sl elt |> ignore) l in let remove_all_elems l = List.iter (fun elt -> Skiplist.try_remove sl elt |> ignore) l in let domain1 = Domain.spawn @@ fun () -> Barrier.await barrier; add_all_elems lpush; remove_all_elems lpush in let () = Barrier.await barrier; add_all_elems lpush; remove_all_elems lpush in let () = Domain.join domain1 in let rec check_none_present l = match l with | h :: t -> if Skiplist.mem sl h then false else check_none_present t | [] -> true in check_none_present lpush); ] let () = let to_alcotest = List.map QCheck_alcotest.to_alcotest in Alcotest.run "QCheck Skiplist" [ ("test_sequential", to_alcotest tests_sequential); ("tests_two_domains", to_alcotest tests_two_domains); ] saturn-0.5.0/test/skiplist/dune0000644000175000017500000000134114661627530015232 0ustar kylekyle(rule (action (progn (copy ../../src_lockfree/skiplist.ml skiplist.ml) (copy ../../src_lockfree/size.ml size.ml))) (package saturn_lockfree)) (test (package saturn_lockfree) (name dscheck_skiplist) (modules skiplist size dscheck_skiplist) (build_if (>= %{ocaml_version} 5)) (libraries alcotest dscheck multicore-magic-dscheck) (flags (:standard -open Multicore_magic_dscheck))) (test (package saturn_lockfree) (name qcheck_skiplist) (modules qcheck_skiplist) (libraries saturn_lockfree barrier qcheck qcheck-core qcheck-alcotest alcotest domain_shims)) (test (package saturn_lockfree) (name stm_skiplist) (modules stm_skiplist) (libraries saturn_lockfree qcheck-core qcheck-stm.stm stm_run)) saturn-0.5.0/test/skiplist/dscheck_skiplist.ml0000644000175000017500000000673514661627530020250 0ustar kylekyleopen Skiplist module Atomic = Dscheck.TracedAtomic (** This is needed in this order as the skiplist.ml file contains {[ module Atomic = Multicore_magic.Transparent_atomic ]} which is in multicore-magic-dscheck library only a subset of [Dscheck.TracedAtomic] function. *) let test_max_height_of () = let s = create ~max_height:1 ~compare () in assert (max_height_of s = 1); let s = create ~max_height:10 ~compare () in assert (max_height_of s = 10); let s = create ~max_height:30 ~compare () in assert (max_height_of s = 30) let try_add s k = try_add s k () let _two_mem () = Atomic.trace (fun () -> Random.init 0; let sl = create ~max_height:2 ~compare:Int.compare () in let added1 = ref false in let found1 = ref false in let found2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1; found1 := mem sl 1); Atomic.spawn (fun () -> found2 := mem sl 2); Atomic.final (fun () -> Atomic.check (fun () -> !added1 && !found1 && not !found2))) let _two_add () = Atomic.trace (fun () -> Random.init 0; let sl = create ~max_height:3 ~compare:Int.compare () in let added1 = ref false in let added2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1); Atomic.spawn (fun () -> added2 := try_add sl 2); Atomic.final (fun () -> Atomic.check (fun () -> !added1 && !added2 && mem sl 1 && mem sl 2))) let _two_add_same () = Atomic.trace (fun () -> Random.init 0; let sl = create ~max_height:3 ~compare:Int.compare () in let added1 = ref false in let added2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1); Atomic.spawn (fun () -> added2 := try_add sl 1); Atomic.final (fun () -> Atomic.check (fun () -> (!added1 && not !added2) || (((not !added1) && !added2) && mem sl 1)))) let _two_remove_same () = Atomic.trace (fun () -> Random.init 0; let sl = create ~max_height:2 ~compare:Int.compare () in let added1 = ref false in let removed1 = ref false in let removed2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1; removed1 := try_remove sl 1); Atomic.spawn (fun () -> removed2 := try_remove sl 1); Atomic.final (fun () -> Atomic.check (fun () -> !added1 && ((!removed1 && not !removed2) || ((not !removed1) && !removed2)) && not (mem sl 1)))) let _two_remove () = Atomic.trace (fun () -> Random.init 0; let sl = create ~max_height:2 ~compare:Int.compare () in let added1 = ref false in let removed1 = ref false in let removed2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1; removed1 := try_remove sl 1); Atomic.spawn (fun () -> removed2 := try_remove sl 2); Atomic.final (fun () -> Atomic.check (fun () -> let found1 = mem sl 1 in !added1 && !removed1 && (not !removed2) && not found1))) let () = let open Alcotest in run "DSCheck Skiplist" [ ( "basic", [ test_case "max_height_of" `Quick test_max_height_of; test_case "2-mem" `Slow _two_mem; test_case "2-add-same" `Slow _two_add_same; test_case "2-add" `Slow _two_add; test_case "2-remove-same" `Slow _two_remove_same; test_case "2-remove" `Slow _two_remove; ] ); ] saturn-0.5.0/test/ws_deque/0000755000175000017500000000000014661627530014327 5ustar kylekylesaturn-0.5.0/test/ws_deque/qcheck_ws_deque.ml0000644000175000017500000002465414661627530020026 0ustar kylekylemodule Ws_deque = Saturn_lockfree.Work_stealing_deque.M (* Sequential building of a deque *) let deque_of_list l = let deque = Ws_deque.create () in List.iter (Ws_deque.push deque) l; deque (* [extract_n_from_d q f n] extract [n] elements of [q] by calling [n] times the function [f] on [q]. *) let extract_n_of_deque q fextract n = let rec loop acc = function | 0 -> acc | n -> let a = fextract q in loop (a :: acc) (n - 1) in loop [] n |> List.rev let keep_some l = List.filter Option.is_some l |> List.map Option.get let keep_n_first n = List.filteri (fun i _ -> i < n) let tests_one_producer = [ (* TEST 1 - single producer no stealer: forall l, l' and with q built by pushing in order (l@l') pop q :: pop q :: pop q :: ... :: [] = List.rev l' *) QCheck.( Test.make ~name:"pops_are_in_order" (pair (list int) (list int)) (fun (l, l') -> assume (l' <> []); let deque = deque_of_list (l @ l') in let pop_list = extract_n_of_deque deque Ws_deque.pop (List.length l') in pop_list = List.rev l')); (* TEST 2 - single producer no stealer : forall q of size n, forall m > n, poping m times raises Exit (m-n) times. *) QCheck.( Test.make ~name:"pop_on_empty_deque_raises_exit" ~count:1 (pair (list int) small_nat) (fun (l, m) -> assume (m > 0); let n = List.length l in let m = m + n in let count = ref 0 in let deque = deque_of_list l in for _i = 0 to m - 1 do try ignore (Ws_deque.pop deque) with Exit -> incr count done; !count = m - n)); ] let tests_one_producer_one_stealer = [ (* TEST 1 with 1 producer, 1 stealer and sequential execution. Producer domain pushes a list of value THEN a stealer domain steals. This checks : - order is preserved (first push = first steal) - Exit is raised only when the deque is empty *) QCheck.( Test.make ~name:"steals_are_in_order" (pair (list int) small_nat) (fun (l, n) -> (* Main domain pushes all elements of [l] in order. *) let deque = deque_of_list l in (* Then the stealer domain steals [n] times. The output list is composed of all stolen value. If an [Exit] is raised, it is register as a [None] value in the returned list.*) let stealer = Domain.spawn (fun () -> let steal' deque = match Ws_deque.steal deque with | value -> Some value | exception Exit -> Domain.cpu_relax (); None in extract_n_of_deque deque steal' n) in let steal_list = Domain.join stealer in (* The stolen values should be the [n]th first elements of [l]*) (let expected_stolen = keep_n_first n l in let nfirst = keep_n_first (List.length l) steal_list in List.for_all2 (fun found_opt expected -> match found_opt with | Some found -> found = expected | None -> false) nfirst expected_stolen) && (* The [n - (List.length l)] last values of [steal_list] should be [None] (i.e. the [steal] function had raised [Exit]). *) let exits = List.filteri (fun i _ -> i >= List.length l) steal_list in List.for_all (function None -> true | _ -> false) exits)); (* TEST 2 with 1 producer, 1 stealer and parallel execution. Producer domain does pushes. Simultaneously the stealer domain steals. This test checks : - order is preserved (first push = first steal) - Exit is raised only when the deque is empty *) QCheck.( Test.make ~name:"parallel_pushes_and_steals" (pair (list small_int) (int_bound 200)) (fun (l, n) -> (* Initialization *) let deque = Ws_deque.create () in let barrier = Barrier.create 2 in (* The stealer domain steals n times. If a value [v] is stolen, it is registered as [Some v] in the returned list whereas any [Exit] raised is registered as a [None].*) let stealer = Domain.spawn (fun () -> Barrier.await barrier; let steal' deque = match Ws_deque.steal deque with | value -> Some value | exception Exit -> Domain.cpu_relax (); None in extract_n_of_deque deque steal' n) in Barrier.await barrier; (* Main domain pushes.*) List.iter (fun elt -> Ws_deque.push deque elt; Domain.cpu_relax ()) l; let steal_list = Domain.join stealer in (* We don't know how the pushes and the steals are interleaved but we can check that if [m] values have been stolen, they are the [m] first pushed values. *) List.length steal_list = n && let stolen = keep_some steal_list in let expected_stolen = keep_n_first (List.length stolen) l in stolen = expected_stolen)); (* TEST 3 with 1 producer, 1 stealer and parallel execution. Main domain does sequential pushes and then pops at the same time that a stealer domain steals. This test checks : - order is preserved (first push = first steal, first push = last pop) - no value is both popped and stolen. We actually have a strong property here, as all the [push] calls are done before [pop] and [steal] calls : stolen_values @ (List.rev popped_values) = pushed_values *) QCheck.( Test.make ~name:"parallel_pops_and_steals" (pair (list small_int) (pair small_nat small_nat)) (fun (l, (nsteal, npop)) -> assume (nsteal + npop > List.length l); (* Initialization - sequential pushes*) let deque = deque_of_list l in let barrier = Barrier.create 2 in Random.self_init (); let pop' deque = match Ws_deque.pop deque with | value -> Some value | exception Exit -> Domain.cpu_relax (); None in (* The stealer domain steals [nsteal] times. If a value [v] is stolen, it is registered as [Some v] in the returned list whereas any [Exit] raised, it is registered as a [None].*) let stealer = Domain.spawn (fun () -> Barrier.await barrier; let steal' deque = match Ws_deque.steal deque with | value -> Some value | exception Exit -> Domain.cpu_relax (); None in extract_n_of_deque deque steal' nsteal) in Barrier.await barrier; (* Main domain pops and builds a list of popped values. *) let pop_list = extract_n_of_deque deque pop' npop in let steal_list = Domain.join stealer in (* All the pushes are done sequentially before the run so whatever how pops and steals are interleaved if [npop + nsteal > npush] we should have stolen @ (List.rev popped) = pushed . *) List.length steal_list = nsteal && List.length pop_list = npop && let stolen = keep_some steal_list in let popped = keep_some pop_list in stolen @ List.rev popped = l)); ] let tests_one_producer_two_stealers = [ (* TEST 1 with 1 producer, 2 stealers and parallel steal calls. Producer domain does sequential pushes. Two stealers steal simultaneously. This test checks : - order is preserved (first push = first steal) - no element is stolen by both stealers - Exit is raised only when the deque is empty *) QCheck.( Test.make ~name:"parallel_steals" (pair (list small_int) (pair small_nat small_nat)) (fun (l, (ns1, ns2)) -> (* Initialization *) let deque = deque_of_list l in let barrier = Barrier.create 2 in (* Steal calls *) let multiple_steal deque nsteal = Barrier.await barrier; let res = Array.make nsteal None in for i = 0 to nsteal - 1 do res.(i) <- (match Ws_deque.steal deque with | value -> Some value | exception Exit -> Domain.cpu_relax (); None) done; res in let stealer1 = Domain.spawn (fun () -> multiple_steal deque ns1) in let stealer2 = Domain.spawn (fun () -> multiple_steal deque ns2) in let steal_list1 = Domain.join stealer1 in let steal_list2 = Domain.join stealer2 in let stolen1 = keep_some (Array.to_list steal_list1) in let stolen2 = keep_some (Array.to_list steal_list2) in (* We expect the stolen values to be the first ones that have been pushed. *) let expected_stolen = keep_n_first (ns1 + ns2) l in (* [compare l l1 l2] checks that there exists an interlacing of the stolen values [l1] and [l2] that is equal to the beginning of the push list [l]. *) let rec compare l l1 l2 = match (l, l1, l2) with | [], [], [] -> true | [], _, _ -> false | _, [], _ -> l = l2 | _, _, [] -> l = l1 | x :: l', y :: l1', z :: l2' -> if x = y && x = z then compare l' l1 l2' || compare l' l1' l2 else if x = y then compare l' l1' l2 else if x = z then compare l' l1 l2' else false in Array.length steal_list1 = ns1 && Array.length steal_list2 = ns2 && compare expected_stolen stolen1 stolen2)); ] let main () = let to_alcotest = List.map QCheck_alcotest.to_alcotest in Alcotest.run "Ws_deque" [ ("one_producer", to_alcotest tests_one_producer); ("one_producer_one_stealer", to_alcotest tests_one_producer_one_stealer); ("one_producer_two_stealers", to_alcotest tests_one_producer_two_stealers); ] ;; main () saturn-0.5.0/test/ws_deque/test_ws_deque.ml0000644000175000017500000000712314661627530017537 0ustar kylekyleopen Saturn_lockfree.Work_stealing_deque.M (** Tests *) let test_empty () = let q = create () in match pop q with | exception Exit -> print_string "test_exit: ok\n" | _ -> assert false let test_push_and_pop () = let q = create () in push q 1; push q 10; push q 100; assert (pop q = 100); assert (pop q = 10); assert (pop q = 1); print_string "test_push_and_pop: ok\n" let test_push_and_steal () = let q = create () in push q 1; push q 10; push q 100; let domains = Array.init 3 (fun _ -> Domain.spawn (fun _ -> let v = steal q in assert (v = 1 || v = 10 || v = 100))) in Array.iter Domain.join domains; print_string "test_push_and_steal: ok\n" let tailrec_concat l1 l2 = List.rev_append (List.rev l1) l2 let test_concurrent_workload () = (* The desired number of push events. *) let n = ref 100000 in (* The desired number of steal attempts per thief. *) let attempts = 100000 in (* The number of thieves. *) let thieves = if Sys.word_size >= 64 then 16 else 2 in (* The queue. *) let q = create () in (* A generator of fresh elements. *) let c = ref 0 in let fresh () = let x = !c in c := x + 1; x in (* A history of pushed elements. *) let pushed = ref [] (* A history of popped elements. *) and popped = ref [] (* Histories of stolen elements. *) and stolen = Array.make thieves [] in (* The owner thread. *) let owner = Domain.spawn (fun () -> let push () = let x = fresh () in push q x; pushed := x :: !pushed; decr n and pop () = match pop q with | exception Exit -> Domain.cpu_relax (); false | x -> popped := x :: !popped; true in let rec loop () = if !n > 0 then ( (* More pushes are allowed. *) (* Choose between pushing and popping; then continue. *) if Random.bool () then push () else ignore (pop ()); loop ()) else if (* No more pushes are allowed. Pop and continue. *) pop () then loop () in loop ()) in (* The thief threads. *) let thieves = Array.init thieves (fun i -> Domain.spawn (fun () -> let steal () = match steal q with | exception Exit -> Domain.cpu_relax () | x -> stolen.(i) <- x :: stolen.(i) in for _i = 1 to attempts do (* Should we somehow wait between two steal attempts? *) steal () done)) in (* Wait for every thread to complete. *) Domain.join owner; Array.iter Domain.join thieves; (* Check that the elements that have been popped or stolen are exactly the elements that have been pushed. Thus, no element is lost, duplicated, or created out of thin air. *) let pushed = !pushed and popped = !popped in let npushed = List.length pushed and npopped = List.length popped and nstolen = Array.fold_left (fun accu stolen -> accu + List.length stolen) 0 stolen in assert (npushed = npopped + nstolen); let sort xs = List.sort compare xs in let stolen = Array.fold_left (fun accu stolen -> tailrec_concat accu stolen) [] stolen in assert (sort pushed = sort (tailrec_concat popped stolen)); (* Print a completion message. *) Printf.printf "test_concurrent_workload: ok (pushed = %d, popped = %d, stolen = %d)\n" npushed npopped nstolen let _ = test_empty (); test_push_and_pop (); test_push_and_steal (); test_concurrent_workload () saturn-0.5.0/test/ws_deque/ws_deque_dscheck.ml0000644000175000017500000000402114661627530020156 0ustar kylekylelet drain_remaining queue = let remaining = ref 0 in (try while true do Ws_deque.M.pop queue |> ignore; remaining := !remaining + 1 done with _ -> ()); !remaining let owner_stealer () = Atomic.trace (fun () -> let queue = Ws_deque.M.create () in let total_items = 3 in let popped = ref 0 in (* owner thr *) Atomic.spawn (fun () -> for _ = 1 to total_items do Ws_deque.M.push queue 0 done; for _ = 1 to total_items / 2 do match Ws_deque.M.pop queue with | exception _ -> () | _ -> popped := !popped + 1 done); (* stealer *) Atomic.spawn (fun () -> for _ = 1 to total_items / 2 do match Ws_deque.M.steal queue with | exception _ -> () | _ -> popped := !popped + 1 done); Atomic.final (fun () -> Atomic.check (fun () -> let remaining = drain_remaining queue in remaining + !popped == total_items))) let popper_stealer () = Atomic.trace (fun () -> let queue = Ws_deque.M.create () in let total_items = 3 in for _ = 1 to total_items do Ws_deque.M.push queue 0 done; (* stealers *) let popped = ref 0 in let stealer () = match Ws_deque.M.steal queue with | exception _ -> () | _ -> popped := !popped + 1 in Atomic.spawn stealer |> ignore; Atomic.spawn stealer |> ignore; Atomic.final (fun () -> Atomic.check (fun () -> let remaining = drain_remaining queue in remaining = 1 && !popped = 2))) let () = let open Alcotest in run "ws_deque_dscheck" [ ( "basic", [ test_case "1-owner-1-stealer" `Slow owner_stealer; test_case "1-pusher-2-stealers" `Slow popper_stealer; (* we'd really want to test cases with more threads here, but dscheck is not optimized enough for that yet *) ] ); ] saturn-0.5.0/test/ws_deque/stm_ws_deque.ml0000644000175000017500000000542014661627530017361 0ustar kylekyle(** Sequential and Parallel model-based tests of ws_deque *) open QCheck open STM open Util module Ws_deque = Saturn_lockfree.Work_stealing_deque module Spec = struct type cmd = Push of int | Pop | Steal let show_cmd c = match c with | Push i -> "Push " ^ string_of_int i | Pop -> "Pop" | Steal -> "Steal" type state = int list type sut = int Ws_deque.M.t let arb_cmd _s = let int_gen = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [ Gen.map (fun i -> Push i) int_gen; Gen.return Pop; (*Gen.return Steal;*) (* No point in stealing from yourself :-D *) ]) let stealer_cmd _s = QCheck.make ~print:show_cmd (Gen.return Steal) let init_state = [] let init_sut () = Ws_deque.M.create () let cleanup _ = () let next_state c s = match c with | Push i -> i :: s (*if i<>1213 then i::s else s*) (* an artificial fault *) | Pop -> ( match s with [] -> s | _ :: s' -> s') | Steal -> ( match List.rev s with [] -> s | _ :: s' -> List.rev s') let precond _ _ = true let run c d = match c with | Push i -> Res (unit, Ws_deque.M.push d i) | Pop -> Res (result int exn, protect Ws_deque.M.pop d) | Steal -> Res (result int exn, protect Ws_deque.M.steal d) let postcond c (s : state) res = match (c, res) with | Push _, Res ((Unit, _), _) -> true | Pop, Res ((Result (Int, Exn), _), res) -> ( match s with [] -> res = Error Exit | j :: _ -> res = Ok j) | Steal, Res ((Result (Int, Exn), _), res) -> ( match List.rev s with [] -> Result.is_error res | j :: _ -> res = Ok j) | _, _ -> false end let () = let make_domain ~count ~name (module Dom : Stm_run.STM_domain with type Spec.cmd = Spec.cmd and type Spec.state = Spec.state and type Spec.sut = Spec.sut) = (* A parallel agreement test - w/repeat and retries combined *) let agree_test_par_asym ~count ~name = let rep_count = 20 in let seq_len, par_len = (20, 12) in Test.make ~retries:10 ~count ~name (* "Owner domain" cmds can't be [Steal], "stealer domain" cmds can only be [Steal]. *) (Dom.arb_triple_asym seq_len par_len Spec.arb_cmd Spec.arb_cmd Spec.stealer_cmd) (fun triple -> assume (Dom.all_interleavings_ok triple); repeat rep_count Dom.agree_prop_par_asym triple) in [ agree_test_par_asym ~count ~name:(name ^ " parallel"); (* Note: this can generate, e.g., pop commands/actions in different threads, thus violating the spec. *) Dom.neg_agree_test_par ~count ~name:(name ^ " parallel, negative"); ] in Stm_run.run ~count:1000 ~name:"Saturn_lockfree.Ws_deque" ~verbose:true ~make_domain (module Spec) |> exit saturn-0.5.0/test/ws_deque/dune0000644000175000017500000000177514661627530015217 0ustar kylekyle(rule (action (copy ../../src_lockfree/ArrayExtra.ml ArrayExtra.ml)) (package saturn_lockfree)) (rule (action (copy ../../src_lockfree/ws_deque.ml ws_deque.ml)) (package saturn_lockfree)) (test (package saturn_lockfree) (name ws_deque_dscheck) (libraries atomic dscheck alcotest backoff) (build_if (>= %{ocaml_version} 5)) (modules ArrayExtra ws_deque ws_deque_dscheck)) (test (package saturn_lockfree) (name test_ws_deque) (libraries saturn_lockfree domain_shims) (modules test_ws_deque)) (test (package saturn_lockfree) (name qcheck_ws_deque) (libraries barrier saturn_lockfree qcheck qcheck-core qcheck-alcotest domain_shims alcotest) (enabled_if (not (and (= %{arch_sixtyfour} false) (= %{architecture} arm)))) (modules qcheck_ws_deque)) (test (package saturn_lockfree) (name stm_ws_deque) (modules stm_ws_deque) (libraries saturn_lockfree qcheck-core qcheck-multicoretests-util qcheck-stm.stm stm_run) (enabled_if (= %{arch_sixtyfour} true))) saturn-0.5.0/test/spsc_queue/0000755000175000017500000000000014661627530014667 5ustar kylekylesaturn-0.5.0/test/spsc_queue/qcheck_spsc_queue.ml0000644000175000017500000003004214661627530020712 0ustar kylekylemodule Qcheck_spsc (Spsc_queue : Spsc_queues.SPSC_tests) = struct let keep_some l = List.filter Option.is_some l |> List.map Option.get let keep_n_first n = List.filteri (fun i _ -> i < n) let pop_opt_n_times q n = let rec loop count acc = if count = 0 then acc else let v = Spsc_queue.pop_opt q in Domain.cpu_relax (); loop (count - 1) (v :: acc) in loop n [] |> List.rev let pop_n_times q n = let rec loop count acc = if count = 0 then acc else try let v = Spsc_queue.pop_exn q in Domain.cpu_relax (); loop (count - 1) (Some v :: acc) with Spsc_queue.Empty -> loop (count - 1) (None :: acc) in loop n [] |> List.rev let tests = [ (* TEST 1 - one producer, one consumer: Sequential pushes then pops. Checks that the behaviour is similar to one of a FIFO queue. *) QCheck.( Test.make ~name:"seq_pop_opt_push" (pair (list int) small_nat) (fun (l, npop) -> (* Making sure we do not create a too big queue. Other tests are checking the behaviour of a full queue.*) let size_exponent = 8 in let size_max = Int.shift_left 1 size_exponent in assume (List.length l < size_max); (* Initialization *) let q = Spsc_queue.create ~size_exponent in (* Sequential pushed : not Full exception should be raised. *) let not_full_queue = try List.iter (Spsc_queue.push_exn q) l; true with Spsc_queue.Full -> false in (* Consumer domain pops *) let consumer = Domain.spawn (fun () -> pop_opt_n_times q npop) in let pops = Domain.join consumer in (* Property *) not_full_queue && List.length pops = npop && keep_some pops = keep_n_first (min (List.length l) npop) l)); (* TEST 1b - one producer, one consumer: Same than previous with pop instead of pop_opt *) QCheck.( Test.make ~name:"seq_pop_push" (pair (list int) small_nat) (fun (l, npop) -> (* Making sure we do not create a too big queue. Other tests are checking the behaviour of a full queue.*) let size_exponent = 8 in let size_max = Int.shift_left 1 size_exponent in assume (List.length l < size_max); (* Initialization *) let q = Spsc_queue.create ~size_exponent in (* Sequential pushed : not Full exception should be raised. *) let not_full_queue = try List.iter (Spsc_queue.push_exn q) l; true with Spsc_queue.Full -> false in (* Consumer domain pops *) let consumer = Domain.spawn (fun () -> pop_n_times q npop) in let pops = Domain.join consumer in (* Property *) not_full_queue && List.length pops = npop && keep_some pops = keep_n_first (min (List.length l) npop) l)); (* TEST 1b - one producer, one consumer: Same than TEST1 with try_push instead of push *) QCheck.( Test.make ~name:"seq_pop_try_push" (pair (list int) small_nat) (fun (l, npop) -> (* Making sure we do not create a too big queue. Other tests are checking the behaviour of a full queue.*) let size_exponent = 8 in let size_max = Int.shift_left 1 size_exponent in assume (List.length l < size_max); (* Initialization *) let q = Spsc_queue.create ~size_exponent in (* Sequential pushed : [try_push] should always returns true. *) let not_full_queue = List.for_all (Spsc_queue.try_push q) l in (* Consumer domain pops *) let consumer = Domain.spawn (fun () -> pop_opt_n_times q npop) in let pops = Domain.join consumer in (* Property *) not_full_queue && List.length pops = npop && keep_some pops = keep_n_first (min (List.length l) npop) l)); (* TEST 2 - one producer, one consumer: Parallel pushes and pops. Checks that the behaviour is similar to one of a FIFO queue. *) QCheck.( Test.make ~name:"par_pop_push" (pair (pair (list int) (list int)) small_nat) (fun ((l, l'), npop) -> (* Making sure we do not create a too big queue. Other tests are checking the behaviour of a full queue.*) let size_exponent = 8 in let size_max = Int.shift_left 1 size_exponent in assume (List.length l + List.length l' < size_max); (* Initialization *) let barrier = Barrier.create 2 in let q = Spsc_queue.create ~size_exponent in List.iter (Spsc_queue.push_exn q) l; (* Consumer pops *) let consumer = Domain.spawn (fun () -> Barrier.await barrier; pop_opt_n_times q npop) in let producer = Domain.spawn (fun () -> Barrier.await barrier; (* Main domain pushes.*) List.iter (fun elt -> Spsc_queue.push_exn q elt; Domain.cpu_relax ()) l') in let popped = Domain.join consumer in let _ = Domain.join producer in let popped_val = popped |> keep_some in (* Property *) List.length popped = npop && popped_val = keep_n_first (List.length popped_val) (l @ l'))); (* TEST 3 - one producer, one consumer: Checks that pushing too many elements raise exception Full. *) QCheck.( Test.make ~name:"push_full" (list int) (fun l -> let size_exponent = 4 in let size_max = Int.shift_left 1 size_exponent in (* Initialization *) let q = Spsc_queue.create ~size_exponent in let is_full = try List.iter (Spsc_queue.push_exn q) l; false with Spsc_queue.Full -> true in (* Property *) (List.length l > size_max && is_full) || (List.length l <= size_max && not is_full))); (* TEST 4 - one producer, one consumer: Sequential checks that [peek_opt] read the next value. *) QCheck.( Test.make ~name:"seq_peek_opt" (list int) (fun l -> let size_exponent = 10 in let size_max = Int.shift_left 1 size_exponent in assume (size_max > List.length l); (* Initialisation : pushing l in a new spsc queue. *) let q = Spsc_queue.create ~size_exponent in List.iter (Spsc_queue.push_exn q) l; (* Test : we consecutively peek and pop and check both matches with pushed elements. *) let rec loop pushed = match (pushed, Spsc_queue.peek_opt q) with | [], None -> ( match Spsc_queue.pop_opt q with | None -> true | Some _ -> false) | x :: pushed, Some y when x = y -> ( match Spsc_queue.pop_opt q with | None -> false | Some z when y = z -> loop pushed | _ -> false) | _, _ -> false in loop l)); (* TEST 4b - one producer, one consumer: Same then previous one for [peek] instead of [peek_one]. *) QCheck.( Test.make ~name:"seq_peek" (list int) (fun l -> let size_exponent = 10 in let size_max = Int.shift_left 1 size_exponent in assume (size_max > List.length l); (* Initialisation : pushing l in a new spsc queue. *) let q = Spsc_queue.create ~size_exponent in List.iter (Spsc_queue.push_exn q) l; (* Test : we consecutively peek and pop and check both matches with pushed elements. *) let rec loop pushed = let peeked = try Some (Spsc_queue.peek_exn q) with Spsc_queue.Empty -> None in match (pushed, peeked) with | [], None -> ( match Spsc_queue.pop_opt q with | None -> true | Some _ -> false) | x :: pushed, Some y when x = y -> ( match Spsc_queue.pop_opt q with | None -> false | Some z when y = z -> loop pushed | _ -> false) | _, _ -> false in loop l)); (* TEST 5 - one producer, one consumer: Parallel test of [peek_opt] with [try_push]. *) QCheck.( Test.make ~name:"par_peek_opt" (list int) (fun pushed -> let size_exponent = 10 in let size_max = Int.shift_left 1 size_exponent in let npush = List.length pushed in assume (size_max > npush); let barrier = Barrier.create 2 in (* Initialisation : pushing l in a new spsc queue. *) let q = Spsc_queue.create ~size_exponent in (* Test : - domain1 pushes a list of element - in parallel, domain2 peeks then pops. *) let domain1 = Domain.spawn (fun () -> Barrier.await barrier; List.iter (fun elt -> Domain.cpu_relax (); Spsc_queue.push_exn q elt) pushed) in let domain2 = Domain.spawn (fun () -> let peeked = ref [] in let popped = ref [] in Barrier.await barrier; for _ = 0 to npush - 1 do Domain.cpu_relax (); (* peek then pop *) let peek = Spsc_queue.peek_opt q in let pop = Spsc_queue.pop_opt q in peeked := peek :: !peeked; popped := pop :: !popped done; (!peeked, !popped)) in Domain.join domain1; let peeked, popped = Domain.join domain2 in let peeked = List.rev peeked in let popped = List.rev popped in let rec check pushed peeked popped = match (pushed, peeked, popped) with | _, [], [] -> (* pushed can not be empty if the consumer finished before the producer *) true | _, None :: peeked, None :: popped -> (* consumer tries to peek then pop when the queue was empty *) check pushed peeked popped | push :: pushed, Some peek :: peeked, Some pop :: popped when push = pop && push = peek -> (* consumer peeks and pops on an non-empty queue. The peeked and the popped element must be the same. *) check pushed peeked popped | push :: pushed, None :: peeked, Some pop :: popped when push = pop -> (* consumer peeks when the queue was empty, then producer pushes at least once and then consumer pops. *) check pushed peeked popped | _, _, _ -> false in check pushed peeked popped)); ] end let () = let module Safe = Qcheck_spsc (Spsc_queues.Spsc_queue) in let module Unsafe = Qcheck_spsc (Spsc_queues.Spsc_queue_unsafe) in let to_alcotest = List.map QCheck_alcotest.to_alcotest in Alcotest.run "Spsc_queues" [ (Spsc_queues.Spsc_queue.name, to_alcotest Safe.tests); (Spsc_queues.Spsc_queue_unsafe.name, to_alcotest Unsafe.tests); ] saturn-0.5.0/test/spsc_queue/stm_spsc_queue.ml0000644000175000017500000000701414661627530020262 0ustar kylekyle(** Sequential and Parallel model-based tests of spsc_queue *) open QCheck open STM open Util module STM_spsc (Spsc_queue : Spsc_queues.SPSC_tests) = struct module Spec = struct type cmd = Push of int | Pop | Peek let show_cmd c = match c with | Push i -> "Push " ^ string_of_int i | Pop -> "Pop" | Peek -> "Peek" type state = int * int list type sut = int Spsc_queue.t let producer_cmd _s = let int_gen = Gen.nat in QCheck.make ~print:show_cmd (Gen.map (fun i -> Push i) int_gen) let consumer_cmd _s = QCheck.make ~print:show_cmd (Gen.oneof [ Gen.return Pop; Gen.return Peek ]) let arb_cmd _s = let int_gen = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [ Gen.return Pop; Gen.return Peek; Gen.map (fun i -> Push i) int_gen; ]) let size_exponent = 4 let max_size = Int.shift_left 1 size_exponent let init_state = (0, []) let init_sut () = Spsc_queue.create ~size_exponent let cleanup _ = () let next_state c (n, s) = match c with | Push i -> if n = max_size then (n, s) else (n + 1, i :: s) | Pop -> ( match List.rev s with [] -> (0, s) | _ :: s' -> (n - 1, List.rev s')) | Peek -> (n, s) let precond _ _ = true let run c d = match c with | Push i -> Res (result unit exn, protect (fun d -> Spsc_queue.push_exn d i) d) | Pop -> Res (result int exn, protect Spsc_queue.pop_exn d) | Peek -> Res (result int exn, protect Spsc_queue.peek_exn d) let postcond c ((n, s) : state) res = match (c, res) with | Push _, Res ((Result (Unit, Exn), _), res) -> ( match res with | Error Spsc_queue.Full -> n = max_size | Ok () -> n < max_size | _ -> false) | (Pop | Peek), Res ((Result (Int, Exn), _), res) -> ( match (res, List.rev s) with | Error Spsc_queue.Empty, [] -> true | Ok popped, x :: _ -> x = popped | _ -> false) | _, _ -> false end let run () = let make_domain ~count ~name (module Dom : Stm_run.STM_domain with type Spec.cmd = Spec.cmd and type Spec.state = Spec.state and type Spec.sut = Spec.sut) = (* [arb_cmds_par] differs in what each triple component generates: "Producer domain" cmds can't be [Pop], "consumer domain" cmds can only be [Pop]. *) let arb_cmds_par = Dom.arb_triple 20 12 Spec.producer_cmd Spec.producer_cmd Spec.consumer_cmd in (* A parallel agreement test - w/repeat and retries combined *) let agree_test_par_asym ~count ~name = let rep_count = 20 in Test.make ~retries:10 ~count ~name:(name ^ " parallel") arb_cmds_par @@ fun triple -> assume (Dom.all_interleavings_ok triple); repeat rep_count Dom.agree_prop_par_asym triple in [ agree_test_par_asym ~count ~name; (* Note: this can generate, e.g., pop commands/actions in different threads, thus violating the spec. *) Dom.neg_agree_test_par ~count ~name:(name ^ " parallel, negative"); ] in Stm_run.run ~count:1000 ~name:("Saturn_lockfree." ^ Spsc_queue.name) ~verbose:true ~make_domain (module Spec) end let () = let module Safe = STM_spsc (Spsc_queues.Spsc_queue) in let exit_code = Safe.run () in if exit_code <> 0 then exit exit_code else let module Unsafe = STM_spsc (Spsc_queues.Spsc_queue_unsafe) in Unsafe.run () |> exit saturn-0.5.0/test/spsc_queue/spsc_queues/0000755000175000017500000000000014661627530017226 5ustar kylekylesaturn-0.5.0/test/spsc_queue/spsc_queues/spsc_queues.ml0000644000175000017500000000056014661627530022120 0ustar kylekylemodule type SPSC_tests = sig include Spsc_queue_intf.SPSC_queue val name : string end module Spsc_queue : SPSC_tests = struct include Saturn_lockfree.Single_prod_single_cons_queue let name = "Spsc_queue" end module Spsc_queue_unsafe : SPSC_tests = struct include Saturn_lockfree.Single_prod_single_cons_queue_unsafe let name = "Spsc_queue_unsafe" end saturn-0.5.0/test/spsc_queue/spsc_queues/dune0000644000175000017500000000025514661627530020106 0ustar kylekyle(rule (action (copy ../../../src_lockfree/spsc_queue_intf.ml spsc_queue_intf.ml)) (package saturn_lockfree)) (library (name spsc_queues) (libraries saturn_lockfree)) saturn-0.5.0/test/spsc_queue/spsc_queue_dscheck.ml0000644000175000017500000000510114661627530021056 0ustar kylekylemodule Atomic = Dscheck.TracedAtomic module Dscheck_spsc (Spsc_queue : Spsc_queue_intf.SPSC_queue) = struct let create_test ~shift_by () = let queue = Spsc_queue.create ~size_exponent:2 in let items_count = 3 in (* shift the queue, that helps testing overlap handling *) for _ = 1 to shift_by do Spsc_queue.push_exn queue (-1); assert (Option.is_some (Spsc_queue.pop_opt queue)) done; (* enqueuer *) Atomic.spawn (fun () -> for i = 1 to items_count do Spsc_queue.push_exn queue i done); (* dequeuer *) let dequeued = ref 0 in Atomic.spawn (fun () -> for _ = 1 to items_count + 1 do let peeked = Spsc_queue.peek_opt queue in match Spsc_queue.pop_opt queue with | None -> assert (peeked = None) | Some v as popped -> assert (v = !dequeued + 1); assert (popped = peeked || peeked = None); dequeued := v done); (* ending assertions *) Atomic.final (fun () -> Atomic.check (fun () -> Spsc_queue.size queue == items_count - !dequeued)) let with_trace ?(shift_by = 0) f () = Atomic.trace (fun () -> f ~shift_by ()) let size_linearizes_with_1_thr () = Atomic.trace (fun () -> let queue = Spsc_queue.create ~size_exponent:4 in Spsc_queue.push_exn queue (-1); Spsc_queue.push_exn queue (-1); Atomic.spawn (fun () -> for _ = 1 to 4 do Spsc_queue.push_exn queue (-1) done); let size = ref 0 in Atomic.spawn (fun () -> assert (Option.is_some (Spsc_queue.pop_opt queue)); size := Spsc_queue.size queue); Atomic.final (fun () -> Atomic.check (fun () -> 1 <= !size && !size <= 5))) let tests name = let open Alcotest in [ ( "basic_" ^ name, [ test_case "simple-test" `Slow (with_trace create_test) ] ); ( "wrap-arounds_" ^ name, let with_shift s = test_case (Printf.sprintf "shift-by-%d" s) `Slow (with_trace ~shift_by:s create_test) in [ with_shift 1; with_shift 6; with_shift 11 ] ); ( "size_" ^ name, [ test_case "linearizes-with-1-thr" `Slow size_linearizes_with_1_thr ] ); ] end let () = let module Safe = Dscheck_spsc (Spsc_queue) in let safe_test = Safe.tests "safe" in let module Unsafe = Dscheck_spsc (Spsc_queue_unsafe) in let unsafe_test = Unsafe.tests "unsafe" in let open Alcotest in run "spsc_queue_dscheck" (safe_test @ unsafe_test) saturn-0.5.0/test/spsc_queue/test_spsc_queue.ml0000644000175000017500000000376214661627530020444 0ustar kylekylemodule Tests_spsc (Spsc_queue : Spsc_queues.SPSC_tests) = struct (** Tests *) let test_empty () = let q = Spsc_queue.create ~size_exponent:3 in assert (Option.is_none (Spsc_queue.pop_opt q)); assert (Spsc_queue.size q == 0); Printf.printf "test_%s_empty: ok\n" Spsc_queue.name let push_not_full q elt = try Spsc_queue.push_exn q elt; true with Spsc_queue.Full -> false let test_full () = let q = Spsc_queue.create ~size_exponent:3 in while push_not_full q () do Domain.cpu_relax () done; assert (Spsc_queue.size q == 8); Printf.printf "test_%s_full: ok\n" Spsc_queue.name let test_parallel () = let count = let ocaml_4 = Char.code (String.get Sys.ocaml_version 0) < Char.code '5' in match ocaml_4 with true -> 100 | false -> 100_000 in let q = Spsc_queue.create ~size_exponent:2 in (* producer *) let producer = Domain.spawn (fun () -> for i = 1 to count do while not (push_not_full q (Float.of_int i)) do Domain.cpu_relax () done done) in (* consumer *) let last_num = ref 0 in while !last_num < count do match Spsc_queue.pop_opt q with | None -> Domain.cpu_relax () | Some v -> assert (v = Float.of_int (!last_num + 1)); last_num := Float.to_int v done; assert (Option.is_none (Spsc_queue.pop_opt q)); assert (Spsc_queue.size q == 0); Domain.join producer; Printf.printf "test_%s_parallel: ok (transferred = %d)\n" Spsc_queue.name !last_num let test_float () = let q = Spsc_queue.create ~size_exponent:1 in assert (Spsc_queue.try_push q 1.01); assert (Spsc_queue.pop_opt q = Some 1.01) let run () = test_empty (); test_full (); test_parallel (); test_float () end let () = let module Safe = Tests_spsc (Spsc_queues.Spsc_queue) in Safe.run (); let module Unsafe = Tests_spsc (Spsc_queues.Spsc_queue_unsafe) in Unsafe.run () saturn-0.5.0/test/spsc_queue/dune0000644000175000017500000000220514661627530015544 0ustar kylekyle(rule (action (copy ../../src_lockfree/spsc_queue.ml spsc_queue.ml)) (package saturn_lockfree)) (rule (action (copy ../../src_lockfree/spsc_queue_unsafe.ml spsc_queue_unsafe.ml)) (package saturn_lockfree)) (rule (action (copy ../../src_lockfree/spsc_queue_intf.ml spsc_queue_intf.ml)) (package saturn_lockfree)) (test (package saturn_lockfree) (name spsc_queue_dscheck) (libraries alcotest atomic dscheck multicore-magic-dscheck) (build_if (>= %{ocaml_version} 5)) (modules spsc_queue spsc_queue_unsafe spsc_queue_intf spsc_queue_dscheck) (flags (:standard -open Multicore_magic_dscheck))) (test (package saturn_lockfree) (name test_spsc_queue) (libraries spsc_queues domain_shims) (modules test_spsc_queue)) (test (package saturn_lockfree) (name qcheck_spsc_queue) (libraries spsc_queues barrier qcheck qcheck-core qcheck-alcotest domain_shims alcotest) (modules qcheck_spsc_queue)) (test (package saturn_lockfree) (name stm_spsc_queue) (modules stm_spsc_queue) (libraries spsc_queues qcheck-core qcheck-multicoretests-util qcheck-stm.stm stm_run) (enabled_if (= %{arch_sixtyfour} true))) saturn-0.5.0/test/size/0000755000175000017500000000000014661627530013465 5ustar kylekylesaturn-0.5.0/test/size/dscheck_size.ml0000644000175000017500000000546314661627530016465 0ustar kylekylemodule Atomic = Dscheck.TracedAtomic open Linked_set.Make (Atomic) (Size) let test_underflow_and_overflow () = let s = Size.create () in assert (Size.get s = 0); Size.update_once s (Size.new_once s Size.decr); assert (Size.get s = Size.max_value); Size.update_once s (Size.new_once s Size.incr); assert (Size.get s = 0) let two_mem () = Atomic.trace @@ fun () -> let sl = create () in let added1 = ref false in let found1 = ref false in let found2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1; found1 := mem sl 1); Atomic.spawn (fun () -> found2 := mem sl 2); Atomic.final (fun () -> Atomic.check (fun () -> !added1 && !found1 && not !found2)) let two_add () = Atomic.trace @@ fun () -> let sl = create () in let added1 = ref false in let added2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1); Atomic.spawn (fun () -> added2 := try_add sl 2); Atomic.final (fun () -> Atomic.check (fun () -> !added1 && !added2 && mem sl 1 && mem sl 2)) let two_add_same () = Atomic.trace @@ fun () -> let sl = create () in let added1 = ref false in let added2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1); Atomic.spawn (fun () -> added2 := try_add sl 1); Atomic.final (fun () -> Atomic.check (fun () -> (!added1 && not !added2) || (((not !added1) && !added2) && mem sl 1))) let two_remove_same () = Atomic.trace @@ fun () -> let sl = create () in let added1 = ref false in let removed1 = ref false in let removed2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1; removed1 := try_remove sl 1); Atomic.spawn (fun () -> removed2 := try_remove sl 1); Atomic.final (fun () -> Atomic.check (fun () -> !added1 && ((!removed1 && not !removed2) || ((not !removed1) && !removed2)) && not (mem sl 1))) let two_remove () = Atomic.trace @@ fun () -> let sl = create () in let added1 = ref false in let removed1 = ref false in let removed2 = ref false in Atomic.spawn (fun () -> added1 := try_add sl 1; removed1 := try_remove sl 1); Atomic.spawn (fun () -> removed2 := try_remove sl 2); Atomic.final (fun () -> Atomic.check (fun () -> let found1 = mem sl 1 in !added1 && !removed1 && (not !removed2) && not found1)) let () = Alcotest.run "dscheck_size" [ ( "basic", [ Alcotest.test_case "underflow and overflow" `Quick test_underflow_and_overflow; Alcotest.test_case "2-mem" `Slow two_mem; Alcotest.test_case "2-add-same" `Slow two_add_same; Alcotest.test_case "2-add" `Slow two_add; Alcotest.test_case "2-remove-same" `Slow two_remove_same; Alcotest.test_case "2-remove" `Slow two_remove; ] ); ] saturn-0.5.0/test/size/linked_set.ml0000644000175000017500000000665714661627530016156 0ustar kylekyle(** Functorized lock-free linked set with [length] for testing and as an example of using [Size]. The functorization is to allow the use of traced atomics with DSCheck. *) module Make (Atomic : sig type !'a t val make : 'a -> 'a t val get : 'a t -> 'a val compare_and_set : 'a t -> 'a -> 'a -> bool end) (Size : sig type t val create : unit -> t val get : t -> int type once val used_once : once type update val decr : update val incr : update val new_once : t -> update -> once val update_once : t -> once -> unit end) : sig type 'a t val create : unit -> 'a t val length : 'a t -> int val mem : 'a t -> 'a -> bool val try_add : 'a t -> 'a -> bool val try_remove : 'a t -> 'a -> bool end = struct type ('a, _) node = | Null : ('a, [> `Null ]) node | Node : { next : 'a link Atomic.t; value : 'a; mutable incr : Size.once; } -> ('a, [> `Node ]) node | Mark : { node : ('a, [< `Null | `Node ]) node; decr : Size.once; } -> ('a, [> `Mark ]) node and 'a link = Link : ('a, [< `Null | `Node | `Mark ]) node -> 'a link [@@unboxed] type 'a t = { size : Size.t; head : 'a link Atomic.t } let create () = { size = Size.create (); head = Atomic.make (Link Null) } let length t = Size.get t.size let rec find_node t prev value : _ -> (_, [< `Null | `Node ]) node = function | Link (Mark _) -> find_node t t.head value (Atomic.get t.head) | Link Null -> Null | Link (Node r as node) as before -> begin match Atomic.get r.next with | Link (Mark r) -> Size.update_once t.size r.decr; if Atomic.compare_and_set prev before (Link r.node) then find_node t prev value (Link r.node) else find_node t prev value (Atomic.get prev) | Link (Null | Node _) as next -> if r.value == value then begin if r.incr != Size.used_once then begin Size.update_once t.size r.incr; r.incr <- Size.used_once end; node end else find_node t r.next value next end let mem t value = find_node t t.head value (Atomic.get t.head) != Null let rec try_add t value = let before = Atomic.get t.head in match find_node t t.head value before with | Node _ -> false | Null -> let incr = Size.new_once t.size Size.incr in let (Node r as after) : (_, [ `Node ]) node = Node { next = Atomic.make before; value; incr } in if Atomic.compare_and_set t.head before (Link after) then begin if r.incr != Size.used_once then begin Size.update_once t.size r.incr; r.incr <- Size.used_once end; true end else try_add t value let rec try_remove t value = match find_node t t.head value (Atomic.get t.head) with | Null -> false | Node r -> begin match Atomic.get r.next with | Link (Mark r) -> Size.update_once t.size r.decr; false | Link ((Null | Node _) as node) as before -> let decr = Size.new_once t.size Size.decr in let after = Mark { node; decr } in if Atomic.compare_and_set r.next before (Link after) then begin find_node t t.head value (Atomic.get t.head) |> ignore; true end else try_remove t value end end saturn-0.5.0/test/size/dune0000644000175000017500000000105314661627530014342 0ustar kylekyle(library (package saturn_lockfree) (name linked_set) (modules linked_set)) (rule (action (copy ../../src_lockfree/size.ml size.ml)) (package saturn_lockfree)) (test (package saturn_lockfree) (name dscheck_size) (modules dscheck_size size) (build_if (>= %{ocaml_version} 5)) (libraries dscheck linked_set alcotest multicore-magic-dscheck) (flags (:standard -open Multicore_magic_dscheck))) (test (package saturn_lockfree) (name stm_size) (modules stm_size) (libraries saturn_lockfree linked_set qcheck-core qcheck-stm.stm stm_run)) saturn-0.5.0/test/size/stm_size.ml0000644000175000017500000000324114661627530015654 0ustar kylekylemodule Linked_set = Linked_set.Make (Atomic) (Saturn_lockfree.Size) module Spec = struct type cmd = Mem of int | Add of int | Remove of int | Length let show_cmd c = match c with | Mem i -> "Mem " ^ string_of_int i | Add i -> "Add " ^ string_of_int i | Remove i -> "Remove " ^ string_of_int i | Length -> "Length" module Sint = Set.Make (Int) type state = Sint.t type sut = int Linked_set.t let arb_cmd _s = QCheck.( make ~print:show_cmd (let int_gen = Gen.nat in Gen.oneof [ Gen.map (fun i -> Add i) int_gen; Gen.map (fun i -> Mem i) int_gen; Gen.map (fun i -> Remove i) int_gen; Gen.return Length; ])) let init_state = Sint.empty let init_sut () = Linked_set.create () let cleanup _ = () let next_state c s = match c with | Add i -> Sint.add i s | Remove i -> Sint.remove i s | Mem _ -> s | Length -> s let precond _ _ = true let run c d = let open STM in match c with | Add i -> Res (bool, Linked_set.try_add d i) | Remove i -> Res (bool, Linked_set.try_remove d i) | Mem i -> Res (bool, Linked_set.mem d i) | Length -> Res (int, Linked_set.length d) let postcond c (s : state) res = let open STM in match (c, res) with | Add i, Res ((Bool, _), res) -> Sint.mem i s = not res | Remove i, Res ((Bool, _), res) -> Sint.mem i s = res | Mem i, Res ((Bool, _), res) -> Sint.mem i s = res | Length, Res ((Int, _), res) -> Sint.cardinal s = res | _, _ -> false end let () = Stm_run.run ~count:1000 ~verbose:true ~name:"Saturn_lockfree.Size" (module Spec) |> exit saturn-0.5.0/test/treiber_stack/0000755000175000017500000000000014661627530015334 5ustar kylekylesaturn-0.5.0/test/treiber_stack/stm_treiber_stack.ml0000644000175000017500000000274414661627530021401 0ustar kylekyle(** Sequential and Parallel model-based tests of treiber_stack *) open QCheck open STM module Treiber_stack = Saturn_lockfree.Stack module Spec = struct type cmd = Push of int | Pop | Is_empty let show_cmd c = match c with | Push i -> "Push " ^ string_of_int i | Pop -> "Pop" | Is_empty -> "Is_empty" type state = int list type sut = int Treiber_stack.t let arb_cmd _s = let int_gen = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [ Gen.map (fun i -> Push i) int_gen; Gen.return Pop; Gen.return Is_empty; ]) let init_state = [] let init_sut () = Treiber_stack.create () let cleanup _ = () let next_state c s = match c with | Push i -> i :: s | Pop -> ( match s with [] -> s | _ :: s' -> s') | Is_empty -> s let precond _ _ = true let run c d = match c with | Push i -> Res (unit, Treiber_stack.push d i) | Pop -> Res (result int exn, protect Treiber_stack.pop d) | Is_empty -> Res (bool, Treiber_stack.is_empty d) let postcond c (s : state) res = match (c, res) with | Push _, Res ((Unit, _), _) -> true | Pop, Res ((Result (Int, Exn), _), res) -> ( match s with | [] -> res = Error Treiber_stack.Empty | j :: _ -> res = Ok j) | Is_empty, Res ((Bool, _), res) -> res = (s = []) | _, _ -> false end let () = Stm_run.run ~count:500 ~verbose:true ~name:"Saturn_lockfree.Treiber_stack" (module Spec) |> exit saturn-0.5.0/test/treiber_stack/treiber_stack_dscheck.ml0000644000175000017500000001351614661627530022201 0ustar kylekylelet drain stack = let remaining = ref 0 in while not (Treiber_stack.is_empty stack) do remaining := !remaining + 1; assert (Option.is_some (Treiber_stack.pop_opt stack)) done; !remaining let producer_consumer () = Atomic.trace (fun () -> let stack = Treiber_stack.create () in let items_total = 3 in (* producer *) Atomic.spawn (fun () -> for i = 1 to items_total do Treiber_stack.push stack i done); (* consumer *) let popped = ref 0 in Atomic.spawn (fun () -> for _ = 1 to items_total do match Treiber_stack.pop_opt stack with | None -> () | Some _ -> popped := !popped + 1 done); (* checks*) Atomic.final (fun () -> Atomic.check (fun () -> let remaining = drain stack in !popped + remaining = items_total))) let two_producers () = Atomic.trace (fun () -> let stack = Treiber_stack.create () in let items_total = 4 in (* two producers *) for i = 0 to 1 do Atomic.spawn (fun () -> for j = 1 to items_total / 2 do (* even nums belong to thr 1, odd nums to thr 2 *) Treiber_stack.push stack (i + (j * 2)) done) done; (* checks*) Atomic.final (fun () -> let rec get_items s = if Treiber_stack.is_empty s then [] else let item = Option.get (Treiber_stack.pop_opt s) in item :: get_items s in let items = get_items stack in (* got the same number of items out as in *) Atomic.check (fun () -> items_total = List.length items); (* they are in lifo order *) let odd, even = List.partition (fun v -> v mod 2 == 0) items in Atomic.check (fun () -> List.sort Int.compare odd = List.rev odd); Atomic.check (fun () -> List.sort Int.compare even = List.rev even))) let two_consumers () = Atomic.trace (fun () -> let stack = Treiber_stack.create () in let items_total = 4 in for i = 1 to items_total do Treiber_stack.push stack i done; (* two consumers *) let lists = [ ref []; ref [] ] in List.iter (fun list -> Atomic.spawn (fun () -> for _ = 1 to items_total / 2 do (* even nums belong to thr 1, odd nums to thr 2 *) list := Option.get (Treiber_stack.pop_opt stack) :: !list done) |> ignore) lists; (* checks*) Atomic.final (fun () -> let l1 = !(List.nth lists 0) in let l2 = !(List.nth lists 1) in (* got the same number of items out as in *) Atomic.check (fun () -> items_total = List.length l1 + List.length l2); (* they are in lifo order *) Atomic.check (fun () -> List.sort Int.compare l1 = l1); Atomic.check (fun () -> List.sort Int.compare l2 = l2))) let two_domains () = Atomic.trace (fun () -> let stack = Treiber_stack.create () in let n1, n2 = (1, 2) in (* two producers *) let lists = [ (List.init n1 (fun i -> i), ref []); (List.init n2 (fun i -> i + n1), ref []); ] in List.iter (fun (lpush, lpop) -> Atomic.spawn (fun () -> List.iter (fun elt -> (* even nums belong to thr 1, odd nums to thr 2 *) Treiber_stack.push stack elt; lpop := Option.get (Treiber_stack.pop_opt stack) :: !lpop) lpush) |> ignore) lists; (* checks*) Atomic.final (fun () -> let lpop1 = !(List.nth lists 0 |> snd) in let lpop2 = !(List.nth lists 1 |> snd) in (* got the same number of items out as in *) Atomic.check (fun () -> List.length lpop1 = 1); Atomic.check (fun () -> List.length lpop2 = 2); (* no element are missing *) Atomic.check (fun () -> List.sort Int.compare (lpop1 @ lpop2) = List.init (n1 + n2) (fun i -> i)))) let two_domains_more_pop () = Atomic.trace (fun () -> let stack = Treiber_stack.create () in let n1, n2 = (2, 1) in (* two producers *) let lists = [ (List.init n1 (fun i -> i), ref []); (List.init n2 (fun i -> i + n1), ref []); ] in List.iter (fun (lpush, lpop) -> Atomic.spawn (fun () -> List.iter (fun elt -> Treiber_stack.push stack elt; lpop := Treiber_stack.pop_opt stack :: !lpop; lpop := Treiber_stack.pop_opt stack :: !lpop) lpush) |> ignore) lists; (* checks*) Atomic.final (fun () -> let lpop1 = !(List.nth lists 0 |> snd) |> List.filter Option.is_some |> List.map Option.get in let lpop2 = !(List.nth lists 1 |> snd) |> List.filter Option.is_some |> List.map Option.get in (* got the same number of items out as in *) Atomic.check (fun () -> n1 + n2 = List.length lpop1 + List.length lpop2); (* no element are missing *) Atomic.check (fun () -> List.sort Int.compare (lpop1 @ lpop2) = List.init (n1 + n2) (fun i -> i)))) let () = let open Alcotest in run "treiber_stack_dscheck" [ ( "basic", [ test_case "1-producer-1-consumer" `Slow producer_consumer; test_case "2-producers" `Slow two_producers; test_case "2-consumers" `Slow two_consumers; test_case "2-domains" `Slow two_domains; test_case "2-domains-more-pops" `Slow two_domains_more_pop; ] ); ] saturn-0.5.0/test/treiber_stack/qcheck_treiber_stack.ml0000644000175000017500000001433614661627530022034 0ustar kylekyleopen Saturn_lockfree.Stack let tests_sequential = QCheck. [ (* TEST 1: push *) Test.make ~name:"push" (list int) (fun lpush -> assume (lpush <> []); (* Building a random stack *) let stack = create () in List.iter (push stack) lpush; (* Testing property *) not (is_empty stack)); (* TEST 2 - push, pop until empty *) Test.make ~name:"push_pop_until_empty" (list int) (fun lpush -> (* Building a random stack *) let stack = create () in List.iter (push stack) lpush; (* Popping until [is_empty q] is true *) let count = ref 0 in while not (is_empty stack) do incr count; ignore (pop_opt stack) done; (* Testing property *) pop_opt stack = None && !count = List.length lpush); (* TEST 3 - push, pop_opt, check LIFO *) Test.make ~name:"lifo" (list int) (fun lpush -> (* Building a random stack *) let stack = create () in List.iter (push stack) lpush; let out = ref [] in let insert v = out := v :: !out in for _ = 1 to List.length lpush do match pop_opt stack with None -> assert false | Some v -> insert v done; (* Testing property *) lpush = !out); ] let tests_one_consumer_one_producer = QCheck. [ (* TEST 1 - one consumer one producer: Parallel [push] and [pop_opt]. *) Test.make ~name:"parallel" (list int) (fun lpush -> (* Initialization *) let stack = create () in let barrier = Barrier.create 2 in (* Producer pushes. *) let producer = Domain.spawn (fun () -> Barrier.await barrier; List.iter (push stack) lpush) in Barrier.await barrier; for _ = 1 to List.length lpush do while Option.is_none (pop_opt stack) do Domain.cpu_relax () done done; (* Ensure nothing is left behind. *) Domain.join producer; is_empty stack); ] let tests_two_domains = QCheck. [ (* TEST 1 - two domains doing multiple times one push then one pop. Parallel [push] and [pop]. *) Test.make ~name:"parallel_pop_push" (pair small_nat small_nat) (fun (npush1, npush2) -> (* Initialization *) let stack = create () in let barrier = Barrier.create 2 in let lpush1 = List.init npush1 (fun i -> i) in let lpush2 = List.init npush2 (fun i -> i + npush1) in let work lpush = List.map (fun elt -> push stack elt; Domain.cpu_relax (); pop_opt stack) lpush in let domain1 = Domain.spawn (fun () -> Barrier.await barrier; work lpush1) in let popped2 = Barrier.await barrier; work lpush2 in (* As a domain always pushs before popping, all pops succeeds. *) let popped1 = Domain.join domain1 |> List.map Option.get in let popped2 = List.map Option.get popped2 in (* Check 1 : no elements are missing (everyting is popped). *) let all_elt_in = List.sort compare (popped1 @ popped2) = lpush1 @ lpush2 in all_elt_in && List.length popped1 = List.length lpush1 && List.length popped2 = List.length lpush2); (* TEST 2 - Parallel [push] and [pop] with two domains Two domains randomly pushs and pops in parallel. They stop as soon as they have finished pushing a list of element to push. *) Test.make ~name:"parallel_pop_push_random" (pair small_nat small_nat) (fun (npush1, npush2) -> (* Initialization *) let stack = create () in let lpush1 = List.init npush1 (fun i -> i) in let lpush2 = List.init npush2 (fun i -> i + npush1) in let barrier = Barrier.create 2 in let work lpush = let consecutive_pop = ref 0 in let rec loop lpush popped = let what_to_do = Random.int 2 in if what_to_do = 0 || !consecutive_pop > 10 then ( (* randomly choosing between pushing and popping except if too many consecutive pops have already occurred *) consecutive_pop := 0; match lpush with | [] -> popped | elt :: xs -> push stack elt; loop xs popped) else ( incr consecutive_pop; let p = pop_opt stack in loop lpush (p :: popped)) in loop lpush [] in let domain1 = Domain.spawn (fun () -> Barrier.await barrier; work lpush1) in let popped2 = Barrier.await barrier; work lpush2 in let popped1 = Domain.join domain1 |> List.filter (function None -> false | _ -> true) |> List.map Option.get in let popped2 = popped2 |> List.filter (function None -> false | _ -> true) |> List.map Option.get in (* Pop everything that is still on the queue *) let popped3 = let rec loop popped = match pop_opt stack with | None -> popped | Some v -> loop (v :: popped) in loop [] in (* Check that no element is missing. *) let all_n_elt_in = List.sort compare (popped1 @ popped2 @ popped3) = lpush1 @ lpush2 in all_n_elt_in); ] let main () = let to_alcotest = List.map QCheck_alcotest.to_alcotest in Alcotest.run "Treiber_stack" [ ("test_sequential", to_alcotest tests_sequential); ("one_cons_one_prod", to_alcotest tests_one_consumer_one_producer); ("two_domains", to_alcotest tests_two_domains); ] ;; main () saturn-0.5.0/test/treiber_stack/dune0000644000175000017500000000145014661627530016212 0ustar kylekyle(rule (action (copy ../../src_lockfree/treiber_stack.ml treiber_stack.ml)) (package saturn_lockfree)) (test (package saturn_lockfree) (name treiber_stack_dscheck) (libraries atomic dscheck alcotest backoff multicore-magic) (build_if (and (>= %{ocaml_version} 5) (not (and (= %{arch_sixtyfour} false) (= %{architecture} arm))))) (modules treiber_stack treiber_stack_dscheck)) (test (package saturn_lockfree) (name qcheck_treiber_stack) (libraries saturn_lockfree barrier qcheck qcheck-core qcheck-alcotest domain_shims alcotest) (modules qcheck_treiber_stack)) (test (package saturn_lockfree) (name stm_treiber_stack) (modules stm_treiber_stack) (libraries saturn_lockfree qcheck-core qcheck-stm.stm stm_run) (enabled_if (= %{arch_sixtyfour} true))) saturn-0.5.0/test/atomic/0000755000175000017500000000000014661627530013767 5ustar kylekylesaturn-0.5.0/test/atomic/atomic.ml0000644000175000017500000000003514661627530015573 0ustar kylekyleinclude Dscheck.TracedAtomic saturn-0.5.0/test/atomic/dune0000644000175000017500000000012614661627530014644 0ustar kylekyle(library (name atomic) (libraries dscheck) (enabled_if (>= %{ocaml_version} 5))) saturn-0.5.0/test/mpsc_queue/0000755000175000017500000000000014661627530014661 5ustar kylekylesaturn-0.5.0/test/mpsc_queue/qcheck_mpsc_queue.ml0000644000175000017500000006503514661627530020710 0ustar kylekylemodule Mpsc_queue = Saturn_lockfree.Single_consumer_queue (* Mpsc_queue is a multiple producers, single consumer queue. *) (* Producers can use the functions - [push], - [is_empty], - [close] *) (* Consumer can use the functions - [pop], - [push], - [push_head], - [is_empty], - [close] *) let extract_n q n close = let rec loop acc = function | 0 -> acc | m -> if m = n - close then Mpsc_queue.close q; let res = match Mpsc_queue.pop_opt q with | Some elt -> `Some elt | None -> `None | exception Mpsc_queue.Closed -> `Closed in Domain.cpu_relax (); loop (res :: acc) (m - 1) in if n < 0 then failwith "Number of pop should be positive."; loop [] n |> List.rev let extract_n_with_peek q n close = let rec loop peeked popped = function | 0 -> (peeked, popped) | m -> if m = n - close then Mpsc_queue.close q; let peek = match Mpsc_queue.peek_opt q with | Some elt -> `Some elt | None -> `None | exception Mpsc_queue.Closed -> `Closed in let pop = match Mpsc_queue.pop_opt q with | Some elt -> `Some elt | None -> `None | exception Mpsc_queue.Closed -> `Closed in Domain.cpu_relax (); loop (peek :: peeked) (pop :: popped) (m - 1) in if n < 0 then failwith "Number of pop should be positive."; let peeked, popped = loop [] [] n in (List.rev peeked, List.rev popped) let popped_until_empty_and_closed q = let rec loop acc = try let popped = Mpsc_queue.pop_opt q in Domain.cpu_relax (); loop (popped :: acc) with Mpsc_queue.Closed -> acc in loop [] |> List.rev let keep_n_first n = List.filteri (fun i _ -> i < n) let keep_n_last n l = List.filteri (fun i _ -> i >= List.length l - n) l let list_some = List.map (fun elt -> `Some elt) (* With just one consumer, the [Mpsc_queue] is basically a LIFO. *) let tests_one_consumer = QCheck. [ (* TEST 1 - single consumer no producer: forall q and n, pop_opt (push_head q i; q) = Some i*) Test.make ~name:"push_head_pop_opt" (pair (list int) int) (fun (lpush, i) -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Testing property *) Mpsc_queue.push_head queue i; Mpsc_queue.pop_opt queue = Some i); (* TEST 1b - single consumer no producer: forall q and n, pop (push_head q i; q) = i*) Test.make ~name:"push_head_pop" (pair (list int) int) (fun (lpush, i) -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Testing property *) Mpsc_queue.push_head queue i; try Mpsc_queue.pop queue = i with Mpsc_queue.Empty -> false); (* TEST 1c - single consumer no producer: forall q and n, peek_opt (push_head q i; q) = Some i*) Test.make ~name:"push_head_peek_opt" (pair (list int) int) (fun (lpush, i) -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Testing property *) Mpsc_queue.push_head queue i; Mpsc_queue.peek_opt queue = Some i); (* TEST 1d - single consumer no producer: forall q and n, peek (push_head q i; q) = Some i*) Test.make ~name:"push_head_peek" (pair (list int) int) (fun (lpush, i) -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Testing property *) Mpsc_queue.push_head queue i; try Mpsc_queue.peek queue = i with Mpsc_queue.Empty -> false); (* TEST 2 - single consumer no producer: forall q, if is_empty q then pop_opt queue = None *) Test.make ~name:"pop_opt_empty" (list int) (fun lpush -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Popping until [is_empty q] is true*) let count = ref 0 in while not (Mpsc_queue.is_empty queue) do incr count; ignore (Mpsc_queue.pop_opt queue) done; (* Testing property *) Mpsc_queue.pop_opt queue = None && !count = List.length lpush); (* TEST 2b - single consumer no producer: forall q, if is_empty q then pop queue raises Empty *) Test.make ~name:"pop_empty" (list int) (fun lpush -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Popping until [is_empty q] is true*) let count = ref 0 in while not (Mpsc_queue.is_empty queue) do incr count; ignore (Mpsc_queue.pop_opt queue) done; (* Testing property *) (try ignore (Mpsc_queue.pop queue); false with Mpsc_queue.Empty -> true) && !count = List.length lpush); (* TEST 2 - single consumer no producer: forall q, if is_empty q then peek_opt queue = None *) Test.make ~name:"peek_opt_empty" (list int) (fun lpush -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Popping until [is_empty q] is true*) let count = ref 0 in while not (Mpsc_queue.is_empty queue) do incr count; ignore (Mpsc_queue.pop_opt queue) done; (* Testing property *) Mpsc_queue.peek_opt queue = None && !count = List.length lpush); (* TEST 2b - single consumer no producer: forall q, if is_empty q then peek queue raises Empty *) Test.make ~name:"peek_empty" (list int) (fun lpush -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Popping until [is_empty q] is true*) let count = ref 0 in while not (Mpsc_queue.is_empty queue) do incr count; ignore (Mpsc_queue.pop_opt queue) done; (* Testing property *) (try ignore (Mpsc_queue.peek queue); false with Mpsc_queue.Empty -> true) && !count = List.length lpush); (* TEST 3 - single consumer no producer: forall q and i, push_head q i; is_empty q = false*) Test.make ~name:"push_head_not_empty" (list int) (fun lpush -> assume (lpush <> []); (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Testing property *) not (Mpsc_queue.is_empty queue)); (* TEST 4 - single consumer no producer: forall q and i, [close q; push_head q i] raises Closed <=> q is empty. *) Test.make ~name:"close_push_head" (pair (list int) int) (fun (lpush, i) -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* is_empty raises Close if the queue is closed and empty, so we need to register its value before closing. Next test checks [is_empty] behaviour on a closed queue. *) let is_empty = Mpsc_queue.is_empty queue in Mpsc_queue.close queue; (* Testing property *) if is_empty then try Mpsc_queue.push_head queue i; false with Mpsc_queue.Closed -> true else try Mpsc_queue.push_head queue i; true with Mpsc_queue.Closed -> false); (* TEST 5 - single consumer no producer: This test works also for one producer no consumer. forall q and i, [close q; is_empty q] raises Closed <=> q is empty *) Test.make ~name:"close_is_empty" (list int) (fun lpush -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); let is_empty = Mpsc_queue.is_empty queue in Mpsc_queue.close queue; (* Testing property *) if is_empty then try ignore (Mpsc_queue.is_empty queue); false with Mpsc_queue.Closed -> true else try Mpsc_queue.is_empty queue = false with Mpsc_queue.Closed -> false); (* TEST 6 - single consumer no producer: forall q and i, [close q; pop q] raises Closed <=> q is empty *) Test.make ~name:"close_pop_opt" (list int) (fun lpush -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); let is_empty = Mpsc_queue.is_empty queue in Mpsc_queue.close queue; (* Testing property *) if is_empty then try ignore (Mpsc_queue.pop_opt queue); false with Mpsc_queue.Closed -> true else try Mpsc_queue.pop_opt queue = Some (List.hd lpush) with Mpsc_queue.Closed -> false); (* TEST 7 - single consumer no producer: More complex test. Maybe redondant with tests 1 to 6. Sequentially does n [push_head] then m [pop_opt], [close] and may call [pop] again. Checks : - that closing the queue does not prevent [pop_opt] - [pop_opt] order (it's a LIFO) - [pop_opt] on a [close]d and empty queue raises [Closed] *) Test.make ~name:"pop_opt_order" (pair (list int) (pair small_nat small_nat)) (fun (lpush, (npop, when_close)) -> (* Initialisation*) let npush = List.length lpush in let queue = Mpsc_queue.create () in (* Sequential [push_head] *) List.iter (fun elt -> Mpsc_queue.push_head queue elt) (List.rev lpush); (* Call [pop_opt] [npop] times and [close] after [when_close] pops. *) let popped = extract_n queue npop when_close in let expected = List.init npop (fun i -> if npop <= npush then (* Closing the queue does not prevent popping *) `Some (List.nth lpush i) else if npush <= npop && npop <= when_close then if i < npush then `Some (List.nth lpush i) else `None else if npush <= when_close && when_close <= npop then if i < npush then `Some (List.nth lpush i) else if i < when_close then `None else `Closed else if when_close <= npush && npush <= npop then if i < npush then `Some (List.nth lpush i) else `Closed else failwith "should not happen") in expected = popped); (* TEST 8 - single consumer no producer: More complex test. Maybe redondant with tests 1 to 6. Sequentially does n [push_head], followed by m [pop_opt] and n' more [push_head]. Checks : - order of [pop_opt] and [push_head] -> LIFO *) Test.make ~name:"seq_push_pop_opt" (pair small_nat (pair (list int) (list int))) (fun (npop, (lpush1, lpush2)) -> (* Initialisation*) let queue = Mpsc_queue.create () in (* Sequential [push_head] *) List.iter (fun elt -> Mpsc_queue.push_head queue elt) lpush1; (* Call [pop_opt] [npop] times without closing. *) let popped = extract_n queue npop (npop + 1) in (* Sequential [push_head] *) List.iter (fun elt -> Mpsc_queue.push_head queue elt) lpush2; (* Dequeue and closing *) let size_queue = List.length lpush2 + Int.max 0 (List.length lpush1 - npop) in let final = extract_n queue size_queue 0 in if npop <= List.length lpush1 then let expected_final = keep_n_first (List.length lpush1 - npop) lpush1 @ lpush2 |> list_some in let expected_popped = keep_n_first npop (List.rev lpush1) |> list_some in List.rev final = expected_final && popped = expected_popped else let expected_popped = (List.rev lpush1 |> list_some) @ List.init (npop - List.length lpush1) (fun _ -> `None) in List.rev final = list_some lpush2 && popped = expected_popped); ] (* With just one producer, only the [push], [empty] and [close] functions can be used. *) let tests_one_producer = QCheck. [ (* TEST 1 - single producer no consumer: forall l and q built by pushing each element of l, is_empty q = true <=> l = [] *) Test.make ~name:"push_not_empty" (list int) (fun lpush -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push queue elt) lpush; (* Testing property *) match lpush with | [] -> Mpsc_queue.is_empty queue | _ -> not (Mpsc_queue.is_empty queue)); (* TEST 2 - single producer no consumer: forall q and i, [close q; push q i] raises Closed. *) Test.make ~name:"closing_prevents_pushing" (pair (list int) int) (fun (lpush, i) -> (* Building a random queue *) let queue = Mpsc_queue.create () in List.iter (fun elt -> Mpsc_queue.push queue elt) lpush; Mpsc_queue.close queue; (* Testing property *) try Mpsc_queue.push queue i; false with Mpsc_queue.Closed -> true); ] let tests_one_consumer_one_producer = QCheck. [ (* TEST 1 - one consumer one producer: Sequential [push] then several [peek_opt] followed by [pop_opt]. Checks [peek_opt] and [pop_opt] are in FIFO order. *) Test.make ~name:"seq_push_pop_opt_peek_opt" (pair (list int) small_nat) (fun (lpush, npop) -> (* Initialization *) let queue = Mpsc_queue.create () in (* Producer pushes. *) let producer = Domain.spawn (fun () -> List.iter (fun elt -> Mpsc_queue.push queue elt) lpush) in (* Sequential test: we wait for the producer to be finished *) let () = Domain.join producer in let peeked, popped = extract_n_with_peek queue npop (npop + 1) in (* Testing property *) let expected = (keep_n_first npop lpush |> list_some) @ List.init (Int.max 0 (npop - List.length lpush)) (fun _ -> `None) in popped = expected && peeked = expected); (* TEST 2 - one consumer one producer: Parallel [push], [pop_opt], [peek_opt]. *) Test.make ~name:"par_push_pop" (pair (list int) small_nat) (fun (lpush, npop) -> (* Initialization *) let queue = Mpsc_queue.create () in let barrier = Barrier.create 2 in (* Producer pushes. *) let producer = Domain.spawn (fun () -> Barrier.await barrier; try List.iter (fun elt -> Mpsc_queue.push queue elt; Domain.cpu_relax ()) lpush; false with Mpsc_queue.Closed -> true) in (* Waiting to make sure the producer can start *) Barrier.await barrier; (* Consumer pops. *) let peeked, popped = extract_n_with_peek queue npop (npop + 1) in let closed = Domain.join producer in let popped_value = List.filter (function `Some _ -> true | _ -> false) popped in let rec check pushed peeked popped = match (pushed, peeked, popped) with | _, [], [] -> true | _, `None :: peeked, `None :: popped -> check pushed peeked popped | push :: pushed, `None :: peeked, `Some pop :: popped when pop = push -> check pushed peeked popped | push :: pushed, `Some peek :: peeked, `Some pop :: popped when pop = push && pop = peek -> check pushed peeked popped | _, _, _ -> false in (* Testing property *) (not closed) && List.length popped = npop && popped_value = (keep_n_first (List.length popped_value) lpush |> list_some) && (List.for_all (function | `Some _ | `None -> true | `Closed -> false)) popped && check lpush peeked popped); (* TEST 3 - one consumer one producer: Parallel [push] and [push_head]. *) Test.make ~name:"par_push_push_head" (pair (list int) (list int)) (fun (lpush, lpush_head) -> (* Initialization *) let queue = Mpsc_queue.create () in let barrier = Barrier.create 2 in (* Producer pushes. *) let producer = Domain.spawn (fun () -> Barrier.await barrier; try List.iter (fun elt -> Mpsc_queue.push queue elt; Domain.cpu_relax ()) lpush; false with Mpsc_queue.Closed -> true) in (* Waiting to make sure the producer can start *) Barrier.await barrier; List.iter (fun elt -> Mpsc_queue.push_head queue elt) lpush_head; let closed = Domain.join producer in (* We pop everything to check order.*) let total_push = List.length lpush + List.length lpush_head in let all_pushed = extract_n queue total_push (total_push + 1) in (* Testing property *) (not closed) && Mpsc_queue.is_empty queue && keep_n_first (List.length lpush_head) all_pushed = list_some (lpush_head |> List.rev) && keep_n_last (List.length lpush) all_pushed = list_some lpush); (* TEST 4 - one consumer one producer Consumer push then close while consumer pop_opt until the queue is empty and closed. *) Test.make ~name:"par_pop_opt_push2" (list int) (fun lpush -> (* Initialisation*) let queue = Mpsc_queue.create () in let barrier = Barrier.create 2 in (* Sequential [push_head] *) let producer = Domain.spawn (fun () -> Barrier.await barrier; let res = try List.iter (fun elt -> Mpsc_queue.push queue elt; Domain.cpu_relax ()) lpush; false with Mpsc_queue.Closed -> true in Mpsc_queue.close queue; res) in Barrier.await barrier; let popped = popped_until_empty_and_closed queue in let unexpected_closed = Domain.join producer in let popped_value = List.filter (function Some _ -> true | _ -> false) popped in (not unexpected_closed) && lpush |> List.map (fun elt -> Some elt) = popped_value); ] let tests_one_consumer_two_producers = QCheck. [ (* TEST 1 - one consumer two producers: Two producers push at the same time. Checks that producers do not erase each other [pushes]. *) Test.make ~name:"par_push" (pair (list int) (list int)) (fun (lpush1, lpush2) -> (* Initialization *) let npush1, npush2 = (List.length lpush1, List.length lpush2) in let queue = Mpsc_queue.create () in let barrier = Barrier.create 2 in let multi_push lpush = Barrier.await barrier; try List.iter (fun elt -> Mpsc_queue.push queue elt; Domain.cpu_relax ()) lpush; false with Mpsc_queue.Closed -> true in (* Producers pushes. *) let producer1 = Domain.spawn (fun () -> multi_push lpush1) in let producer2 = Domain.spawn (fun () -> multi_push lpush2) in let closed1 = Domain.join producer1 in let closed2 = Domain.join producer2 in Mpsc_queue.close queue; (* Retrieve pushed values. *) let popped = popped_until_empty_and_closed queue in let popped_value = List.fold_left (fun acc elt -> match elt with Some elt -> elt :: acc | _ -> acc) [] popped |> List.rev in let rec compare l l1 l2 = match (l, l1, l2) with | [], [], [] -> true | [], _, _ -> false | _, [], _ -> l = l2 | _, _, [] -> l = l1 | x :: l', y :: l1', z :: l2' -> if x = y && x = z then compare l' l1 l2' || compare l' l1' l2 else if x = y then compare l' l1' l2 else if x = z then compare l' l1 l2' else false in (* Testing property : - no Close exception raised before the queue being actually closed - all pushed values are in the queue *) (not closed1) && (not closed2) && List.length popped_value = npush1 + npush2 && compare popped_value lpush1 lpush2); (* TEST 2 - one consumer two producers: Two producers push and close the queue when one has finished pushing. At the same time a consumer popes. Checks that closing the queue prevent other producers to push and that popping at the same time works. *) Test.make ~name:"par_push_close_pop_opt" (pair (list int) (list int)) (fun (lpush1, lpush2) -> (* Initialization *) let npush1, npush2 = (List.length lpush1, List.length lpush2) in let queue = Mpsc_queue.create () in let barrier = Barrier.create 3 in let guard_push lpush = Barrier.await barrier; let closed_when_pushing = try List.iter (fun elt -> Mpsc_queue.push queue elt; Domain.cpu_relax ()) lpush; false with Mpsc_queue.Closed -> true in ( closed_when_pushing, try Mpsc_queue.close queue; true with Mpsc_queue.Closed -> false ) in (* Producers pushes. *) let producer1 = Domain.spawn (fun () -> guard_push lpush1) in let producer2 = Domain.spawn (fun () -> guard_push lpush2) in (* Waiting to make sure the producers have time to start. However, as the consumer will [pop_opt] until one of the producer closes the queue, it is not a requirement to wait here. *) Barrier.await barrier; let popped = popped_until_empty_and_closed queue in let closed_when_pushing1, has_closed1 = Domain.join producer1 in let closed_when_pushing2, has_closed2 = Domain.join producer2 in let popped_value = List.fold_left (fun acc elt -> match elt with Some elt -> elt :: acc | _ -> acc) [] popped |> List.rev in let rec compare l l1 l2 = match (l, l1, l2) with | [], [], [] -> true | [], _, _ -> false | _, [], _ -> l = l2 | _, _, [] -> l = l1 | x :: l', y :: l1', z :: l2' -> if x = y && x = z then compare l' l1 l2' || compare l' l1' l2 else if x = y then compare l' l1' l2 else if x = z then compare l' l1 l2' else false in (* Testing property : - there should be only 4 workings combinaisons for the boolean values [closed_when_pushing] and [has_closed] : + CASE 1 : if producer 1 closed the queue before producer 2 have finised pushing. In this case returned values will be: 1 -> false, true / 2 -> true, false + CASE 2 : if producer 1 closed the queue and producer 2 have finised pushing but have not closed the queue. 1 -> false, true / 2 -> false, false + two symetrical cases. - in case 1, the closing producer should have pushed everything but not the other. - in case 2, both queues should have finished pushing. *) match ( closed_when_pushing1, has_closed1, closed_when_pushing2, has_closed2 ) with | false, true, true, false -> (* CASE 1 *) let real_npush2 = List.length popped_value - npush1 in real_npush2 < npush2 && compare popped_value lpush1 (keep_n_first real_npush2 lpush2) | true, false, false, true -> (* CASE 1, sym *) let real_npush1 = List.length popped_value - npush2 in real_npush1 < npush1 && compare popped_value (keep_n_first real_npush1 lpush1) lpush2 | false, true, false, false | false, false, false, true -> (* CASE 2*) List.length popped_value = npush1 + npush2 && compare popped_value lpush1 lpush2 | _, _, _, _ -> false); ] let main () = let to_alcotest = List.map QCheck_alcotest.to_alcotest in Alcotest.run "Mpsc_queue" [ ("one_consumer", to_alcotest tests_one_consumer); ("one_producer", to_alcotest tests_one_producer); ("one_cons_one_prod", to_alcotest tests_one_consumer_one_producer); ("one_cons_two_prod", to_alcotest tests_one_consumer_two_producers); ] ;; main () saturn-0.5.0/test/mpsc_queue/stm_mpsc_queue.ml0000644000175000017500000001004314661627530020242 0ustar kylekyle(** Sequential and Parallel model-based tests of mpsc_queue *) open QCheck open STM open Util module Mpsc_queue = Saturn_lockfree.Single_consumer_queue module Spec = struct type cmd = Push of int | Pop | Peek | Push_head of int | Is_empty | Close let show_cmd c = match c with | Push i -> "Push " ^ string_of_int i | Pop -> "Pop" | Peek -> "Peek" | Push_head i -> "Push_head" ^ string_of_int i | Is_empty -> "Is_empty" | Close -> "Close" type state = bool * int list type sut = int Mpsc_queue.t let producer_cmd _s = let int_gen = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [ Gen.map (fun i -> Push i) int_gen; Gen.return Is_empty; Gen.return Close; ]) let arb_cmd _s = let int_gen = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [ Gen.return Pop; Gen.return Peek; Gen.map (fun i -> Push i) int_gen; Gen.map (fun i -> Push_head i) int_gen; Gen.return Is_empty; Gen.return Close; ]) let init_state = (false, []) let init_sut () = Mpsc_queue.create () let cleanup _ = () let next_state c (is_closed, s) = match c with | Push i -> (is_closed, if not is_closed then i :: List.rev s |> List.rev else s) | Push_head i -> (is_closed, if not (is_closed && s = []) then i :: s else s) | Is_empty -> (is_closed, s) | Pop -> (is_closed, match s with [] -> s | _ :: s' -> s') | Peek -> (is_closed, s) | Close -> (true, s) let precond _ _ = true let run c d = match c with | Push i -> Res (result unit exn, protect (fun d -> Mpsc_queue.push d i) d) | Pop -> Res (result int exn, protect Mpsc_queue.pop d) | Peek -> Res (result int exn, protect Mpsc_queue.peek d) | Push_head i -> Res (result unit exn, protect (fun d -> Mpsc_queue.push_head d i) d) | Is_empty -> Res (result bool exn, protect Mpsc_queue.is_empty d) | Close -> Res (result unit exn, protect Mpsc_queue.close d) let postcond c ((is_closed, s) : state) res = match (c, res) with | Push _, Res ((Result (Unit, Exn), _), res) -> if is_closed then res = Error Mpsc_queue.Closed else res = Ok () | Push_head _, Res ((Result (Unit, Exn), _), res) -> if is_closed && s = [] then res = Error Mpsc_queue.Closed else res = Ok () | (Pop | Peek), Res ((Result (Int, Exn), _), res) -> ( match s with | [] -> if is_closed then res = Error Mpsc_queue.Closed else res = Error Mpsc_queue.Empty | x :: _ -> res = Ok x) | Is_empty, Res ((Result (Bool, Exn), _), res) -> if is_closed && s = [] then res = Error Mpsc_queue.Closed else res = Ok (s = []) | Close, Res ((Result (Unit, Exn), _), res) -> if is_closed then res = Error Mpsc_queue.Closed else res = Ok () | _, _ -> false end let () = let make_domain ~count ~name (module Dom : Stm_run.STM_domain with type Spec.cmd = Spec.cmd and type Spec.state = Spec.state and type Spec.sut = Spec.sut) = (* [arb_cmds_par] differs in what each triple component generates: "Consumer domain" cmds can't be [Push] (but can be [Pop], [Is_empty], [Close] or [Push_head]), "producer domain" cmds can't be [Push_head] or [Pop] (but can be [Push], [Is_empty] or [Close]). *) let arb_cmds_par = Dom.arb_triple 20 12 Spec.arb_cmd Spec.arb_cmd Spec.producer_cmd in (* A parallel agreement test - w/repeat and retries combined *) let agree_test_par_asym ~count ~name = let rep_count = 50 in Test.make ~retries:10 ~count ~name arb_cmds_par (fun triple -> assume (Dom.all_interleavings_ok triple); repeat rep_count Dom.agree_prop_par_asym triple) in [ agree_test_par_asym ~count ~name:(name ^ " parallel"); Dom.neg_agree_test_par ~count ~name:(name ^ " parallel, negative"); ] in Stm_run.run ~count:1000 ~name:"Saturn_lockfree.Mpsc_queue" ~verbose:true ~make_domain (module Spec) |> exit saturn-0.5.0/test/mpsc_queue/mpsc_queue_dscheck.ml0000644000175000017500000000634714661627530021057 0ustar kylekylelet drain queue = let remaining = ref 0 in while not (Mpsc_queue.is_empty queue) do remaining := !remaining + 1; assert (Option.is_some (Mpsc_queue.pop_opt queue)) done; !remaining let producer_consumer () = Atomic.trace (fun () -> let queue = Mpsc_queue.create () in let items_total = 4 in (* producer *) Atomic.spawn (fun () -> for _ = 1 to items_total - 1 do Mpsc_queue.push queue 0 done); (* consumer *) let popped = ref 0 in Atomic.spawn (fun () -> Mpsc_queue.push_head queue 1; for _ = 1 to items_total do match Mpsc_queue.pop_opt queue with | None -> () | Some _ -> popped := !popped + 1 done); (* checks*) Atomic.final (fun () -> Atomic.check (fun () -> let remaining = drain queue in !popped + remaining = items_total))) let producer_consumer_peek () = Atomic.trace (fun () -> let queue = Mpsc_queue.create () in let items_total = 1 in let pushed = List.init items_total (fun i -> i) in (* producer *) Atomic.spawn (fun () -> List.iter (fun elt -> Mpsc_queue.push queue elt) pushed); (* consumer *) let popped = ref [] in let peeked = ref [] in Atomic.spawn (fun () -> for _ = 1 to items_total do peeked := Mpsc_queue.peek_opt queue :: !peeked; popped := Mpsc_queue.pop_opt queue :: !popped done); (* checks*) Atomic.final (fun () -> Atomic.check (fun () -> let rec check pushed peeked popped = match (pushed, peeked, popped) with | _, [], [] -> true | _, None :: peeked, None :: popped -> check pushed peeked popped | push :: pushed, None :: peeked, Some pop :: popped when push = pop -> check pushed peeked popped | push :: pushed, Some peek :: peeked, Some pop :: popped when push = peek && push = pop -> check pushed peeked popped | _, _, _ -> false in check pushed (List.rev !peeked) (List.rev !popped)); Atomic.check (fun () -> let remaining = drain queue in let popped = List.filter Option.is_some !popped in List.length popped + remaining = items_total))) let two_producers () = Atomic.trace (fun () -> let queue = Mpsc_queue.create () in let items_total = 4 in (* producers *) for _ = 1 to 2 do Atomic.spawn (fun () -> for _ = 1 to items_total / 2 do Mpsc_queue.push queue 0 done) done; (* checks*) Atomic.final (fun () -> Atomic.check (fun () -> let remaining = drain queue in remaining = items_total))) let () = let open Alcotest in run "mpsc_queue_dscheck" [ ( "basic", [ test_case "1-producer-1-consumer" `Slow producer_consumer; test_case "1-producer-1-consumer-peek" `Slow producer_consumer_peek; test_case "2-producers" `Slow two_producers; ] ); ] saturn-0.5.0/test/mpsc_queue/dune0000644000175000017500000000130014661627530015531 0ustar kylekyle(rule (action (copy ../../src_lockfree/mpsc_queue.ml mpsc_queue.ml)) (package saturn_lockfree)) (test (package saturn_lockfree) (name mpsc_queue_dscheck) (libraries atomic dscheck alcotest) (build_if (>= %{ocaml_version} 5)) (modules mpsc_queue mpsc_queue_dscheck)) (test (package saturn_lockfree) (name qcheck_mpsc_queue) (libraries saturn_lockfree barrier qcheck qcheck-core qcheck-alcotest domain_shims alcotest) (modules qcheck_mpsc_queue)) (test (package saturn_lockfree) (name stm_mpsc_queue) (modules stm_mpsc_queue) (libraries saturn_lockfree qcheck-core qcheck-multicoretests-util qcheck-stm.stm stm_run) (enabled_if (= %{arch_sixtyfour} true))) saturn-0.5.0/Makefile0000644000175000017500000000022414661627530013172 0ustar kylekyle.PHONY: all clean test bench all: dune build test: dune runtest clean: dune clean bench: @dune exec --release -- ./bench/main.exe -budget 1 saturn-0.5.0/saturn_lockfree.opam0000644000175000017500000000240614661627530015602 0ustar kylekyleversion: "0.5.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Collection of lock-free data structures for Multicore OCaml" maintainer: ["Carine Morel" "KC Sivaramakrishnan" "Sudha Parimala"] authors: ["KC Sivaramakrishnan"] license: "ISC" homepage: "https://github.com/ocaml-multicore/saturn" doc: "https://ocaml-multicore.github.io/saturn/" bug-reports: "https://github.com/ocaml-multicore/saturn/issues" depends: [ "dune" {>= "3.14"} "ocaml" {>= "4.13"} "domain_shims" {>= "0.1.0" & with-test} "backoff" {>= "0.1.0"} "multicore-magic" {>= "2.3.0"} "multicore-magic-dscheck" {>= "2.3.0" & with-test} "alcotest" {>= "1.7.0" & with-test} "qcheck" {>= "0.21.3" & with-test} "qcheck-core" {>= "0.21.3" & with-test} "qcheck-stm" {>= "0.3" & with-test} "qcheck-multicoretests-util" {>= "0.3" & with-test} "qcheck-alcotest" {>= "0.21.3" & with-test} "yojson" {>= "2.0.2" & with-test} "dscheck" {>= "0.5.0" & with-test} "sherlodoc" {>= "0.2" & with-doc} "odoc" {>= "2.4.1" & with-doc} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/ocaml-multicore/saturn.git"saturn-0.5.0/CODE_OF_CONDUCT.md0000644000175000017500000000076614661627530014344 0ustar kylekyle# Code of Conduct This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). # Enforcement This project follows the OCaml Code of Conduct [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). To report any violations, please contact: * Bartosz Modelski * Carine Morel * Sudha Parimala saturn-0.5.0/CHANGES.md0000644000175000017500000000361714661627530013135 0ustar kylekyle### 0.5.0 - Optimized Michael-Scott queue with a safe and an unsafe versions (@lyrm, @polytypic) - Optimize spsc queue : unsafe optimizations (@lyrm, @polytypic) - Optimize spsc queue : optimizations without Obj.magic (@lyrm, @polytypic) - Tweak treiber stack (@polytypic) - Disable implicit transitive dependencies (@polytypic) - Fix dune rules to specify package (@polytypic) - Lock free skiplist with size (@polytypic, @lyrm, @sooraj-srini) - Wait-free size for lock free data structures (@polytypic, @lyrm, @nikochiko) ### 0.4.1 - pop_opt, peek, peek_opt functions for queue (@lyrm) - Remove 'name' field from benchmark results (@Sudha247) - Better README (@lyrm, @Sudha247, @polytypic, @art-w, @christinerose, @ILeandersson, @kayceesrk) - Add .nojekyll (@lyrm) - Add a barrier module in tests to replace the use of Semaphore (@lyrm, @polytypic) - Remove .merlin and .ocp-indent files. (@lyrm) - Correct issue caused by saturn_lockfree module beeing named Lockfree (@lyrm) - Generate opam files automatically (@sudha247) ## 0.4.0 - Add docs and rename/refactor to add a lockfree package (@lyrm) - CI clean up and set up Windows CI (@lyrm) - Adopt OCaml Code of Conduct (@Sudha247) - Mark alcotest as a test dependency (@Khady) - Set QCHECK_MSG_INTERVAL to avoid clutter in CI logs (@jmid) - Fix space leaks in MS Queue (@polytypic, @lyrm) - Add STM tests for current data structures (@lyrm, @jmid) ## 0.3.1 - Rework dscheck integration to work with utop (@lyrm) - Add OCaml 4 compatability (@sudha247) - Add STM ws_deque tests (@jmid, @lyrm) ## 0.3.0 - Add MPSC queue (@lyrm) - Add SPSC queue (@bartoszmodelski) - Add MPMC relaxed queue (@bartoszmodelski, @lyrm) - Add Michael-Scott Queue (@tmcgilchrist, @bartoszmodelski, @lyrm) - Add Treiber Stack (@tmcgilchrist , @bartoszmodelski, @lyrm) - Integrate model-checker (DSCheck) (@bartoszmodelski) ## v0.2.0 - Add Chase-Lev Work-stealing deque `Ws_deque`. (@ctk21) saturn-0.5.0/.github/0000755000175000017500000000000014661627530013074 5ustar kylekylesaturn-0.5.0/.github/workflows/0000755000175000017500000000000014661627530015131 5ustar kylekylesaturn-0.5.0/.github/workflows/main.yml0000644000175000017500000000220514661627530016577 0ustar kylekylename: main on: pull_request: push: branches: - main schedule: # Prime the caches every Monday - cron: 0 1 * * MON jobs: windows: strategy: fail-fast: false matrix: ocaml-compiler: - ocaml.5.0.0,ocaml-option-mingw - ocaml.5.1.1,ocaml-option-mingw - ocaml.5.2.0,ocaml-option-mingw runs-on: windows-latest env: QCHECK_MSG_INTERVAL: '60' steps: - name: Check out code uses: actions/checkout@v2 - name: Set up OCaml uses: ocaml/setup-ocaml@v2 with: opam-pin: false opam-depext: false ocaml-compiler: ${{ matrix.ocaml-compiler }} opam-repositories: | dra27: https://github.com/dra27/opam-repository.git#windows-5.0 default: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset upstream: https://github.com/ocaml/opam-repository.git - name: Install dependencies run: opam install . --deps-only --with-test - name: Build run: opam exec -- dune build - name: Test run: opam exec -- dune runtest