From 88cfb697ee2423534b57fe8bef76b3f091f9ef71 Mon Sep 17 00:00:00 2001 From: Carine Morel Date: Mon, 6 Jan 2025 15:29:43 +0100 Subject: [PATCH] Update ocamlformat version. --- .ocamlformat | 2 +- src/ArrayExtra.ml | 18 +- src/bag.mli | 78 +++--- src/bounded_queue/bounded_queue.body.ml | 5 +- src/bounded_queue/bounded_queue.mli | 11 +- src/bounded_queue/bounded_queue_intf.mli | 103 +++---- src/bounded_queue/bounded_queue_unsafe.mli | 11 +- src/bounded_stack.mli | 197 +++++++------ src/htbl/htbl.body.ml | 56 ++-- src/htbl/htbl.mli | 6 +- src/htbl/htbl_intf.mli | 165 +++++------ src/htbl/htbl_unsafe.mli | 6 +- .../michael_scott_queue.ml | 4 +- .../michael_scott_queue.mli | 19 +- .../michael_scott_queue_intf.mli | 185 ++++++------- .../michael_scott_queue_unsafe.ml | 4 +- .../michael_scott_queue_unsafe.mli | 20 +- src/mpsc_queue.ml | 2 +- src/mpsc_queue.mli | 262 +++++++++--------- src/saturn.mli | 20 +- src/size.ml | 16 +- src/size.mli | 55 ++-- src/skiplist.ml | 6 +- src/skiplist.mli | 142 +++++----- src/spsc_queue/spsc_queue.mli | 11 +- src/spsc_queue/spsc_queue_intf.mli | 248 ++++++++--------- src/spsc_queue/spsc_queue_unsafe.ml | 2 +- src/spsc_queue/spsc_queue_unsafe.mli | 11 +- src/treiber_stack.mli | 224 ++++++++------- src/ws_deque.ml | 2 +- src/ws_deque.mli | 109 ++++---- test/barrier/barrier.mli | 48 ++-- test/bounded_queue/stm_bounded_queue.ml | 3 +- test/size/linked_set.ml | 2 +- test/skiplist/dscheck_skiplist.ml | 12 +- test/ws_deque/test_ws_deque.ml | 6 +- 36 files changed, 1013 insertions(+), 1058 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 79ff3653..ffb06fc4 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ profile = default -version = 0.26.2 +version = 0.27.0 exp-grouping=preserve diff --git a/src/ArrayExtra.ml b/src/ArrayExtra.ml index 15861b1b..b0d0021f 100644 --- a/src/ArrayExtra.ml +++ b/src/ArrayExtra.ml @@ -1,9 +1,9 @@ (* 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 +(** [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. *) @@ -22,12 +22,12 @@ let blit_circularly_dst a1 i1 a2 i2 k = 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. *) + 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. *) diff --git a/src/bag.mli b/src/bag.mli index b910f19f..fbda7581 100644 --- a/src/bag.mli +++ b/src/bag.mli @@ -20,43 +20,41 @@ val pop_exn : 'v t -> 'v @raise Empty if the [bag] is empty. *) val pop_opt : 'v t -> 'v option -(** [pop_opt bag] removes and returns [Some] of a random element of the [bag] -and [None] if the [bag] is empty. *) - -(** {1 Example} - -{[ - # Random.init 0 - - : unit = () - # module Bag = Saturn.Bag - module Bag = Saturn.Bag - # let t : string Bag.t = Bag.create () - val t : string Bag.t = - - # let planets = ["Mercury"; "Venus"; "Earth"; "Mars"; "Jupiter"; "Saturn"; "Uranus"; "Neptune"] - val planets : string list = - ["Mercury"; "Venus"; "Earth"; "Mars"; "Jupiter"; "Saturn"; "Uranus"; - "Neptune"] - # List.iter (Bag.push t) planets - - : unit = () - # Bag.pop_exn t - - : string = "Neptune" - # Bag.pop_opt t - - : string option = Some "Saturn" - # Bag.pop_exn t - - : string = "Mercury" - # Bag.pop_exn t - - : string = "Mars" - # Bag.pop_exn t - - : string = "Earth" - # Bag.pop_exn t - - : string = "Venus" - # Bag.pop_exn t - - : string = "Uranus" - # Bag.pop_exn t - - : string = "Jupiter" - # Bag.pop_exn t - Exception: Saturn__Bag.Empty. -]} - -*) +(** [pop_opt bag] removes and returns [Some] of a random element of the [bag] + and [None] if the [bag] is empty. *) + +(** {1 Example} + + {[ + # Random.init 0 + - : unit = () + # module Bag = Saturn.Bag + module Bag = Saturn.Bag + # let t : string Bag.t = Bag.create () + val t : string Bag.t = + + # let planets = ["Mercury"; "Venus"; "Earth"; "Mars"; "Jupiter"; "Saturn"; "Uranus"; "Neptune"] + val planets : string list = + ["Mercury"; "Venus"; "Earth"; "Mars"; "Jupiter"; "Saturn"; "Uranus"; + "Neptune"] + # List.iter (Bag.push t) planets + - : unit = () + # Bag.pop_exn t + - : string = "Neptune" + # Bag.pop_opt t + - : string option = Some "Saturn" + # Bag.pop_exn t + - : string = "Mercury" + # Bag.pop_exn t + - : string = "Mars" + # Bag.pop_exn t + - : string = "Earth" + # Bag.pop_exn t + - : string = "Venus" + # Bag.pop_exn t + - : string = "Uranus" + # Bag.pop_exn t + - : string = "Jupiter" + # Bag.pop_exn t + Exception: Saturn__Bag.Empty. + ]} *) diff --git a/src/bounded_queue/bounded_queue.body.ml b/src/bounded_queue/bounded_queue.body.ml index 6e44356e..b6afacb8 100644 --- a/src/bounded_queue/bounded_queue.body.ml +++ b/src/bounded_queue/bounded_queue.body.ml @@ -146,9 +146,8 @@ let rec fix_tail tail new_tail = type _ mono = Bool : bool mono | Unit : unit mono -let rec push_as : - type r. 'a t -> ('a, [ `Node ]) node -> ('a, [ `Node ]) node -> r mono -> r - = +let rec push_as : type r. + 'a t -> ('a, [ `Node ]) node -> ('a, [ `Node ]) node -> r mono -> r = fun t new_node old_tail mono -> let capacity = get_capacity old_tail in if capacity = 0 then begin diff --git a/src/bounded_queue/bounded_queue.mli b/src/bounded_queue/bounded_queue.mli index 68324889..e54504f6 100644 --- a/src/bounded_queue/bounded_queue.mli +++ b/src/bounded_queue/bounded_queue.mli @@ -1,9 +1,8 @@ -(** Lock-free bounded Queue. +(** Lock-free bounded Queue. - This module implements a lock-free bounded queue based on Michael-Scott's queue - algorithm. Adding a capacity to this algorithm adds a general overhead to the - operations, and thus, it is recommended to use the unbounded queue - {!Saturn.Queue} if you don't need it. - *) + This module implements a lock-free bounded queue based on Michael-Scott's + queue algorithm. Adding a capacity to this algorithm adds a general overhead + to the operations, and thus, it is recommended to use the unbounded queue + {!Saturn.Queue} if you don't need it. *) include Bounded_queue_intf.BOUNDED_QUEUE diff --git a/src/bounded_queue/bounded_queue_intf.mli b/src/bounded_queue/bounded_queue_intf.mli index d46cb3cf..5a9e0a99 100644 --- a/src/bounded_queue/bounded_queue_intf.mli +++ b/src/bounded_queue/bounded_queue_intf.mli @@ -20,70 +20,72 @@ module type BOUNDED_QUEUE = sig (** Represents a lock-free bounded queue holding elements of type ['a]. *) val create : ?capacity:int -> unit -> 'a t - (** [create ~capacity ()] creates a new empty bounded queue with a maximum - capacity of [capacity]. The default [capacity] value is [Int.max_int].*) + (** [create ~capacity ()] creates a new empty bounded queue with a maximum + capacity of [capacity]. The default [capacity] value is [Int.max_int].*) val of_list_exn : ?capacity:int -> 'a list -> 'a t (** [of_list_exn ~capacity list] creates a new queue from a list. - - @raises Full if the length of [list] is greater than [capacity]. - - 🐌 This is a linear-time operation. - - {[ - # open Saturn.Bounded_queue - # let t : int t = of_list_exn [1;2;3;4] - val t : int t = - # pop_opt t - - : int option = Some 1 - # pop_opt t - - : int option = Some 2 - # length t - - : int = 2 - ]} - *) + + @raise Full if the length of [list] is greater than [capacity]. + + 🐌 This is a linear-time operation. + + {[ + # open Saturn.Bounded_queue + # let t : int t = of_list_exn [1;2;3;4] + val t : int t = + # pop_opt t + - : int option = Some 1 + # pop_opt t + - : int option = Some 2 + # length t + - : int = 2 + ]} *) val length : 'a t -> int (** [length queue] returns the number of elements currently in the [queue]. *) val capacity_of : 'a t -> int - (** [capacity_of queue] returns the maximum number of elements that the [queue] - can hold. *) + (** [capacity_of queue] returns the maximum number of elements that the + [queue] can hold. *) val is_empty : 'a t -> bool - (** [is_empty queue] returns [true] if the [queue] is empty, otherwise [false]. *) + (** [is_empty queue] returns [true] if the [queue] is empty, otherwise + [false]. *) val is_full : 'a t -> bool - (** [is_full queue] returns [true] if the [queue] is full, otherwise [false]. *) + (** [is_full queue] returns [true] if the [queue] is full, otherwise [false]. + *) (** {2 Consumer functions} *) exception Empty (** Raised when {!pop_exn}, {!peek_exn}, or {!drop_exn} is applied to an empty - stack. *) + stack. *) val peek_exn : 'a t -> 'a - (** [peek_exn queue] returns the first element of the [queue] without removing it. - - @raises Empty if the [queue] is empty. *) + (** [peek_exn queue] returns the first element of the [queue] without removing + it. + + @raise Empty if the [queue] is empty. *) val peek_opt : 'a t -> 'a option - (** [peek_opt queue] returns [Some] of the first element of the [queue] without - removing it, or [None] if the [queue] is empty. *) + (** [peek_opt queue] returns [Some] of the first element of the [queue] + without removing it, or [None] if the [queue] is empty. *) val pop_exn : 'a t -> 'a (** [pop_exn queue] removes and returns the first element of the [queue]. - - @raises Empty if the [queue] is empty. *) + + @raise Empty if the [queue] is empty. *) val pop_opt : 'a t -> 'a option - (** [pop_opt queue] removes and returns [Some] of the first element of the [queue], - or [None] if the [queue] is empty. *) + (** [pop_opt queue] removes and returns [Some] of the first element of the + [queue], or [None] if the [queue] is empty. *) val drop_exn : 'a t -> unit - (** [drop_exn queue] removes the top element of the [queue]. - - @raises Empty if the [queue] is empty. *) + (** [drop_exn queue] removes the top element of the [queue]. + + @raise Empty if the [queue] is empty. *) (** {2 Producer functions} *) @@ -92,8 +94,8 @@ module type BOUNDED_QUEUE = sig val push_exn : 'a t -> 'a -> unit (** [push_exn queue element] adds [element] at the end of the [queue]. - - @raises Full if the [queue] is full. *) + + @raise Full if the [queue] is full. *) val try_push : 'a t -> 'a -> bool (** [try_push queue element] tries to add [element] at the end of the [queue]. @@ -117,7 +119,7 @@ end - : unit = () # push_exn t 4 Exception: Saturn__Bounded_queue.Full. - # try_push t 4 + # try_push t 4 - : bool = false # pop_exn t - : int = 1 @@ -130,15 +132,16 @@ end # pop_opt t - : int option = None # pop_exn t - Exception: Saturn__Bounded_queue.Empty.]} -*) + Exception: Saturn__Bounded_queue.Empty. + ]} *) (** {2 Multicore example} - Note: The barrier is used in this example solely to make the results more - interesting by increasing the likelihood of parallelism. Spawning a domain is - a costly operation, especially compared to the relatively small amount of work - being performed here. In practice, using a barrier in this manner is unnecessary. + Note: The barrier is used in this example solely to make the results more + interesting by increasing the likelihood of parallelism. Spawning a domain + is a costly operation, especially compared to the relatively small amount of + work being performed here. In practice, using a barrier in this manner is + unnecessary. {@ocaml non-deterministic=command[ # open Saturn.Bounded_queue @@ -148,16 +151,16 @@ end # let barrier = Atomic.make 2 val barrier : int Atomic.t = - # let pusher () = + # let pusher () = Atomic.decr barrier; while Atomic.get barrier != 0 do Domain.cpu_relax () done; List.init 8 (fun i -> i) |> List.map (fun i -> Domain.cpu_relax (); try_push t i) val pusher : unit -> bool list = - # let popper () = + # let popper () = Atomic.decr barrier; - while Atomic.get barrier != 0 do Domain.cpu_relax () done; + while Atomic.get barrier != 0 do Domain.cpu_relax () done; List.init 8 (fun i -> Domain.cpu_relax (); pop_opt t) val popper : unit -> int option list = @@ -171,6 +174,4 @@ end - : bool list = [true; true; true; true; true; false; true; true] # Domain.join domain_popper - : int option list = [None; None; Some 0; None; Some 1; Some 2; Some 3; Some 4] - ]} - - *) + ]} *) diff --git a/src/bounded_queue/bounded_queue_unsafe.mli b/src/bounded_queue/bounded_queue_unsafe.mli index 27d44ac3..fab770c7 100644 --- a/src/bounded_queue/bounded_queue_unsafe.mli +++ b/src/bounded_queue/bounded_queue_unsafe.mli @@ -1,9 +1,8 @@ -(** Optimized lock-free bounded Queue. +(** Optimized lock-free bounded Queue. - This module implements a lock-free bounded queue based on Michael-Scott's queue - algorithm. Adding a capacity to this algorithm adds a general overhead to the - operations, and thus, it is recommended to use the unbounded queue - {!Saturn.Queue} if you don't need it. - *) + This module implements a lock-free bounded queue based on Michael-Scott's + queue algorithm. Adding a capacity to this algorithm adds a general overhead + to the operations, and thus, it is recommended to use the unbounded queue + {!Saturn.Queue} if you don't need it. *) include Bounded_queue_intf.BOUNDED_QUEUE diff --git a/src/bounded_stack.mli b/src/bounded_stack.mli index fd13ad30..1d655e02 100644 --- a/src/bounded_stack.mli +++ b/src/bounded_stack.mli @@ -1,11 +1,10 @@ -(** Lock-free bounded stack. +(** Lock-free bounded stack. - This module implements a lock-free bounded stack based on Treiber's stack - algorithm. Adding a capacity to this algorithm adds a general overhead to the - operations, and thus, it is recommended to use the unbounded stack - {!Saturn.Stack} if neither the capacity nor the {!length} function - is needed. -*) + This module implements a lock-free bounded stack based on Treiber's stack + algorithm. Adding a capacity to this algorithm adds a general overhead to + the operations, and thus, it is recommended to use the unbounded stack + {!Saturn.Stack} if neither the capacity nor the {!length} function is + needed. *) (** {1 API} *) @@ -13,49 +12,48 @@ type 'a t (** Represents a lock-free bounded stack holding elements of type ['a]. *) val create : ?capacity:int -> unit -> 'a t -(** [create ~capacity ()] creates a new empty bounded stack with a maximum -capacity of [capacity]. The default [capacity] value is [Int.max_int]. -*) +(** [create ~capacity ()] creates a new empty bounded stack with a maximum + capacity of [capacity]. The default [capacity] value is [Int.max_int]. *) val of_list_exn : ?capacity:int -> 'a list -> 'a t (** [of_list_exn list] creates a new Treiber stack from a list. - @raises Full if the [list] is longer than the capacity of the stack. + @raise Full if the [list] is longer than the capacity of the stack. - 🐌 This is a linear-time operation. - {[ + 🐌 This is a linear-time operation. + {[ # open Saturn.Bounded_stack # let t : int t = of_list_exn [1;2;3;4] val t : int t = # pop_opt t - : int option = Some 4 - # pop_opt t + # pop_opt t - : int option = Some 3 # length t - : int = 2 - ]} -*) + ]} *) val length : 'a t -> int (** [length stack] returns the number of elements currently in the [stack]. *) val is_empty : 'a t -> bool -(** [is_empty stack] returns [true] if the [stack] is empty, otherwise [false]. *) +(** [is_empty stack] returns [true] if the [stack] is empty, otherwise [false]. +*) val is_full : 'a t -> bool -(** [is_full stack] returns [true] if the [stack] has reached capacity, - otherwise [false]. *) +(** [is_full stack] returns [true] if the [stack] has reached capacity, + otherwise [false]. *) (** {2 Consumer functions} *) exception Empty (** Raised when {!pop_exn}, {!peek_exn}, or {!drop_exn} is applied to an empty - stack. *) + stack. *) val peek_exn : 'a t -> 'a (** [peek_exn stack] returns the top element of the [stack] without removing it. - - @raises Empty if the [stack] is empty. *) + + @raise Empty if the [stack] is empty. *) val peek_opt : 'a t -> 'a option (** [peek_opt stack] returns [Some] of the top element of the [stack] without @@ -63,36 +61,35 @@ val peek_opt : 'a t -> 'a option val pop_exn : 'a t -> 'a (** [pop_exn stack] removes and returns the top element of the [stack]. - - @raises Empty if the [stack] is empty. *) + + @raise Empty if the [stack] is empty. *) val pop_opt : 'a t -> 'a option -(** [pop_opt stack] removes and returns [Some] of the top element of the [stack], - or [None] if the [stack] is empty. *) +(** [pop_opt stack] removes and returns [Some] of the top element of the + [stack], or [None] if the [stack] is empty. *) val drop_exn : 'a t -> unit -(** [drop_exn stack] removes the top element of the [stack]. +(** [drop_exn stack] removes the top element of the [stack]. - @raises Empty if the [stack] is empty. *) + @raise Empty if the [stack] is empty. *) val pop_all : 'a t -> 'a list -(** [pop_all stack] removes and returns all elements of the [stack] in LIFO -order. - - {[ - # open Saturn.Bounded_stack - # let t : int t = create () - val t : int t = - # try_push t 1 - - : bool = true - # try_push t 2 - - : bool = true - # try_push t 3 - - : bool = true - # pop_all t - - : int list = [3; 2; 1] - ]} -*) +(** [pop_all stack] removes and returns all elements of the [stack] in LIFO + order. + + {[ + # open Saturn.Bounded_stack + # let t : int t = create () + val t : int t = + # try_push t 1 + - : bool = true + # try_push t 2 + - : bool = true + # try_push t 3 + - : bool = true + # pop_all t + - : int list = [3; 2; 1] + ]} *) (** {2 Producer functions} *) @@ -101,72 +98,69 @@ exception Full val push_exn : 'a t -> 'a -> unit (** [push_exn stack element] adds [element] to the top of the [stack]. - - @raises Full if the [stack] is full. *) + + @raise Full if the [stack] is full. *) val try_push : 'a t -> 'a -> bool (** [try_push stack element] tries to add [element] to the top of the [stack]. Returns [true] if the element was successfully added, or [false] if the - stack is full. -*) + stack is full. *) val push_all_exn : 'a t -> 'a list -> unit (** [push_all_exn stack elements] adds all [elements] to the top of the [stack]. - - @raises Full if the [stack] is full. - - 🐌 This is a linear-time operation on the size of [elements]. *) + + @raise Full if the [stack] is full. + + 🐌 This is a linear-time operation on the size of [elements]. *) val try_push_all : 'a t -> 'a list -> bool -(** [try_push_all stack elements] tries to add all [elements] to the top of the - [stack]. Returns [true] if the elements were successfully added, or [false] if - the stack is full. - -🐌 This is a linear-time operation on the size of [elements]. - - {[ - # let t : int t = create () - val t : int t = - # try_push_all t [1; 2; 3; 4] - - : bool = true - # pop_opt t - - : int option = Some 4 - # pop_opt t - - : int option = Some 3 - # pop_all t - - : int list = [2; 1] - ]} - *) - -(** {2 With Sequences }*) +(** [try_push_all stack elements] tries to add all [elements] to the top of the + [stack]. Returns [true] if the elements were successfully added, or [false] + if the stack is full. + + 🐌 This is a linear-time operation on the size of [elements]. + + {[ + # let t : int t = create () + val t : int t = + # try_push_all t [1; 2; 3; 4] + - : bool = true + # pop_opt t + - : int option = Some 4 + # pop_opt t + - : int option = Some 3 + # pop_all t + - : int list = [2; 1] + ]} *) + +(** {2 With Sequences}*) val to_seq : 'a t -> 'a Seq.t -(** [to_seq stack] takes a snapshot of [stack] and returns its value from top to -bottom. +(** [to_seq stack] takes a snapshot of [stack] and returns its value from top to + bottom. - 🐌 This is a linear time operation. *) + 🐌 This is a linear time operation. *) val of_seq : ?capacity:int -> 'a Seq.t -> 'a t -(** [of_seq seq] creates a stack from a [seq]. It must be finite. +(** [of_seq seq] creates a stack from a [seq]. It must be finite. - @raises Full if the [seq] is longer than the capacity of the stack. - - 🐌 This is a linear-time operation. -*) + @raise Full if the [seq] is longer than the capacity of the stack. + + 🐌 This is a linear-time operation. *) val add_seq_exn : 'a t -> 'a Seq.t -> unit -(** [add_seq_exn stack seq] adds all elements of [seq] to the top of the -[stack]. [seq] must be finite. +(** [add_seq_exn stack seq] adds all elements of [seq] to the top of the + [stack]. [seq] must be finite. -@raises Full if the [seq] is too long to fit in the stack. - -🐌 This is a linear-time operation on the size of [seq]. *) + @raise Full if the [seq] is too long to fit in the stack. + + 🐌 This is a linear-time operation on the size of [seq]. *) val try_add_seq : 'a t -> 'a Seq.t -> bool (** [try_add_seq stack seq] tries to add all elements of [seq] to the top of the -[stack]. Returns [true] if the elements were successfully added, or [false] if -the [seq] is too long to fit in the stack. + [stack]. Returns [true] if the elements were successfully added, or [false] + if the [seq] is too long to fit in the stack. -🐌 This is a linear-time operation. *) + 🐌 This is a linear-time operation. *) (** {1 Examples} *) @@ -189,15 +183,15 @@ the [seq] is too long to fit in the stack. # pop_opt t - : int option = None # pop_exn t - Exception: Saturn__Bounded_stack.Empty.]} -*) + Exception: Saturn__Bounded_stack.Empty. + ]} *) (** {2 Multicore example} - Note: The barrier is used in this example solely to make the results more - interesting by increasing the likelihood of parallelism. Spawning a domain is - a costly operation, especially compared to the relatively small amount of work - being performed here. In practice, using a barrier in this manner is unnecessary. - + Note: The barrier is used in this example solely to make the results more + interesting by increasing the likelihood of parallelism. Spawning a domain + is a costly operation, especially compared to the relatively small amount of + work being performed here. In practice, using a barrier in this manner is + unnecessary. {@ocaml non-deterministic=command[ # open Saturn.Bounded_stack @@ -206,7 +200,7 @@ the [seq] is too long to fit in the stack. # let barrier = Atomic.make 2 val barrier : int Atomic.t = - # let pusher () = + # let pusher () = Atomic.decr barrier; while Atomic.get barrier != 0 do Domain.cpu_relax () done; try_push_all t [1;2;3] |> ignore; @@ -214,12 +208,12 @@ the [seq] is too long to fit in the stack. push_exn t 12 val pusher : unit -> unit = - # let popper () = + # let popper () = Atomic.decr barrier; while Atomic.get barrier != 0 do Domain.cpu_relax () done; List.init 6 (fun i -> Domain.cpu_relax (); pop_opt t) val popper : unit -> int option list = - + # let domain_pusher = Domain.spawn pusher val domain_pusher : unit Domain.t = # let domain_popper = Domain.spawn popper @@ -228,5 +222,4 @@ the [seq] is too long to fit in the stack. - : unit = () # Domain.join domain_popper - : int option list = [Some 42; Some 3; Some 2; Some 1; None; Some 12] - ]} - *) + ]} *) diff --git a/src/htbl/htbl.body.ml b/src/htbl/htbl.body.ml index 188265c0..3b401976 100644 --- a/src/htbl/htbl.body.ml +++ b/src/htbl/htbl.body.ml @@ -50,7 +50,7 @@ type ('k, 'v) state = { max_buckets : int; } (** This record is [7 + 1] words and should be aligned on such a boundary on the - second generation heap. It is probably not worth it to pad it further. *) + second generation heap. It is probably not worth it to pad it further. *) type ('k, 'v) t = ('k, 'v) state Atomic.t @@ -409,11 +409,10 @@ type ('k, 'v, _) poly = | Value : ('k, 'v, 'v) poly | Option : ('k, 'v, 'v option) poly -let rec find_as : - type k v r. (k, v) state -> k -> (k, v) bucket -> (k, v, r) poly -> r = +let rec find_as : type k v r. + (k, v) state -> k -> (k, v) bucket -> (k, v, r) poly -> r = fun r key bucket poly -> - let rec assoc : - type k v r. + let rec assoc : type k v r. (k -> k -> bool) -> k -> (k, v, [ `Nil | `Cons ]) tdt -> @@ -529,8 +528,8 @@ let rec assoc eq key = function | Nil -> raise_notrace Not_found | Cons r -> if eq r.key key then r.value else assoc eq key r.rest -let rec try_reassoc : - type v c r. (_, v) t -> _ -> c -> v -> (v, c, r) op -> _ -> r = +let rec try_reassoc : type v c r. + (_, v) t -> _ -> c -> v -> (v, c, r) op -> _ -> r = fun t key present future op backoff -> let r = Atomic.get t in let h = r.hash key in @@ -577,20 +576,20 @@ let rec try_reassoc : else try_reassoc t key present future op (Backoff.once backoff) else not_found op else - let[@tail_mod_cons] rec reassoc : - type v c r. + let[@tail_mod_cons] rec reassoc : type v c r. _ -> _ -> c -> v -> (v, c, r) op -> (_, v, 't) tdt -> (_, v, 't) tdt = fun t key present future op -> function - | Nil -> raise_notrace Not_found - | Cons r -> - if t key r.key then - match op with - | Exists | Return -> Cons { r with value = future } - | Compare -> - if r.value == present then Cons { r with value = future } - else raise_notrace Not_found - else Cons { r with rest = reassoc t key present future op r.rest } + | Nil -> raise_notrace Not_found + | Cons r -> + if t key r.key then + match op with + | Exists | Return -> Cons { r with value = future } + | Compare -> + if r.value == present then Cons { r with value = future } + else raise_notrace Not_found + else + Cons { r with rest = reassoc t key present future op r.rest } in match reassoc r.equal key present future op cons_r.rest with | rest -> @@ -682,19 +681,18 @@ let rec try_dissoc : type v c r. (_, v) t -> _ -> c -> (v, c, r) op -> _ -> r = else try_dissoc t key present op (Backoff.once backoff) else not_found op else - let[@tail_mod_cons] rec dissoc : - type v c r. + let[@tail_mod_cons] rec dissoc : type v c r. _ -> _ -> c -> (v, c, r) op -> (_, v, 't) tdt -> (_, v, 't) tdt = fun t key present op -> function - | Nil -> raise_notrace Not_found - | Cons r -> - if t key r.key then - match op with - | Exists | Return -> r.rest - | Compare -> - if r.value == present then r.rest - else raise_notrace Not_found - else Cons { r with rest = dissoc t key present op r.rest } + | Nil -> raise_notrace Not_found + | Cons r -> + if t key r.key then + match op with + | Exists | Return -> r.rest + | Compare -> + if r.value == present then r.rest + else raise_notrace Not_found + else Cons { r with rest = dissoc t key present op r.rest } in match dissoc r.equal key present op cons_r.rest with | (Nil | Cons _) as rest -> diff --git a/src/htbl/htbl.mli b/src/htbl/htbl.mli index 8a21bfd5..1cadb20f 100644 --- a/src/htbl/htbl.mli +++ b/src/htbl/htbl.mli @@ -1,13 +1,13 @@ (** Lock-free and resizable hash table. The operations provided by this hash table are designed to work as building - blocks of non-blocking algorithms. Specifically, the operation signatures + blocks of non-blocking algorithms. Specifically, the operation signatures and semantics are designed to allow building {{:https://dl.acm.org/doi/10.1145/62546.62593} consensus protocols over - arbitrary numbers of processes}. + arbitrary numbers of processes}. 🏎️ Single key reads with this hash table are actually wait-free rather than - just lock-free. Internal resizing automatically uses all the threads that + just lock-free. Internal resizing automatically uses all the threads that are trying to write to the hash table. *) include Htbl_intf.HTBL diff --git a/src/htbl/htbl_intf.mli b/src/htbl/htbl_intf.mli index 71093257..3721dc71 100644 --- a/src/htbl/htbl_intf.mli +++ b/src/htbl/htbl_intf.mli @@ -3,7 +3,7 @@ module type HTBL = sig type (!'k, !'v) t (** Represents a lock-free hash table mapping keys of type ['k] to values of - type ['v]. *) + type ['v]. *) type 'k hashed_type = (module Stdlib.Hashtbl.HashedType with type t = 'k) (** First-class module type abbreviation. *) @@ -15,161 +15,162 @@ module type HTBL = sig unit -> ('k, 'v) t (** [create ~hashed_type:(module Key) ()] creates a new empty lock-free hash - table. - - - The optional [hashed_type] argument can and usually should be used to - specify the [equal] and [hash] operations on keys. Slow polymorphic - equality [(=)] and slow polymorphic {{!Stdlib.Hashtbl.seeded_hash} [seeded_hash (Bits64.to_int (Random.bits64 ()))]} - are used by default. - - The default [min_buckets] is unspecified, and a given [min_buckets] may be - adjusted by the implementation. - - The default [max_buckets] is unspecified, and a given [max_buckets] may be - adjusted by the implementation. *) + table. + + - The optional [hashed_type] argument can and usually should be used to + specify the [equal] and [hash] operations on keys. Slow polymorphic + equality [(=)] and slow polymorphic + {{!Stdlib.Hashtbl.seeded_hash} + [seeded_hash (Bits64.to_int (Random.bits64 ()))]} are used by default. + - The default [min_buckets] is unspecified, and a given [min_buckets] may + be adjusted by the implementation. + - The default [max_buckets] is unspecified, and a given [max_buckets] may + be adjusted by the implementation. *) val hashed_type_of : ('k, 'v) t -> 'k hashed_type (** [hashed_type_of htbl] returns a copy of the hashed type used when the hash - table [htbl] was created. *) + table [htbl] was created. *) val min_buckets_of : ('k, 'v) t -> int (** [min_buckets_of htbl] returns the minimum number of buckets in the hash - table [htbl]. + table [htbl]. - ℹ️ The returned value may not be the same as the one given to {!create}. *) + ℹ️ The returned value may not be the same as the one given to {!create}. *) val max_buckets_of : ('k, 'v) t -> int (** [max_buckets_of htbl] returns the maximum number of buckets in the hash - table [htbl]. + table [htbl]. - ℹ️ The returned value may not be the same as the one given to {!create}. *) + ℹ️ The returned value may not be the same as the one given to {!create}. *) val length : ('k, 'v) t -> int (** [length htbl] returns the number of bindings in the hash table [htbl]. *) (** {2 Looking up bindings} *) val find_opt : ('k, 'v) t -> 'k -> 'v option - (** [find_opt htbl key] returns [Some] of the current binding of [key] in the + (** [find_opt htbl key] returns [Some] of the current binding of [key] in the hash table [htbl] or [None] if it does not exist. *) val find_exn : ('k, 'v) t -> 'k -> 'v (** [find_exn htbl key] returns the current binding of [key] in the hash table - [htbl] or raises {!Not_found} if no such binding exists. + [htbl] or raises {!Not_found} if no such binding exists. - @raise Not_found if no binding of [key] exists in the hash table - [htbl]. *) + @raise Not_found if no binding of [key] exists in the hash table [htbl]. + *) val mem : ('k, 'v) t -> 'k -> bool (** [mem htbl key] determines whether the hash table [htbl] has a binding for - the [key]. *) + the [key]. *) (** {2 Adding bindings} *) val try_add : ('k, 'v) t -> 'k -> 'v -> bool (** [try_add htbl key value] tries to add a new binding of [key] to [value] to - the hash table [htbl]. Returns [true] on success and [false] if the - hash table already contains a binding for [key]. *) + the hash table [htbl]. Returns [true] on success and [false] if the hash + table already contains a binding for [key]. *) (** {2 Updating bindings} *) val try_set : ('k, 'v) t -> 'k -> 'v -> bool (** [try_set htbl key value] tries to update an existing binding of [key] to - [value] in the hash table [htbl]. Returns [true] on success and [false] if - the hash table does not contain a binding for [key]. *) + [value] in the hash table [htbl]. Returns [true] on success and [false] if + the hash table does not contain a binding for [key]. *) val try_compare_and_set : ('k, 'v) t -> 'k -> 'v -> 'v -> bool (** [try_compare_and_set htbl key before after] tries to update an existing - binding of [key] from the [before] value to the [after] value in the hash - table [htbl]. Returns [true] on success and [false] if the hash table - does not contain a binding of [key] to the [before] value. + binding of [key] from the [before] value to the [after] value in the hash + table [htbl]. Returns [true] on success and [false] if the hash table does + not contain a binding of [key] to the [before] value. - ℹ️ The values are compared using physical equality, i.e. the [==] - operator. *) + ℹ️ The values are compared using physical equality, i.e. the [==] operator. + *) val set_exn : ('k, 'v) t -> 'k -> 'v -> 'v (** [set_exn htbl key after] tries to update an existing binding of [key] from - some [before] value to the [after] value in the hash table [htbl]. Returns - the [before] value on success or raises {!Not_found} if no such binding - exists. + some [before] value to the [after] value in the hash table [htbl]. Returns + the [before] value on success or raises {!Not_found} if no such binding + exists. - @raise Not_found if no binding of [key] exists in the hash table - [htbl]. *) + @raise Not_found if no binding of [key] exists in the hash table [htbl]. + *) (** {2 Removing bindings} *) val try_remove : ('k, 'v) t -> 'k -> bool - (** [try_remove htbl key] tries to remove a binding of [key] from the hash table - [htbl]. Returns [true] on success and [false] if the hash table does not - contain a binding for [key]. *) + (** [try_remove htbl key] tries to remove a binding of [key] from the hash + table [htbl]. Returns [true] on success and [false] if the hash table does + not contain a binding for [key]. *) val try_compare_and_remove : ('k, 'v) t -> 'k -> 'v -> bool - (** [try_compare_and_remove htbl key before] tries to remove a binding of [key] - to the [before] value from the hash table [htbl]. Returns [true] on success - and [false] if the hash table does not contain a binding of [key] to the - [before] value. + (** [try_compare_and_remove htbl key before] tries to remove a binding of + [key] to the [before] value from the hash table [htbl]. Returns [true] on + success and [false] if the hash table does not contain a binding of [key] + to the [before] value. - ℹ️ The values are compared using physical equality, i.e. the [==] - operator. *) + ℹ️ The values are compared using physical equality, i.e. the [==] operator. + *) val remove_exn : ('k, 'v) t -> 'k -> 'v (** [remove_exn htbl key] tries to remove a binding of [key] to some [before] - value from the hash table [htbl]. Returns the [before] value on success or - raises {!Not_found} if no such binding exists. + value from the hash table [htbl]. Returns the [before] value on success or + raises {!Not_found} if no such binding exists. - @raise Not_found if no binding of [key] exists in the hash table - [htbl]. *) + @raise Not_found if no binding of [key] exists in the hash table [htbl]. + *) (** {2 Examining contents} *) val to_seq : ('k, 'v) t -> ('k * 'v) Seq.t - (** [to_seq htbl] takes a snapshot of the bindings in the hash table [htbl] and - returns them as an association sequence. + (** [to_seq htbl] takes a snapshot of the bindings in the hash table [htbl] + and returns them as an association sequence. - 🐌 This is a linear-time operation. *) + 🐌 This is a linear-time operation. *) val remove_all : ('k, 'v) t -> ('k * 'v) Seq.t - (** [remove_all htbl] takes a snapshot of the bindings in the hash table [htbl], - removes the bindings from the hash table, and returns the snapshot as an - association sequence. + (** [remove_all htbl] takes a snapshot of the bindings in the hash table + [htbl], removes the bindings from the hash table, and returns the snapshot + as an association sequence. - 🐌 This is a linear-time operation. *) + 🐌 This is a linear-time operation. *) val find_random_exn : ('k, 'v) t -> 'k (** [find_random_exn htbl] tries to find a random binding from the hash table - [htbl] and returns the key of the binding or raises {!Not_found} if the - hash table is empty. + [htbl] and returns the key of the binding or raises {!Not_found} if the + hash table is empty. - 🐌 This is an expected constant-time operation with worst-case linear-time - complexity. + 🐌 This is an expected constant-time operation with worst-case linear-time + complexity. - @raise Not_found if the hash table [htbl] is empty. *) + @raise Not_found if the hash table [htbl] is empty. *) (** {1 Examples} - An example top-level session: - {[ - # module Htbl = Saturn.Htbl - module Htbl = Saturn.Htbl + An example top-level session: + {[ + # module Htbl = Saturn.Htbl + module Htbl = Saturn.Htbl + + # let t : (int, string) Htbl.t = + Htbl.create + ~hashed_type:(module Int) () + val t : (int, string) Htbl.t = - # let t : (int, string) Htbl.t = - Htbl.create - ~hashed_type:(module Int) () - val t : (int, string) Htbl.t = + # Htbl.try_add t 42 "The answer" + - : bool = true - # Htbl.try_add t 42 "The answer" - - : bool = true + # Htbl.try_add t 101 "Basics" + - : bool = true - # Htbl.try_add t 101 "Basics" - - : bool = true + # Htbl.find_exn t 42 + - : string = "The answer" - # Htbl.find_exn t 42 - - : string = "The answer" + # Htbl.try_add t 101 "The basics" + - : bool = false - # Htbl.try_add t 101 "The basics" - - : bool = false + # Htbl.remove_all t |> List.of_seq + - : (int * string) list = [(101, "Basics"); (42, "The answer")] + ]} - # Htbl.remove_all t |> List.of_seq - - : (int * string) list = [(101, "Basics"); (42, "The answer")] - ]} - - The lockfree bag (see {!Saturn.Bag}) is implemented using this hash table. -*) + The lockfree bag (see {!Saturn.Bag}) is implemented using this hash table. + *) end diff --git a/src/htbl/htbl_unsafe.mli b/src/htbl/htbl_unsafe.mli index e785b652..a9348923 100644 --- a/src/htbl/htbl_unsafe.mli +++ b/src/htbl/htbl_unsafe.mli @@ -1,13 +1,13 @@ (** Optimized lock-free and resizable hash table. The operations provided by this hash table are designed to work as building - blocks of non-blocking algorithms. Specifically, the operation signatures + blocks of non-blocking algorithms. Specifically, the operation signatures and semantics are designed to allow building {{:https://dl.acm.org/doi/10.1145/62546.62593} consensus protocols over - arbitrary numbers of processes}. + arbitrary numbers of processes}. 🏎️ Single key reads with this hash table are actually wait-free rather than - just lock-free. Internal resizing automatically uses all the threads that + just lock-free. Internal resizing automatically uses all the threads that are trying to write to the hash table. *) include Htbl_intf.HTBL diff --git a/src/michael_scott_queue/michael_scott_queue.ml b/src/michael_scott_queue/michael_scott_queue.ml index a89c6300..2862ab3a 100644 --- a/src/michael_scott_queue/michael_scott_queue.ml +++ b/src/michael_scott_queue/michael_scott_queue.ml @@ -52,8 +52,8 @@ type ('a, _) poly = | Value : ('a, 'a) poly | Unit : ('a, unit) poly -let rec pop_as : - type a r. a node Atomic.t Atomic.t -> Backoff.t -> (a, r) poly -> r = +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 diff --git a/src/michael_scott_queue/michael_scott_queue.mli b/src/michael_scott_queue/michael_scott_queue.mli index 8b718185..6478f2d5 100644 --- a/src/michael_scott_queue/michael_scott_queue.mli +++ b/src/michael_scott_queue/michael_scott_queue.mli @@ -1,15 +1,12 @@ -(** - Michael-Scott classic lock-free multi-producer multi-consumer queue. +(** Michael-Scott classic lock-free 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}. + 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}. - If you need a [length] function, you can use the bounded queue - {!Saturn.Bounded_queue} instead with maximun capacity (default value). - However, this adds a general overhead to the operation. -*) + If you need a [length] function, you can use the bounded queue + {!Saturn.Bounded_queue} instead with maximun capacity (default value). + However, this adds a general overhead to the operation. *) include Michael_scott_queue_intf.MS_QUEUE diff --git a/src/michael_scott_queue/michael_scott_queue_intf.mli b/src/michael_scott_queue/michael_scott_queue_intf.mli index eccb56a4..b0aa9c6c 100644 --- a/src/michael_scott_queue/michael_scott_queue_intf.mli +++ b/src/michael_scott_queue/michael_scott_queue_intf.mli @@ -26,19 +26,18 @@ module type MS_QUEUE = sig val of_list : 'a list -> 'a t (** [of_list list] creates a new queue from a list. - - 🐌 This is a linear-time operation. - - {[ - # open Saturn.Queue - # let t : int t = of_list [1;2;3;4] - val t : int t = - # pop_opt t - - : int option = Some 1 - # pop_opt t - - : int option = Some 2 - ]} - *) + + 🐌 This is a linear-time operation. + + {[ + # open Saturn.Queue + # let t : int t = of_list [1;2;3;4] + val t : int t = + # pop_opt t + - : int option = Some 1 + # pop_opt t + - : int option = Some 2 + ]} *) val is_empty : 'a t -> bool (** [is_empty q] returns [true] if [q] is empty and [false] otherwise. *) @@ -47,103 +46,103 @@ module type MS_QUEUE = sig exception Empty (** Raised when {!pop_exn}, {!peek_exn}, or {!drop_exn} is applied to an empty - queue. *) + queue. *) val peek_exn : 'a t -> 'a - (** [peek_exn queue] returns the first element of the [queue] without removing it. - - @raises Empty if the [queue] is empty. *) + (** [peek_exn queue] returns the first element of the [queue] without removing + it. + + @raise Empty if the [queue] is empty. *) val peek_opt : 'a t -> 'a option - (** [peek_opt queue] returns [Some] of the first element of the [queue] without - removing it, or [None] if the [queue] is empty. *) + (** [peek_opt queue] returns [Some] of the first element of the [queue] + without removing it, or [None] if the [queue] is empty. *) val pop_exn : 'a t -> 'a (** [pop_exn queue] removes and returns the first element of the [queue]. - - @raises Empty if the [queue] is empty. *) + + @raise Empty 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. *) + (** [pop_opt q] removes and returns the first element in queue [q], or returns + [None] if the queue is empty. *) val drop_exn : 'a t -> unit - (** [drop_exn queue] removes the top element of the [queue]. - - @raises Empty if the [queue] is empty. *) + (** [drop_exn queue] removes the top element of the [queue]. + + @raise Empty if the [queue] is empty. *) (** {2 Producer functions} *) val push : 'a t -> 'a -> unit (** [push q v] adds the element [v] at the end of the queue [q]. *) - (** {1 Examples} *) + (** {1 Examples} *) (** {2 Sequential example} - - An example top-level session: - {[ - # open Saturn.Queue - # let t : int t = of_list [1;2;3] - val t : int t = - # push t 42 - - : unit = () - # pop_exn t - - : int = 1 - # peek_opt t - - : int option = Some 2 - # drop_exn t - - : unit = () - # pop_opt t - - : int option = Some 3 - # pop_opt t - - : int option = Some 42 - # pop_exn t - Exception: Saturn__Michael_scott_queue.Empty.]} - *) - - (** {2 Parallel example} - Note: The barrier is used in this example solely to make the results more - interesting by increasing the likelihood of parallelism. Spawning a domain is - a costly operation, especially compared to the relatively small amount of work - being performed here. In practice, using a barrier in this manner is unnecessary. - - - {@ocaml non-deterministic=command[ - # open Saturn.Queue - # let t : string t = create () - val t : string t = - # Random.self_init () - - : unit = () - # let barrier = Atomic.make 2 - val barrier : int Atomic.t = - - # let work id = - Atomic.decr barrier; - while Atomic.get barrier <> 0 do - Domain.cpu_relax () - done; - for _ = 1 to 4 do - Domain.cpu_relax (); - if Random.bool () then push t id - else - match pop_opt t with - | None -> Format.printf "Domain %s sees an empty queue.\n%!" id - | Some v -> Format.printf "Domain %s pops values pushed by %s.\n%!" id v - done - val work : string -> unit = - - # let domainA = Domain.spawn (fun () -> work "A") - val domainA : unit Domain.t = - # let domainB = Domain.spawn (fun () -> work "B") - Domain B pops values pushed by B. - Domain A pops values pushed by A. - Domain B pops values pushed by A. - Domain B pops values pushed by A. - val domainB : unit Domain.t = - - # Domain.join domainA; Domain.join domainB - - : unit = () - ]} - *) + + An example top-level session: + {[ + # open Saturn.Queue + # let t : int t = of_list [1;2;3] + val t : int t = + # push t 42 + - : unit = () + # pop_exn t + - : int = 1 + # peek_opt t + - : int option = Some 2 + # drop_exn t + - : unit = () + # pop_opt t + - : int option = Some 3 + # pop_opt t + - : int option = Some 42 + # pop_exn t + Exception: Saturn__Michael_scott_queue.Empty. + ]} *) + + (** {2 Parallel example} + Note: The barrier is used in this example solely to make the results more + interesting by increasing the likelihood of parallelism. Spawning a domain + is a costly operation, especially compared to the relatively small amount + of work being performed here. In practice, using a barrier in this manner + is unnecessary. + + {@ocaml non-deterministic=command[ + # open Saturn.Queue + # let t : string t = create () + val t : string t = + # Random.self_init () + - : unit = () + # let barrier = Atomic.make 2 + val barrier : int Atomic.t = + + # let work id = + Atomic.decr barrier; + while Atomic.get barrier <> 0 do + Domain.cpu_relax () + done; + for _ = 1 to 4 do + Domain.cpu_relax (); + if Random.bool () then push t id + else + match pop_opt t with + | None -> Format.printf "Domain %s sees an empty queue.\n%!" id + | Some v -> Format.printf "Domain %s pops values pushed by %s.\n%!" id v + done + val work : string -> unit = + + # let domainA = Domain.spawn (fun () -> work "A") + val domainA : unit Domain.t = + # let domainB = Domain.spawn (fun () -> work "B") + Domain B pops values pushed by B. + Domain A pops values pushed by A. + Domain B pops values pushed by A. + Domain B pops values pushed by A. + val domainB : unit Domain.t = + + # Domain.join domainA; Domain.join domainB + - : unit = () + ]} *) end diff --git a/src/michael_scott_queue/michael_scott_queue_unsafe.ml b/src/michael_scott_queue/michael_scott_queue_unsafe.ml index 7ca00215..bef4dc79 100644 --- a/src/michael_scott_queue/michael_scott_queue_unsafe.ml +++ b/src/michael_scott_queue/michael_scott_queue_unsafe.ml @@ -51,8 +51,8 @@ type ('a, _) poly = | Value : ('a, 'a) poly | Unit : ('a, unit) poly -let rec pop_as : - type a r. (a, [ `Next ]) Node.t Atomic.t -> Backoff.t -> (a, r) poly -> r = +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 diff --git a/src/michael_scott_queue/michael_scott_queue_unsafe.mli b/src/michael_scott_queue/michael_scott_queue_unsafe.mli index 19fdeddb..b165dd35 100644 --- a/src/michael_scott_queue/michael_scott_queue_unsafe.mli +++ b/src/michael_scott_queue/michael_scott_queue_unsafe.mli @@ -1,16 +1,12 @@ -(** - Optimized Michael-Scott lock-free multi-producer multi-consumer - queue. +(** Optimized Michael-Scott lock-free 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}. + 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}. - If you need a [length] function, you can use the bounded queue - {!Saturn.Bounded_queue} instead with maximun capacity (default value). - However, this adds a general overhead to the operation. -*) + If you need a [length] function, you can use the bounded queue + {!Saturn.Bounded_queue} instead with maximun capacity (default value). + However, this adds a general overhead to the operation. *) include Michael_scott_queue_intf.MS_QUEUE diff --git a/src/mpsc_queue.ml b/src/mpsc_queue.ml index 75818764..576906ec 100644 --- a/src/mpsc_queue.ml +++ b/src/mpsc_queue.ml @@ -101,7 +101,7 @@ let rec pop_as : type a r. a t -> (a, r) poly -> r = t.head <- rev_append tail Open; pop_as t poly) -(* *) +(* *) type ('a, _) poly2 = Option : ('a, 'a option) poly2 | Value : ('a, 'a) poly2 diff --git a/src/mpsc_queue.mli b/src/mpsc_queue.mli index 4b453bda..2bc48521 100644 --- a/src/mpsc_queue.mli +++ b/src/mpsc_queue.mli @@ -2,12 +2,11 @@ for cancellation. This data structure is well-suited for use as a scheduler's run queue. - - {b Warning}: This queue does not include safety mechanisms to prevent misuse. - If consumer-only functions are called concurrently by multiple domains, the - queue may enter an unexpected state, due to data races and a lack of - linearizability. -*) + + {b Warning}: This queue does not include safety mechanisms to prevent + misuse. If consumer-only functions are called concurrently by multiple + domains, the queue may enter an unexpected state, due to data races and a + lack of linearizability. *) (** {1 API} *) @@ -20,61 +19,59 @@ val create : unit -> 'a t (** [create ()] returns a new empty single-consumer queue. *) val of_list : 'a list -> 'a t -(** [of_list l] creates a new single-consumer queue from list [l]. +(** [of_list l] creates a new single-consumer queue from list [l]. 🐌 This is a linear-time operation. {[ - # open Saturn.Single_consumer_queue - # let t : int t = of_list [1; 2; 3] - val t : int t = - # pop_opt t - - : int option = Some 1 - # peek_opt t - - : int option = Some 2 - # pop_opt t - - : int option = Some 2 - # pop_opt t - - : int option = Some 3 - ]} -*) + # open Saturn.Single_consumer_queue + # let t : int t = of_list [1; 2; 3] + val t : int t = + # pop_opt t + - : int option = Some 1 + # peek_opt t + - : int option = Some 2 + # pop_opt t + - : int option = Some 2 + # pop_opt t + - : int option = Some 3 + ]} *) (** {2 Producer-only functions} *) 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 +(** [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. *) val push_all : 'a t -> 'a list -> unit (** [push_all q vs] adds all the elements [vs] at the end of the queue [q]. This - can be used safely by multiple producer domains, in parallel with the other + can be used safely by multiple producer domains, in parallel with the other operations. - - @raise Closed if [q] is closed. - + + @raise Closed if [q] is closed. + 🐌 This is a linear-time operation on the size of [vs]. {[ - # open Saturn.Single_consumer_queue - # let t : int t = create () - val t : int t = - # push_all t [1; 2; 3] - - : unit = () - # pop_opt t - - : int option = Some 1 - # peek_opt t - - : int option = Some 2 - # pop_opt t - - : int option = Some 2 - # pop_opt t - - : int option = Some 3 - # pop_exn t - Exception: Saturn__Mpsc_queue.Empty. - ]} - *) + # open Saturn.Single_consumer_queue + # let t : int t = create () + val t : int t = + # push_all t [1; 2; 3] + - : unit = () + # pop_opt t + - : int option = Some 1 + # peek_opt t + - : int option = Some 2 + # pop_opt t + - : int option = Some 2 + # pop_opt t + - : int option = Some 3 + # pop_exn t + Exception: Saturn__Mpsc_queue.Empty. + ]} *) (** {2 Consumer-only functions} *) @@ -82,20 +79,20 @@ exception Empty (** Raised when {!pop_exn} or {!peek_exn} is applied to an empty queue. *) val is_empty : 'a t -> bool -(** [is_empty q] is [true] if calling [pop_exn] would return [None]. This can +(** [is_empty q] is [true] if calling [pop_exn] would return [None]. This can only be used by the consumer. @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}). This can only be used by the +(** [close q] marks [q] as closed, preventing any further items from being + pushed by the producers (i.e. with {!push}). This can only be used by the consumer. @raise Closed if [q] has already been closed. *) val pop_exn : 'a t -> 'a -(** [pop_exn q] removes and returns the first element in queue [q]. This can +(** [pop_exn q] removes and returns the first element in queue [q]. This can only be used by the consumer. @raise Empty if [q] is empty. @@ -103,22 +100,22 @@ val pop_exn : 'a t -> 'a @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 +(** [pop_opt q] removes and returns the first element in queue [q] or returns [None] if the queue is empty. This can only be used by the consumer. @raise Closed if [q] is closed and empty. *) val drop_exn : 'a t -> unit -(** [drop_exn q] removes the first element in queue [q]. This can only be used +(** [drop_exn q] removes the first element in queue [q]. This can only be used by the consumer. - + @raise Empty if [q] is empty. - + @raise Closed if [q] is closed and empty. *) val peek_exn : 'a t -> 'a -(** [peek_exn q] returns the first element in queue [q]. This can only - be used by the consumer +(** [peek_exn q] returns the first element in queue [q]. This can only be used + by the consumer @raise Empty if [q] is empty. @@ -126,13 +123,13 @@ val peek_exn : 'a t -> 'a 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. This can only be used by the consumer. + queue is empty. This can only be used by the consumer. @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_exn}, the item +(** [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_exn}, the item might be skipped). @raise Closed if [q] is closed and empty. *) @@ -142,83 +139,82 @@ val push_head : 'a t -> 'a -> unit (** {2 Sequential example} An example top-level session: {[ - # open Saturn.Single_consumer_queue - # let t : int t = create () - val t : int t = - # push t 1 - - : unit = () - # push t 42 - - : unit = () - # pop_opt t - - : int option = Some 1 - # peek_opt t - - : int option = Some 42 - # drop_exn t - - : unit = () - # pop_exn t - Exception: Saturn__Mpsc_queue.Empty.]} -*) + # open Saturn.Single_consumer_queue + # let t : int t = create () + val t : int t = + # push t 1 + - : unit = () + # push t 42 + - : unit = () + # pop_opt t + - : int option = Some 1 + # peek_opt t + - : int option = Some 42 + # drop_exn t + - : unit = () + # pop_exn t + Exception: Saturn__Mpsc_queue.Empty. + ]} *) (** {2 Multicore example} - {b Note}: The barrier is used in this example solely to make the results more - interesting by increasing the likelihood of parallelism. Spawning a domain - is a costly operation, especially compared to the relatively small amount of - work being performed here. In practice, using a barrier in this manner is - unnecessary. - + {b Note}: The barrier is used in this example solely to make the results + more interesting by increasing the likelihood of parallelism. Spawning a + domain is a costly operation, especially compared to the relatively small + amount of work being performed here. In practice, using a barrier in this + manner is unnecessary. + {@ocaml non-deterministic=command[ - # open Saturn.Single_consumer_queue - # let t : (string * int) t = create () - val t : (string * int) t = - # let barrier = Atomic.make 3 - val barrier : int Atomic.t = - # let n = 10 - val n : int = 10 - - # let work_consumer () = - Atomic.decr barrier; - while Atomic.get barrier <> 0 do Domain.cpu_relax () done; - for i = 1 to n do - begin - match pop_opt t with - | None -> Printf.printf "Empty.\n%!" - | Some (s, n) -> - Printf.printf "Consumed ressource #%d from %s.\n%!" n s - end; - Domain.cpu_relax () - done; - val work_consumer : unit -> unit = - - # let work_producer id () = - Atomic.decr barrier; - while Atomic.get barrier <> 0 do Domain.cpu_relax () done; - List.init n Fun.id - |> List.iter (fun i -> push t (id , i); - Domain.cpu_relax ()) - val work_producer : string -> unit -> unit = - - # let consumer = Domain.spawn work_consumer - val consumer : unit Domain.t = - # let producerA = Domain.spawn (work_producer "A") - val producerA : unit Domain.t = - # let producerB = Domain.spawn (work_producer "B") - Empty. - Consumed ressource #0 from A. - Consumed ressource #0 from B. - Consumed ressource #1 from B. - Consumed ressource #2 from B. - Consumed ressource #3 from B. - Consumed ressource #4 from B. - Consumed ressource #5 from B. - Consumed ressource #6 from B. - Consumed ressource #7 from B. - val producerB : unit Domain.t = - - # Domain.join consumer - - : unit = () - # Domain.join producerA - - : unit = () - # Domain.join producerB - - : unit = () - ]} - *) + # open Saturn.Single_consumer_queue + # let t : (string * int) t = create () + val t : (string * int) t = + # let barrier = Atomic.make 3 + val barrier : int Atomic.t = + # let n = 10 + val n : int = 10 + + # let work_consumer () = + Atomic.decr barrier; + while Atomic.get barrier <> 0 do Domain.cpu_relax () done; + for i = 1 to n do + begin + match pop_opt t with + | None -> Printf.printf "Empty.\n%!" + | Some (s, n) -> + Printf.printf "Consumed ressource #%d from %s.\n%!" n s + end; + Domain.cpu_relax () + done; + val work_consumer : unit -> unit = + + # let work_producer id () = + Atomic.decr barrier; + while Atomic.get barrier <> 0 do Domain.cpu_relax () done; + List.init n Fun.id + |> List.iter (fun i -> push t (id , i); + Domain.cpu_relax ()) + val work_producer : string -> unit -> unit = + + # let consumer = Domain.spawn work_consumer + val consumer : unit Domain.t = + # let producerA = Domain.spawn (work_producer "A") + val producerA : unit Domain.t = + # let producerB = Domain.spawn (work_producer "B") + Empty. + Consumed ressource #0 from A. + Consumed ressource #0 from B. + Consumed ressource #1 from B. + Consumed ressource #2 from B. + Consumed ressource #3 from B. + Consumed ressource #4 from B. + Consumed ressource #5 from B. + Consumed ressource #6 from B. + Consumed ressource #7 from B. + val producerB : unit Domain.t = + + # Domain.join consumer + - : unit = () + # Domain.join producerA + - : unit = () + # Domain.join producerB + - : unit = () + ]} *) diff --git a/src/saturn.mli b/src/saturn.mli index 88b4a703..33704990 100644 --- a/src/saturn.mli +++ b/src/saturn.mli @@ -53,16 +53,16 @@ Copyright (c) 2017, Nicolas ASSOUAD (** {2 Unsafe Data Structures} - Some data structures have both a normal and an {b unsafe} version. The - {b unsafe} version uses `Obj.magic`, which can be unsafe, especially with - flambda2 optimizations. + Some data structures have both a normal and an {b unsafe} version. The + {b unsafe} version uses `Obj.magic`, which can be unsafe, especially with + flambda2 optimizations. - The unsafe version is provided to explore performance optimizations that - require features not currently available in OCaml, such as arrays of atomics - or atomic fields in records. These versions give an indication of the - potential performance improvements when such features become available. - It is recommended to use the normal version unless the performance - requirements justify the risks associated with the unsafe version. *) + The unsafe version is provided to explore performance optimizations that + require features not currently available in OCaml, such as arrays of atomics + or atomic fields in records. These versions give an indication of the + potential performance improvements when such features become available. It + is recommended to use the normal version unless the performance requirements + justify the risks associated with the unsafe version. *) (** {1 Data structures} *) @@ -88,7 +88,7 @@ module Single_prod_single_cons_queue_unsafe = Spsc_queue_unsafe module Stack = Treiber_stack module Bounded_stack = Bounded_stack -(** {2 Work Stealing Deque }*) +(** {2 Work Stealing Deque}*) module Work_stealing_deque = Ws_deque diff --git a/src/size.ml b/src/size.ml index bb519440..2973e9f4 100644 --- a/src/size.ml +++ b/src/size.ml @@ -24,9 +24,8 @@ module Snapshot = struct (** We use an optimized flat representation where the first element of the array holds the status of the snapshot. - +--------+---------+---------+---------+- - - - | status | counter | counter | counter | ... - +--------+---------+---------+---------+- - - + +--------+---------+---------+---------+- - - | status | counter | counter + | counter | ... +--------+---------+---------+---------+- - - The status is either {!collecting}, {!computing}, or a non-negative value. @@ -48,7 +47,8 @@ module Snapshot = struct let before = Atomic.get snap in if before = collecting - || (* NOTE: The condition below accounts for overflow. *) + || + (* 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 @@ -58,7 +58,8 @@ module Snapshot = struct while let before = Atomic.get snap in (before = collecting - || (* NOTE: The condition below accounts for overflow. *) + || + (* 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 @@ -101,9 +102,8 @@ 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 | ... - +----------+------+------+------+------+- - - + +----------+------+------+------+------+- - - | 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. diff --git a/src/size.mli b/src/size.mli index 112b05cf..eb133b4d 100644 --- a/src/size.mli +++ b/src/size.mli @@ -1,16 +1,16 @@ (** 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. + 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 + 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. @@ -20,17 +20,10 @@ {[ type 'a node = | Null - | Node of { - next : 'a node Atomic.t; - datum : 'a; - } - | Mark of { - node : 'a node; - } + | Node of { next : 'a node Atomic.t; datum : 'a } + | Mark of { node : 'a node } - type 'a t = { - head : 'a node Atomic.t; - } + 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) @@ -42,9 +35,7 @@ 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 + if r.datum == datum then node else try_find t r.next datum next end ]} @@ -61,15 +52,9 @@ datum : 'a; mutable incr : Size.once; (* ADDED *) } - | Mark of { - node : 'a node; - decr : Size.once; (* ADDED *) - } + | Mark of { node : 'a node; decr : Size.once (* ADDED *) } - type 'a t = { - head : 'a node Atomic.t; - size : Size.t; (* 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) @@ -77,14 +62,16 @@ | Node r as node -> begin match Atomic.get r.next with | Mark r -> - Size.update_once t.size r.decr; (* ADDED *) + 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 *) + Size.update_once t.size r.incr; + (* ADDED *) r.incr <- Size.used_once end; node @@ -94,13 +81,13 @@ ]} Notice how the mutable [incr] field is tested against and overwritten with - {!used_once} after being performed. This can improve performance as nodes + {!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 + 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. *) @@ -108,7 +95,7 @@ type t (** The type of a size counter. *) val create : unit -> t -(** [create ()] allocates a new size counter. The initial value of the size +(** [create ()] allocates a new size counter. The initial value of the size counter will be [0]. *) type once @@ -144,7 +131,7 @@ 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 +(** [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 diff --git a/src/skiplist.ml b/src/skiplist.ml index 074bc1bc..945d77bf 100644 --- a/src/skiplist.ml +++ b/src/skiplist.ml @@ -100,9 +100,9 @@ let[@inline] is_marked = function (* *) -(** [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 +(** [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 diff --git a/src/skiplist.mli b/src/skiplist.mli index ae5da4a3..1d585586 100644 --- a/src/skiplist.mli +++ b/src/skiplist.mli @@ -1,16 +1,16 @@ (** Lock-free non-resizable skiplist. - A skiplist is a probabilistic data structure that has an average logarithmic - complexity for search and insertion operations. Like `Stdlib.Map`, it is an + A skiplist is a probabilistic data structure that has an average logarithmic + complexity for search and insertion operations. Like `Stdlib.Map`, it is an ordered collection. - {b Warning}: This skiplist is not resizable. It will, however, continue - to work once the limit capacity is reached, but performance will decrease as - the depth of the structure won't be enough to maintain logarithmic performance. + {b Warning}: This skiplist is not resizable. It will, however, continue to + work once the limit capacity is reached, but performance will decrease as + the depth of the structure won't be enough to maintain logarithmic + performance. - {b Sources}: This implementation is inspired by the algorithm in chapter 14 of - {i The Art of Multiprocessor Programming} book. -*) + {b Sources}: This implementation is inspired by the algorithm in chapter 14 + of {i The Art of Multiprocessor Programming} book. *) (** {1 API}*) @@ -27,9 +27,9 @@ val create : ?max_height:int -> compare:('k -> 'k -> int) -> unit -> ('k, 'v) t 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. - [max_height] can be more than 30. *) + the skiplist and directly affects the performance of the skiplist. The + current implementation does not adjust height automatically. [max_height] + can be more than 30. *) val max_height_of : ('k, 'v) t -> int (** [max_height_of s] returns the maximum height of nodes of the skiplist [s] as @@ -41,87 +41,87 @@ val length : ('k, 'v) t -> int (** {2 Looking up bindings} *) val find_opt : ('k, 'v) t -> 'k -> 'v option -(** [find_opt sl key] returns [Some] of the current binding of [key] in the +(** [find_opt sl key] returns [Some] of the current binding of [key] in the skiplist [sl] or [None] if it does not exist. *) val find_exn : ('k, 'v) t -> 'k -> 'v -(** [find_exn sl key] returns the current binding of [key] in the skiplist - [sl] or raises {!Not_found} if no such binding exists. +(** [find_exn sl key] returns the current binding of [key] in the skiplist [sl] + or raises {!Not_found} if no such binding exists. @raise Not_found if no binding of [key] exists in the skiplist [sl]. *) val mem : ('k, 'v) t -> 'k -> bool -(** [mem sl k] determines whether the skiplist [sl] contained a binding of [k]. *) +(** [mem sl k] determines whether the skiplist [sl] contained a binding of [k]. +*) (** {2 Adding bindings} *) val try_add : ('k, 'v) t -> 'k -> 'v -> bool -(** [try_add sk key value] tries to add a new binding of [key] to [value] to - the skiplist [sl]. Returns [true] on success and [false] if the skiplist - already contains a binding for [key]. *) +(** [try_add sk key value] tries to add a new binding of [key] to [value] to the + skiplist [sl]. Returns [true] on success and [false] if the skiplist already + contains a binding for [key]. *) val try_remove : ('k, 'v) t -> 'k -> bool -(** [try_remove sl key] tries to remove a binding of [key] from the skiplist [sl]. - Returns [true] on success and [false] if the skiplist does not contain a - binding for [key]. *) +(** [try_remove sl key] tries to remove a binding of [key] from the skiplist + [sl]. Returns [true] on success and [false] if the skiplist does not contain + a binding for [key]. *) (** {1 Examples} *) -(** {2 Sequential example} +(** {2 Sequential example} -{[ - # open Saturn.Skiplist - # let t = create ~compare:Int.compare () - val t : (int, '_weak1) t = - # try_add t 42 "The answer" - - : bool = true + {[ + # open Saturn.Skiplist + # let t = create ~compare:Int.compare () + val t : (int, '_weak1) t = + # try_add t 42 "The answer" + - : bool = true - # try_add t 101 "Basics" - - : bool = true + # try_add t 101 "Basics" + - : bool = true - # find_opt t 42 - - : string option = Some "The answer" + # find_opt t 42 + - : string option = Some "The answer" - # try_add t 101 "The basics" - - : bool = false + # try_add t 101 "The basics" + - : bool = false - # try_remove t 101 - - : bool = true -]} -*) + # try_remove t 101 + - : bool = true + ]} *) (** {2 Multicore example} - {b Note}: The barrier is used in this example solely to make the results more - interesting by increasing the likelihood of parallelism. Spawning a domain is - a costly operation, especially compared to the relatively small amount of work - being performed here. In practice, using a barrier in this manner is unnecessary. - -{[ - # open Saturn.Skiplist - # let t : (int, int) t= create ~compare:Int.compare () - val t : (int, int) t = - # Random.self_init () - - : unit = () - # let barrier = Atomic.make 2 - val barrier : int Atomic.t = - - # let work () = - Atomic.decr barrier; - while Atomic.get barrier > 0 do () done; - for i = 0 to 10 do - if Random.bool () then - try_add t i i |> ignore - else - try_remove t i |> ignore - done - val work : unit -> unit = - - # let d1 = Domain.spawn work - val d1 : unit Domain.t = - # let d2 = Domain.spawn work - val d2 : unit Domain.t = - # Domain.join d1; Domain.join d2 - - : unit = () -]} -*) + {b Note}: The barrier is used in this example solely to make the results + more interesting by increasing the likelihood of parallelism. Spawning a + domain is a costly operation, especially compared to the relatively small + amount of work being performed here. In practice, using a barrier in this + manner is unnecessary. + + {[ + # open Saturn.Skiplist + # let t : (int, int) t= create ~compare:Int.compare () + val t : (int, int) t = + # Random.self_init () + - : unit = () + # let barrier = Atomic.make 2 + val barrier : int Atomic.t = + + # let work () = + Atomic.decr barrier; + while Atomic.get barrier > 0 do () done; + for i = 0 to 10 do + if Random.bool () then + try_add t i i |> ignore + else + try_remove t i |> ignore + done + val work : unit -> unit = + + # let d1 = Domain.spawn work + val d1 : unit Domain.t = + # let d2 = Domain.spawn work + val d2 : unit Domain.t = + # Domain.join d1; Domain.join d2 + - : unit = () + ]} *) diff --git a/src/spsc_queue/spsc_queue.mli b/src/spsc_queue/spsc_queue.mli index 64ef149f..f1cdd893 100644 --- a/src/spsc_queue/spsc_queue.mli +++ b/src/spsc_queue/spsc_queue.mli @@ -1,9 +1,8 @@ -(** Lock-free single-producer, single-consumer queue. - - {b Warning}: This queue does not include safety mechanisms to prevent +(** Lock-free single-producer, single-consumer queue. + + {b Warning}: This queue does not include safety mechanisms to prevent misuse. If consumer-only functions are called concurrently by multiple - domains, the queue may enter an unexpected state, due to data races - and a lack of linearizability. The same goes for producer-only functions. - *) + domains, the queue may enter an unexpected state, due to data races and a + lack of linearizability. The same goes for producer-only functions. *) include Spsc_queue_intf.SPSC_queue diff --git a/src/spsc_queue/spsc_queue_intf.mli b/src/spsc_queue/spsc_queue_intf.mli index ad8ad5bb..1601a31a 100644 --- a/src/spsc_queue/spsc_queue_intf.mli +++ b/src/spsc_queue/spsc_queue_intf.mli @@ -2,37 +2,36 @@ module type SPSC_queue = sig (** {1 API} *) type 'a t - (** Represents a single-producer single-consumer non-resizable queue - that works in FIFO order. *) + (** Represents a single-producer single-consumer non-resizable queue that + works in FIFO order. *) val create : size_exponent:int -> 'a t (** [create ~size_exponent] creates a new single-producer single-consumer - queue with a maximum size of [2^size_exponent] and initially empty. - - 🐌 This is a linear-time operation in [2^size_exponent]. *) + queue with a maximum size of [2^size_exponent] and initially empty. + + 🐌 This is a linear-time operation in [2^size_exponent]. *) val of_list_exn : size_exponent:int -> 'a list -> 'a t (** [of_list_exn ~size_exponent list] creates a new queue from a list. - - @raises Full if the length of [list] is greater than [2^size_exponent]. - - 🐌 This is a linear-time operation. - - {[ - # open Saturn.Single_prod_single_cons_queue - # let t : int t = of_list_exn ~size_exponent:6 [1;2;3;4] - val t : int t = - # pop_opt t - - : int option = Some 1 - # pop_opt t - - : int option = Some 2 - ]} - *) + + @raise Full if the length of [list] is greater than [2^size_exponent]. + + 🐌 This is a linear-time operation. + + {[ + # open Saturn.Single_prod_single_cons_queue + # let t : int t = of_list_exn ~size_exponent:6 [1;2;3;4] + val t : int t = + # pop_opt t + - : int option = Some 1 + # pop_opt t + - : int option = Some 2 + ]} *) val length : 'a t -> int (** [length] returns the length of the queue. This method linearizes only when - called from either the consumer or producer domain. Otherwise, it is safe to - call but provides only an *indication* of the size of the structure. *) + called from either the consumer or producer domain. Otherwise, it is safe + to call but provides only an *indication* of the size of the structure. *) (** {2 Producer functions} *) @@ -40,13 +39,13 @@ module type SPSC_queue = sig (** Raised when {!push_exn} is applied to a full queue. *) val push_exn : 'a t -> 'a -> unit - (** [push queue elt] adds the element [elt] at the end of the [queue]. - This method can be used by at most one domain at a time. - - @raises Full if the [queue] is full. *) + (** [push queue elt] adds the element [elt] at the end of the [queue]. 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 queue elt] tries to add the element [elt] at the end of the + (** [try_push queue elt] tries to add the element [elt] at the end of the [queue]. If the queue [q] is full, [false] is returned. This method can be used by at most one domain at a time. *) @@ -59,120 +58,121 @@ module type SPSC_queue = sig val pop_exn : 'a t -> 'a (** [pop_exn queue] removes and returns the first element in [queue]. This method can be used by at most one domain at a time. - - @raises Empty if the [queue] is empty. *) + + @raise Empty if the [queue] is empty. *) val pop_opt : 'a t -> 'a option (** [pop_opt queue] removes and returns [Some] of the first element of the - [queue], or [None] if the queue is empty. This method can be used by at most - one domain at a time. *) + [queue], or [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 queue] returns the first element in [queue] without removing it. This method can be used by at most one domain at a time. - - @raises Empty if the [queue] is empty. *) + + @raise Empty if the [queue] is empty. *) val peek_opt : 'a t -> 'a option - (** [peek_opt queue] returns [Some] of the first element in [queue], or [None] + (** [peek_opt queue] returns [Some] of the first element in [queue], or [None] if the queue is empty. This method can be used by at most one domain at a time. *) val drop_exn : 'a t -> unit - (** [drop_exn queue] removes the top element of the [queue]. - - @raises Empty if the [queue] is empty. *) + (** [drop_exn queue] removes the top element of the [queue]. + + @raise Empty if the [queue] is empty. *) (** {1 Examples} *) (** {2 Sequential example} *) (** {[ - # open Saturn.Single_prod_single_cons_queue - # let t : int t = create ~size_exponent:2 - val t : int t = - # push_exn t 1 - - : unit = () - # push_exn t 2 - - : unit = () - # try_push t 3 - - : bool = true - # try_push t 4 - - : bool = true - # try_push t 5 - - : bool = false - - # pop_opt t - - : int option = Some 1 - # peek_opt t - - : int option = Some 2 - # drop_exn t - - : unit = () - # pop_exn t - - : int = 3 - # pop_opt t - - : int option = Some 4 - # pop_exn t - Exception: Saturn__Spsc_queue.Empty. - ]} *) - - (** {2 Parallel example} - Note: The barrier is used in this example solely to make the results more - interesting by increasing the likelihood of parallelism. Spawning a domain is - a costly operation, especially compared to the relatively small amount of work - being performed here. In practice, using a barrier in this manner is unnecessary. - - {@ocaml non-deterministic=command[ - # open Saturn.Single_prod_single_cons_queue - # let t : int t = create ~size_exponent:5 - val t : int t = - - # let nwork = 5 - val nwork : int = 5 - # let barrier = Atomic.make 2 - - val barrier : int Atomic.t = - # let consumer_work () = - (* Atomic.decr barrier; - while Atomic.get barrier <> 0 do Domain.cpu_relax () done; *) - let rec loop n = - if n < 1 then () - else - (Domain.cpu_relax (); - match pop_opt t with - | Some p -> Format.printf "Popped %d\n%!" p; loop (n-1) - | None -> loop n) - in - loop nwork - val consumer_work : unit -> unit = - - # let producer_work () = - (* Atomic.decr barrier; - while Atomic.get barrier <> 0 do Domain.cpu_relax () done; *) - for i = 1 to nwork do - Domain.cpu_relax (); - try_push t i |> ignore; - Format.printf "Pushed %d\n%!" i - done - val producer_work : unit -> unit = - - # let consumer = Domain.spawn consumer_work - val consumer : unit Domain.t = - # let producer = Domain.spawn producer_work - Pushed 1 - Popped 1 - Pushed 2 - Popped 2 - Pushed 3 - Popped 3 - Pushed 4 - Popped 4 - Popped 5 - Pushed 5 - val producer : unit Domain.t = - # Domain.join consumer - - : unit = () - # Domain.join producer - - : unit = () - ]} *) + # open Saturn.Single_prod_single_cons_queue + # let t : int t = create ~size_exponent:2 + val t : int t = + # push_exn t 1 + - : unit = () + # push_exn t 2 + - : unit = () + # try_push t 3 + - : bool = true + # try_push t 4 + - : bool = true + # try_push t 5 + - : bool = false + + # pop_opt t + - : int option = Some 1 + # peek_opt t + - : int option = Some 2 + # drop_exn t + - : unit = () + # pop_exn t + - : int = 3 + # pop_opt t + - : int option = Some 4 + # pop_exn t + Exception: Saturn__Spsc_queue.Empty. + ]} *) + + (** {2 Parallel example} + Note: The barrier is used in this example solely to make the results more + interesting by increasing the likelihood of parallelism. Spawning a domain + is a costly operation, especially compared to the relatively small amount + of work being performed here. In practice, using a barrier in this manner + is unnecessary. + + {@ocaml non-deterministic=command[ + # open Saturn.Single_prod_single_cons_queue + # let t : int t = create ~size_exponent:5 + val t : int t = + + # let nwork = 5 + val nwork : int = 5 + # let barrier = Atomic.make 2 + + val barrier : int Atomic.t = + # let consumer_work () = + (* Atomic.decr barrier; + while Atomic.get barrier <> 0 do Domain.cpu_relax () done; *) + let rec loop n = + if n < 1 then () + else + (Domain.cpu_relax (); + match pop_opt t with + | Some p -> Format.printf "Popped %d\n%!" p; loop (n-1) + | None -> loop n) + in + loop nwork + val consumer_work : unit -> unit = + + # let producer_work () = + (* Atomic.decr barrier; + while Atomic.get barrier <> 0 do Domain.cpu_relax () done; *) + for i = 1 to nwork do + Domain.cpu_relax (); + try_push t i |> ignore; + Format.printf "Pushed %d\n%!" i + done + val producer_work : unit -> unit = + + # let consumer = Domain.spawn consumer_work + val consumer : unit Domain.t = + # let producer = Domain.spawn producer_work + Pushed 1 + Popped 1 + Pushed 2 + Popped 2 + Pushed 3 + Popped 3 + Pushed 4 + Popped 4 + Popped 5 + Pushed 5 + val producer : unit Domain.t = + # Domain.join consumer + - : unit = () + # Domain.join producer + - : unit = () + ]} *) end diff --git a/src/spsc_queue/spsc_queue_unsafe.ml b/src/spsc_queue/spsc_queue_unsafe.ml index 333d7d1d..1892b49a 100644 --- a/src/spsc_queue/spsc_queue_unsafe.ml +++ b/src/spsc_queue/spsc_queue_unsafe.ml @@ -65,7 +65,7 @@ let of_list_exn ~size_exponent values = let head_cache = ref 0 |> Multicore_magic.copy_as_padded in { array; tail; tail_cache; head; head_cache } -(* *) +(* *) type _ mono = Unit : unit mono | Bool : bool mono diff --git a/src/spsc_queue/spsc_queue_unsafe.mli b/src/spsc_queue/spsc_queue_unsafe.mli index 58306f29..5514080f 100644 --- a/src/spsc_queue/spsc_queue_unsafe.mli +++ b/src/spsc_queue/spsc_queue_unsafe.mli @@ -1,9 +1,8 @@ -(** Optimized lock-free single-producer, single-consumer queue. - - {b Warning}: This queue does not include safety mechanisms to prevent +(** Optimized lock-free single-producer, single-consumer queue. + + {b Warning}: This queue does not include safety mechanisms to prevent misuse. If consumer-only functions are called concurrently by multiple - domains, the queue may enter an unexpected state, due to data races - and a lack of linearizability. The same goes for producer-only functions. - *) + domains, the queue may enter an unexpected state, due to data races and a + lack of linearizability. The same goes for producer-only functions. *) include Spsc_queue_intf.SPSC_queue diff --git a/src/treiber_stack.mli b/src/treiber_stack.mli index 3d1d9c8d..1a39018d 100644 --- a/src/treiber_stack.mli +++ b/src/treiber_stack.mli @@ -1,7 +1,7 @@ (** Lock-free multi-producer multi-consumer Treiber stack. - All functions are lock-free. It is the recommended starting point - when needing a LIFO structure. *) + All functions are lock-free. It is the recommended starting point when + needing a LIFO structure. *) (** {1 API} *) @@ -15,56 +15,55 @@ val of_list : 'a list -> 'a t (** [of_list list] creates a new Treiber stack from a list. *) val is_empty : 'a t -> bool -(** [is_empty stack] returns [true] if the [stack] is empty, otherwise [false]. *) +(** [is_empty stack] returns [true] if the [stack] is empty, otherwise [false]. +*) (** {2 Consumer functions} *) exception Empty -(** Raised when {!pop_exn}, {!peek_exn} and {!drop_exn} is - applied to an empty stack. -*) +(** Raised when {!pop_exn}, {!peek_exn} and {!drop_exn} is applied to an empty + stack. *) val peek_exn : 'a t -> 'a (** [peek_exn stack] returns the top element of the [stack] without removing it. - - @raises Empty if the [stack] is empty. *) + + @raise Empty if the [stack] is empty. *) val peek_opt : 'a t -> 'a option (** [peek_opt stack] returns [Some] of the top element of the [stack] without - removing it, or [None] if the [stack] is empty. *) + removing it, or [None] if the [stack] is empty. *) val pop_exn : 'a t -> 'a (** [pop_exn stack] removes and returns the top element of the [stack]. - - @raises Empty if the [stack] is empty. *) + + @raise Empty if the [stack] is empty. *) val pop_opt : 'a t -> 'a option -(** [pop_opt stack] removes and returns [Some] of the top element of the [stack], - or [None] if the [stack] is empty. *) +(** [pop_opt stack] removes and returns [Some] of the top element of the + [stack], or [None] if the [stack] is empty. *) val drop_exn : 'a t -> unit -(** [drop_exn stack] removes the top element of the [stack]. +(** [drop_exn stack] removes the top element of the [stack]. - @raises Empty if the [stack] is empty. *) + @raise Empty if the [stack] is empty. *) val pop_all : 'a t -> 'a list -(** [pop_all stack] removes and returns all elements of the [stack] in LIFO -order. - - {[ - # open Saturn.Stack - # let t : int t = create () - val t : int t = - # push t 1 - - : unit = () - # push t 2 - - : unit = () - # push t 3 - - : unit = () - # pop_all t - - : int list = [3; 2; 1] - ]} -*) +(** [pop_all stack] removes and returns all elements of the [stack] in LIFO + order. + + {[ + # open Saturn.Stack + # let t : int t = create () + val t : int t = + # push t 1 + - : unit = () + # push t 2 + - : unit = () + # push t 3 + - : unit = () + # pop_all t + - : int list = [3; 2; 1] + ]} *) (** {2 Producer functions} *) @@ -72,98 +71,97 @@ val push : 'a t -> 'a -> unit (** [push stack element] adds [element] to the top of the [stack]. *) val push_all : 'a t -> 'a list -> unit -(** [push_all stack elements] adds all [elements] to the top of the [stack]. - - 🐌 This is a linear-time operation on the size of [elements]. - - {[ - # let t : int t = create () - val t : int t = - # push_all t [1; 2; 3; 4] - - : unit = () - # pop_opt t - - : int option = Some 4 - # pop_opt t - - : int option = Some 3 - # pop_all t - - : int list = [2; 1] - ]} - *) - -(** {2 With Sequences }*) +(** [push_all stack elements] adds all [elements] to the top of the [stack]. + + 🐌 This is a linear-time operation on the size of [elements]. + + {[ + # let t : int t = create () + val t : int t = + # push_all t [1; 2; 3; 4] + - : unit = () + # pop_opt t + - : int option = Some 4 + # pop_opt t + - : int option = Some 3 + # pop_all t + - : int list = [2; 1] + ]} *) + +(** {2 With Sequences}*) val to_seq : 'a t -> 'a Seq.t -(** [to_seq stack] takes a snapshot of [stack] and returns its value top to -bottom. +(** [to_seq stack] takes a snapshot of [stack] and returns its value top to + bottom. - 🐌 This is a linear time operation. *) + 🐌 This is a linear time operation. *) val of_seq : 'a Seq.t -> 'a t -(** [of_seq seq] creates a stack from a [seq]. It must be finite. +(** [of_seq seq] creates a stack from a [seq]. It must be finite. - 🐌 This is a linear-time operation. *) + 🐌 This is a linear-time operation. *) val add_seq : 'a t -> 'a Seq.t -> unit -(** [add_seq stack seq] adds all elements of [seq] to the top of the -[stack]. [seq] must be finite. +(** [add_seq stack seq] adds all elements of [seq] to the top of the [stack]. + [seq] must be finite. - 🐌 This is a linear-time operation on the size of [elements]. *) + 🐌 This is a linear-time operation on the size of [elements]. *) (** {1 Examples} *) (** {2 Sequential example} - An example top-level session: - {[ - # open Saturn.Stack - # let t : int t = create () - val t : int t = - # push t 42 - - : unit = () - # push_all t [1; 2; 3] - - : unit = () - # pop_exn t - - : int = 3 - # peek_opt t - - : int option = Some 2 - # pop_all t - - : int list = [2; 1; 42] - # pop_exn t - Exception: Saturn__Treiber_stack.Empty.]} -*) + An example top-level session: + {[ + # open Saturn.Stack + # let t : int t = create () + val t : int t = + # push t 42 + - : unit = () + # push_all t [1; 2; 3] + - : unit = () + # pop_exn t + - : int = 3 + # peek_opt t + - : int option = Some 2 + # pop_all t + - : int list = [2; 1; 42] + # pop_exn t + Exception: Saturn__Treiber_stack.Empty. + ]} *) (** {2 Multicore example} - Note: The barrier is used in this example solely to make the results more - interesting by increasing the likelihood of parallelism. Spawning a domain is - a costly operation, especially compared to the relatively small amount of work - being performed here. In practice, using a barrier in this manner is unnecessary. - - {@ocaml non-deterministic=command[ - # open Saturn.Stack - # let t : int t = create () - val t : int t = - # let barrier = Atomic.make 2 - val barrier : int Atomic.t = - - # let pusher () = - Atomic.decr barrier; - while Atomic.get barrier != 0 do Domain.cpu_relax () done; - push_all t [1;2;3] |> ignore; - push t 42; - push t 12 - val pusher : unit -> unit = - - # let popper () = - Atomic.decr barrier; - while Atomic.get barrier != 0 do Domain.cpu_relax () done; - List.init 6 (fun i -> Domain.cpu_relax (); pop_opt t) - val popper : unit -> int option list = - - # let domain_pusher = Domain.spawn pusher - val domain_pusher : unit Domain.t = - # let domain_popper = Domain.spawn popper - val domain_popper : int option list Domain.t = - # Domain.join domain_pusher - - : unit = () - # Domain.join domain_popper - - : int option list = [Some 42; Some 3; Some 2; Some 1; None; Some 12] - ]} - *) + Note: The barrier is used in this example solely to make the results more + interesting by increasing the likelihood of parallelism. Spawning a domain + is a costly operation, especially compared to the relatively small amount of + work being performed here. In practice, using a barrier in this manner is + unnecessary. + + {@ocaml non-deterministic=command[ + # open Saturn.Stack + # let t : int t = create () + val t : int t = + # let barrier = Atomic.make 2 + val barrier : int Atomic.t = + + # let pusher () = + Atomic.decr barrier; + while Atomic.get barrier != 0 do Domain.cpu_relax () done; + push_all t [1;2;3] |> ignore; + push t 42; + push t 12 + val pusher : unit -> unit = + + # let popper () = + Atomic.decr barrier; + while Atomic.get barrier != 0 do Domain.cpu_relax () done; + List.init 6 (fun i -> Domain.cpu_relax (); pop_opt t) + val popper : unit -> int option list = + + # let domain_pusher = Domain.spawn pusher + val domain_pusher : unit Domain.t = + # let domain_popper = Domain.spawn popper + val domain_popper : int option list Domain.t = + # Domain.join domain_pusher + - : unit = () + # Domain.join domain_popper + - : int option list = [Some 42; Some 3; Some 2; Some 1; None; Some 12] + ]} *) diff --git a/src/ws_deque.ml b/src/ws_deque.ml index 31995b36..3874bbbf 100644 --- a/src/ws_deque.ml +++ b/src/ws_deque.ml @@ -61,7 +61,7 @@ let of_list l = let top_cache = ref 0 |> Multicore_magic.copy_as_padded in { top; bottom; top_cache; tab } |> Multicore_magic.copy_as_padded -(* *) +(* *) let realloc a t b sz new_sz = let new_a = Array.make new_sz (Obj.magic ()) in diff --git a/src/ws_deque.mli b/src/ws_deque.mli index 0e7beef9..10d6ebc7 100644 --- a/src/ws_deque.mli +++ b/src/ws_deque.mli @@ -1,17 +1,17 @@ -(** Lock-free single-producer, multi-consumer dynamic-size double-ended queue (deque). +(** Lock-free single-producer, multi-consumer dynamic-size double-ended queue + (deque). - The main strength of a deque in a typical work-stealing setup with a - per-core structure, is efficient work distribution. The owner uses [push] - and [pop] methods to operate at one end of the deque, while other (free) - cores can efficiently steal work from the other side. + The main strength of a deque in a typical work-stealing setup with a + per-core structure, is efficient work distribution. The owner uses [push] + and [pop] methods to operate at one end of the deque, while other (free) + cores can efficiently steal work from the other side. - This approach is great for throughput. Stealers and the owner working on - different sides, reduce contention in work distribution. Further, the - local LIFO order, running related tasks one after another, improves locality. + This approach is great for throughput. Stealers and the owner working on + different sides, reduce contention in work distribution. Further, the local + LIFO order, running related tasks one after another, 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. -*) + 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. *) (** {1 API} *) @@ -24,65 +24,64 @@ val create : unit -> 'a t val of_list : 'a list -> 'a t (** [of_list list] creates a new work-stealing queue from [list]. - 🐌 This is a linear-time operation. + 🐌 This is a linear-time operation. - {[ - # open Saturn.Work_stealing_deque - # let t : int t = of_list [1;2;3;4] - val t : int t = - # pop_opt t - - : int option = Some 4 - # pop_opt t - - : int option = Some 3 - ]} -*) + {[ + # open Saturn.Work_stealing_deque + # let t : int t = of_list [1;2;3;4] + val t : int t = + # pop_opt t + - : int option = Some 4 + # pop_opt t + - : int option = Some 3 + ]} *) exception Empty (** {2 Queue owner functions} *) val push : 'a t -> 'a -> unit -(** [push queue element] adds [element] at the end of the [queue]. - It should only be invoked by the domain that owns the [queue]. *) +(** [push queue element] adds [element] at the end of the [queue]. It should + only be invoked by the domain that owns the [queue]. *) val pop_exn : 'a t -> 'a -(** [pop_exn queue] removes and returns the last element of the [queue]. It - should only be invoked by the domain that owns the [queue]. +(** [pop_exn queue] removes and returns the last element of the [queue]. It + should only be invoked by the domain that owns the [queue]. - @raises Empty if the [queue] is empty. *) + @raise Empty if the [queue] is empty. *) val pop_opt : 'a t -> 'a option -(** [pop_opt queue] removes and returns [Some] of the last element of the - [queue], or returns [None] if the [queue] is empty. It should only - be invoked by the domain that owns the [queue]. *) +(** [pop_opt queue] removes and returns [Some] of the last element of the + [queue], or returns [None] if the [queue] is empty. It should only be + invoked by the domain that owns the [queue]. *) val drop_exn : 'a t -> unit -(** [drop_exn queue] removes the last element of the [queue]. It should only - be invoked by the domain that owns the [queue]. - - @raises Empty if the [queue] is empty. *) +(** [drop_exn queue] removes the last element of the [queue]. It should only be + invoked by the domain that owns the [queue]. + + @raise Empty if the [queue] is empty. *) (** {2 Stealer functions} *) val steal_exn : 'a t -> 'a -(** [steal_exn queue] removes and returns the first element of the [queue]. +(** [steal_exn queue] removes and returns the first element of the [queue]. - @raises Empty if the [queue] is empty. *) + @raise Empty if the [queue] is empty. *) val steal_opt : 'a t -> 'a option -(** [steal_opt queue] removes and returns [Some] of the first element of the - [queue], or returns [None] if the [queue] is empty. *) +(** [steal_opt queue] removes and returns [Some] of the first element of the + [queue], or returns [None] if the [queue] is empty. *) val steal_drop_exn : 'a t -> unit -(** [steal_drop_exn queue] removes the first element of the [queue]. - - @raises Empty if the [queue] is empty. *) +(** [steal_drop_exn queue] removes the first element of the [queue]. + + @raise Empty if the [queue] is empty. *) (** {1 Examples} *) -(** {2 Sequential example} - An example top-level session: -{[ +(** {2 Sequential example} + An example top-level session: + {[ # open Saturn.Work_stealing_deque # let t : int t = of_list [1;2;3;4;5;6] val t : int t = @@ -100,24 +99,23 @@ val steal_drop_exn : 'a t -> unit - : int = 3 # steal_exn t Exception: Saturn__Ws_deque.Empty. -]} -*) - -(** {2 Multicore example} - Note: The barrier is used in this example solely to make the results more - interesting by increasing the likelihood of parallelism. Spawning a domain is - a costly operation, especially compared to the relatively small amount of work - being performed here. In practice, using a barrier in this manner is unnecessary. + ]} *) +(** {2 Multicore example} + Note: The barrier is used in this example solely to make the results more + interesting by increasing the likelihood of parallelism. Spawning a domain + is a costly operation, especially compared to the relatively small amount of + work being performed here. In practice, using a barrier in this manner is + unnecessary. -{@ocaml non-deterministic=command[ + {@ocaml non-deterministic=command[ # open Saturn.Work_stealing_deque # let t : int t = create () val t : int t = # let barrier = Atomic.make 3 val barrier : int Atomic.t = - # let owner () = + # let owner () = Atomic.decr barrier; while Atomic.get barrier <> 0 do Domain.cpu_relax () done; for i = 1 to 10 do push t i; Domain.cpu_relax () done @@ -152,5 +150,4 @@ val steal_drop_exn : 'a t -> unit - : unit = () # Domain.join stealerA; Domain.join stealerB - : unit = () -]} -*) + ]} *) diff --git a/test/barrier/barrier.mli b/test/barrier/barrier.mli index c2092158..57a91485 100644 --- a/test/barrier/barrier.mli +++ b/test/barrier/barrier.mli @@ -9,15 +9,12 @@ 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 + 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 @@ -25,32 +22,31 @@ Whereas with the barrier, you should get a random order : {[ - let example_with_barrier nb_domain = - let barrier = Barrier.create nb_domain in + 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 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 + let domains = List.init nb_domain (fun i -> Domain.spawn (printer i)) in - List.iter Domain.join domains + 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 : + 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 - ]} -*) + 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 diff --git a/test/bounded_queue/stm_bounded_queue.ml b/test/bounded_queue/stm_bounded_queue.ml index f9163016..4a8c45ba 100644 --- a/test/bounded_queue/stm_bounded_queue.ml +++ b/test/bounded_queue/stm_bounded_queue.ml @@ -1,4 +1,5 @@ -(** Sequential and Parallel model-based tests of (bounded queue) Bounded_queue. *) +(** Sequential and Parallel model-based tests of (bounded queue) Bounded_queue. +*) open QCheck open STM diff --git a/test/size/linked_set.ml b/test/size/linked_set.ml index 8501dbd5..a95c6f69 100644 --- a/test/size/linked_set.ml +++ b/test/size/linked_set.ml @@ -1,5 +1,5 @@ (** 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 + of using [Size]. The functorization is to allow the use of traced atomics with DSCheck. *) module Make (Atomic : sig type !'a t diff --git a/test/skiplist/dscheck_skiplist.ml b/test/skiplist/dscheck_skiplist.ml index 7822ead4..1a254bf8 100644 --- a/test/skiplist/dscheck_skiplist.ml +++ b/test/skiplist/dscheck_skiplist.ml @@ -1,12 +1,12 @@ open 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. -*) +(** 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 diff --git a/test/ws_deque/test_ws_deque.ml b/test/ws_deque/test_ws_deque.ml index 1173a448..163fbb3a 100644 --- a/test/ws_deque/test_ws_deque.ml +++ b/test/ws_deque/test_ws_deque.ml @@ -79,8 +79,10 @@ let test_concurrent_workload () = (* 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 () + else if + (* No more pushes are allowed. Pop and continue. *) + pop () + then loop () in loop ()) in