├── .gitignore ├── .merlin ├── .ocamlformat ├── .prettierrc ├── CHANGES.md ├── COMPARISON.md ├── LICENSE.md ├── Makefile ├── README.md ├── doc ├── api.odocl ├── dev.odocl └── style.css ├── dune-project ├── lib ├── base.ml ├── base.mli ├── base_intf.ml ├── channel.ml ├── channel.mli ├── channel_intf.ml ├── core.ml ├── core.mli ├── core_intf.ml ├── data │ ├── counter.ml │ ├── counter.mli │ ├── counter_intf.ml │ ├── elimination_stack.ml │ ├── elimination_stack.mli │ ├── elimination_stack_intf.ml │ ├── exchanger.ml │ ├── exchanger.mli │ ├── exchanger_intf.ml │ ├── michaelScott_queue.ml │ ├── michaelScott_queue.mli │ ├── michaelScott_queue_intf.ml │ ├── treiber_stack.ml │ ├── treiber_stack.mli │ └── treiber_stack_intf.ml ├── dune ├── offer.ml ├── offer.mli ├── offer_id.ml ├── offer_id.mli ├── offer_intf.ml ├── postCommitCas.ml ├── postCommitCas.mli ├── reaction.ml ├── reaction.mli ├── reaction_intf.ml ├── reagents.ml ├── reagents.mli ├── reagents_intf.ml ├── ref.ml ├── ref.mli ├── ref_intf.ml ├── scheduler.ml ├── scheduler.mli ├── scheduler_intf.ml ├── sync │ ├── condition_variable.ml │ ├── condition_variable.mli │ ├── condition_variable_intf.ml │ ├── countdown_latch.ml │ ├── countdown_latch.mli │ ├── countdown_latch_intf.ml │ ├── lock.ml │ ├── lock.mli │ ├── lock_intf.ml │ ├── recursive_lock.ml │ ├── recursive_lock.mli │ └── recursive_lock_intf.ml ├── toy_scheduler.ml ├── toy_scheduler.mli └── toy_scheduler_intf.ml ├── reagents.opam └── tests ├── catalyst_test.ml ├── counter_test.ml ├── dining_philosophers.ml ├── dune ├── eli_stack.ml ├── hw_queue.ml ├── lock_test.ml ├── pair_not_parallel.ml ├── queue_test.ml ├── reagent_queue_test.ml ├── rec_test.ml ├── ref_channel.ml ├── ref_test.ml ├── references ├── dune ├── lock.ml ├── lock.mli ├── lock_queue.ml ├── lock_queue.mli ├── lock_stack.ml ├── lock_stack.mli ├── two_lock_queue.ml └── two_lock_queue.mli ├── sat.ml ├── stack_test.ml ├── stack_test_compose.ml └── swap_test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.install 7 | *.native 8 | *.byte -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG bytes 2 | S src 3 | S test 4 | B _build/** 5 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | version = 0.24.1 -------------------------------------------------------------------------------- /.prettierrc: -------------------------------------------------------------------------------- 1 | { 2 | "arrowParens": "avoid", 3 | "bracketSpacing": false, 4 | "printWidth": 80, 5 | "semi": false, 6 | "singleQuote": true, 7 | "proseWrap": "always" 8 | } -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.3.0 2017-11-30 Cambridge 2 | -------------------------- 3 | 4 | Reorganize project for simplicity. 5 | 6 | v0.2.0 2017-11-30 Cambridge 7 | -------------------------- 8 | 9 | Move to jbuilder. 10 | -------------------------------------------------------------------------------- /COMPARISON.md: -------------------------------------------------------------------------------- 1 | Reagents strive to be more expressive than pure kcas, while maintaining 2 | lock-freedom. In particular, they have a richer support for blocking: 3 | 4 | - Reagents always wait efficiently. 5 | - They support complex waiting patterns, e.g. "rendezvous" - two domains 6 | exchanging items atomically. 7 | 8 | However, existing interface overpromises on the actual capabilities. Most 9 | importantly, the rendezvous cases do not compose. While some access patterns 10 | involving multiple domains and multiple communication objects work fine, a 11 | slight tweak may make a reagent deadlock. For working use-cases see 12 | [tests/swap_test.ml](tests/swap_test.ml). Attempt to fix this behaviour leads to 13 | a deeper underlying issue - the parallel composition. 14 | 15 | The parallel composition is implemented as syntactic sugar over sequential 16 | composition, which means there is no true parallelism underneath. Suppose 17 | `lhs <*> rhs`. If lhs reagent depends on rhs reagent, the composition is going 18 | to deadlock. While a direct dependency between the two does not make sense, 19 | there are real-world programs, where such a dependency arises transitively 20 | through interaction with another reagent. See 21 | [test/pair_not_parallel.ml](tests/pair_not_parallel.ml) for examples. Fixing 22 | this behaviour is not trivial 23 | ([issue](https://github.com/ocaml-multicore/reagents/issues/16)) and as far as 24 | the literature is concerned, such a truly parallel composition in the context of 25 | reagents would be a novelty. 26 | 27 | By comparison, kcas offers a more limited support for blocking, which remains 28 | useful for real-world programs and does not suffer from edge cases described 29 | above. Furthermore, the thinner abstraction layer over core kcas makes it more 30 | susceptible to optimization and, at the moment, kcas performs significantly 31 | better. 32 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Théo Laurent 2 | Copyright (c) 2015, KC Sivaramakrishnan 3 | 4 | Permission to use, copy, modify, and/or distribute this software for any 5 | purpose with or without fee is hereby granted, provided that the above 6 | copyright notice and this permission notice appear in all copies. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build @install 3 | 4 | clean: 5 | dune clean 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # = 📢 Note 📢 = 2 | 3 | [kcas](https://github.com/ocaml-multicore/kcas) is the recommended framework for 4 | composable concurrency. It provides a favourable performance and safer interface 5 | than Reagents. 6 | 7 | Reagents are a research project and not ready for production use. This 8 | repository is no longer actively developed or maintained. 9 | 10 | See [comparison](COMPARISON.md) for details. 11 | 12 | # Reagents — Composable lock-free data and synchronization structures 13 | 14 | [API reference](https://ocaml-multicore.github.io/reagents/doc/) 15 | 16 | Reagents are an experimental library for writing multicore programs. Reagents 17 | provide an expressive framework for composable multithreading. They support both 18 | fine- and coarse-grained multithreading and incorporate mechanisms for efficient 19 | retrying. 20 | 21 | ## Contents 22 | 23 | - [Motivation](#motivation) 24 | - [Limitations](#limitations) 25 | - [Getting Reagents](#getting-reagents) 26 | - [Key Concepts](#key-concepts) 27 | - [Development](#development) 28 | - [License](#license) 29 | - [Reading](#reading) 30 | 31 | ## Motivation 32 | 33 | Reagents strive to be a comprehensive framework for all things concurrent and 34 | parallel. In particular, they have the following advantages over traditional 35 | approaches: 36 | 37 | - _Composability_. Operations are trivial to compose with the set of provided 38 | composition operators. An item can be moved from one lock-free stack to 39 | another in a single atomic lock-free step. Further, a release of one lock can 40 | be melded with the acquisition of another one. This has far-reaching 41 | consequences. For example, a simple way to implement an LRU cache is using a 42 | queue and a map, but traditional implementations of thread-safe queue and map 43 | do not help as both have to be updated at once. Reagents make that trivial (in 44 | contrast with implementing thread-safe LRU cache from scratch) and let us 45 | maintain useful properties (in contrast with surrounding both updates with a 46 | lock). 47 | 48 | - _Expressiveness_. Reagents provide building blocks for various multithreading 49 | patterns: communicating by sharing memory and message passing, active and 50 | passive invocation of operations, conjunction (pair) and disjunction (choice) 51 | of operations. 52 | 53 | - _Fine-grained multithreading_. Low-level synchronisation primitives tend to 54 | perform and scale better than high-level ones. Reagents use fine-grained 55 | multithreading internally and expose it for expert users. 56 | 57 | - _Efficient retrying_. Reagents parametrise over the scheduler to suspend and 58 | resume fibers as the conditions for their progress are met or not. This makes 59 | common anti-patterns such as busy-waiting easy to avoid. 60 | 61 | ## Limitations 62 | 63 | Reagents are weaker than transactional memory. A reagent must be decomposable 64 | into a list of compare-and-set operations. This eliminates the need for any 65 | extra accounting for performed CASes. 66 | 67 | ## Getting Reagents 68 | 69 | Reagents require OCaml 5 (`opam switch create 5.0.0`). 70 | 71 | Install Reagents from this repository. 72 | 73 | ```sh 74 | opam pin -y https://github.com/ocaml-multicore/reagents.git 75 | ``` 76 | 77 | Soon Reagents will be available in the opam repository. 78 | 79 | Test the setup in utop with the following snippet. 80 | 81 | ```ocaml 82 | # #require "reagents";; 83 | 84 | # module Scheduler = (val Reagents.Toy_scheduler.make 1 ()) 85 | open Reagents.Make (Scheduler);; 86 | 87 | # let s = Ref.mk_ref "hello world\n" in 88 | Scheduler.run (run (Ref.read s >>> lift print_string));; 89 | 90 | hello world 91 | - : unit = () 92 | ``` 93 | 94 | ## Key concepts 95 | 96 | This section briefly explains all the key concepts required for using Reagents. 97 | 98 | - [Scheduler](#scheduler) 99 | - [Reagent Type](#reagent-type) 100 | - [Combinators](#combinators) 101 | - [Others](#others) 102 | - [Running a Reagent](#running-a-reagent) 103 | 104 | ### Scheduler 105 | 106 | Reagents are parametrised over a minimal 107 | [scheduler interface](lib/scheduler_intf.ml). If an active reagent cannot make 108 | progress, Reagents automatically suspend the fiber. Once someone else updates 109 | the state, Reagents trigger required resumptions. This behavior comes for free. 110 | 111 | ```ocaml 112 | type 'a cont 113 | 114 | val suspend : ('a cont -> 'a option) -> 'a 115 | val resume : 'a cont -> 'a -> unit 116 | val get_tid : unit -> int 117 | ``` 118 | 119 | A toy scheduler for experimenting and running tests is available in 120 | [Reagents.Toy_scheduler](lib/toy_scheduler.mli). 121 | 122 | ### Reagent Type 123 | 124 | A computation within Reagents framework has the following type 125 | `('a, 'b) Reagents.t`. Here, the computation takes a parameter of type `'a` and 126 | returns a value of type `'b`. Internally, it may consist of any number of 127 | operations and any number of side effects. Crucially, regardless of the 128 | construction of a reagent, all of its operations execute atomically and entirely 129 | or none at all. 130 | 131 | ### Combinators 132 | 133 | Reagents can be composed in arbitrary ways. The following three main combinators 134 | are exposed by the library. These can be composed into more complex combinators. 135 | 136 | - ```ocaml 137 | val (>>>) : ('a,'b) t -> ('b,'c) t -> ('a,'c) t 138 | ``` 139 | 140 | Sequential composition runs one reagent after another. It passes the result of 141 | the first one as a parameter to the second one. 142 | 143 | - ```ocaml 144 | val (<*>) : ('a,'b) t -> ('a,'c) t -> ('a,'b * 'c) t 145 | ``` 146 | 147 | Conjunction executes both reagents at once and returns both results. Note, this 148 | combinator still attempts to execute its components sequentially. It differs 149 | with [>>>] in information flow only. 150 | 151 | - ```ocaml 152 | val (<+>) : ('a,'b) t -> ('a,'b) t -> ('a,'b) t 153 | ``` 154 | 155 | Disjunction tries to execute the first reagent and if it blocks, it attempts the 156 | second one. If both block, the first one to unblock is executed. Also referred 157 | to as a left-biased choice. 158 | 159 | ### Running a Reagent 160 | 161 | Once the desired reagent has been composed, it can be run. 162 | 163 | ```ocaml 164 | val run : ('a, 'b) t -> 'a -> 'b 165 | ``` 166 | 167 | `run r v` executes the reagent `r` with value `v`. 168 | 169 | Note, this function has to be executed from within a scheduler for the 170 | suspension and resumption effects to be handled correctly. 171 | 172 | ### Others 173 | 174 | There are several other values defined in the 175 | [public interface](lib/base_intf.ml) that serve as units, helpers, or 176 | transformations for existing reagents. Perhaps the most notable one is 177 | `attempt`, which converts a blocking reagent into a non-blocking one. 178 | 179 | ```ocaml 180 | val attempt : ('a, 'b) t -> ('a, 'b option) t 181 | ``` 182 | 183 | `attempt r` converts a blocking reagent into a non-blocking one. If the reagent 184 | blocks, then attempt returns `None`. Otherwise, the reagent is committed 185 | immediately and the returned option value is non-empty. 186 | 187 | ### Data structures 188 | 189 | Reagents expose two core data structures. Complex data structures should utilise 190 | these as building blocks, if possible. 191 | 192 | - _Reference_ — a low-level object akin to an `'a Atomic.t`, which can be 193 | modified using compare-and-set operation. In contrast with the standard 194 | library's atomic, if the expected value does not match it is going to suspend 195 | until the operation can succeed (in the default case). 196 | 197 | - _Channel_ — a two-way channel for sharing memory by communicating. 198 | 199 | The library also provides many higher-level data structures (e.g. counter, 200 | stack, queue) and synchronisation primitives (e.g. lock, conditional variable). 201 | See [interface](lib/reagents_intf.ml). 202 | 203 | ## Sample programs 204 | 205 | This section showcases a few applications of Reagents. 206 | 207 | - [Counter](#counter) 208 | - [Reference](#reference) 209 | - [Channel](#channel) 210 | - [Catalyst](#catalyst) 211 | 212 | ### Counter 213 | 214 | See a simple example of creating a synchronized counter below. 215 | 216 | ```ocaml 217 | # let counter = Counter.create 0 in 218 | let a = run (Counter.inc counter) () in 219 | let b = run (Counter.inc counter) () in 220 | let c = run (Counter.dec counter) () in 221 | (a, b, c);; 222 | - : int * int * int = (0, 1, 2) 223 | ``` 224 | 225 | Both `inc` and `dec` operations are of type `(unit, int) Reagents.t` since they 226 | take a unit as input and return the previous value. Now, imagine there are 227 | several counters representing different statistics about the system, balances of 228 | bank accounts, etc. 229 | 230 | Reagents let us take a consistent snapshot of the system without locks. 231 | 232 | ```ocaml 233 | # let c1 = Counter.create 0 in 234 | let c2 = Counter.create 0 in 235 | 236 | run (Counter.get c1 <*> Counter.get c2) ();; 237 | - : int * int = (0, 0) 238 | ``` 239 | 240 | ### Reference 241 | 242 | Continuing from [counter](#counter), we can update any number of locations at 243 | once as well. This example uses references, which are similar to an atomic 244 | variable. 245 | 246 | ```ocaml 247 | # let account_1 = Ref.mk_ref 100 in 248 | let account_2 = Ref.mk_ref 0 in 249 | 250 | let transfer a b amount = 251 | Ref.upd a (fun acc () -> Some (acc - amount, ())) 252 | >>> Ref.upd b (fun acc () -> Some (acc + amount, ())) 253 | in 254 | 255 | run (transfer account_1 account_2 100) (); 256 | 257 | ((Ref.read_imm account_1), (Ref.read_imm account_2));; 258 | - : int * int = (0, 100) 259 | ``` 260 | 261 | Note, in the example above the function passed to `Ref.upd` returns an option 262 | type. If the observed value of account is not appropriate for the requested 263 | operation (e.g. the transfer would make account 1 negative), it may choose to 264 | return `None`. In such a case, reagent will block until the value of the 265 | reference is updated by another actor. Alternatively, it can be attempted, to 266 | simply return with failure if the reagent cannot proceed. See 267 | [counter_test.ml](tests/counter_test.ml) for example. 268 | 269 | ### Channel 270 | 271 | Channel is the building block for sharing memory by communication. Reagents 272 | offer a two-way channel (but we can pass units in one direction). 273 | 274 | ```ocaml 275 | # Scheduler.run (fun () -> 276 | let endpoint_a, endpoint_b = Channel.mk_chan () in 277 | Scheduler.fork (fun () -> run (Channel.swap endpoint_a) 12345); 278 | print_int (run (Channel.swap endpoint_b) ()));; 279 | 12345- : unit = () 280 | ``` 281 | 282 | There are a couple of nuances worth keeping in mind: 283 | 284 | - Channels have a blocking nature; the reaction can occur only if there are two 285 | matching reagents ready to interact. Thus, the one to arrive first is going to 286 | block until its match is ready. 287 | - Since `<*>` is not truly parallel, there are some limitations to the type of 288 | channel reactions Reagents are able to commit. See 289 | [pair_not_parallel.ml](tests/pair_not_parallel.ml) for more details. 290 | 291 | ### Catalyst 292 | 293 | Catalyst is a passively invoked reagent. It does not react on its own, instead, 294 | it remains ready to react with others as many times as needed until canceled. 295 | Catalysts let us link multiple data structures to form a graph of computations. 296 | See [catalyst_test.ml](tests/catalyst_test.ml) for examples of linking channels. 297 | 298 | ### More 299 | 300 | More sample programs and tests are located in the [`tests`](tests) directory of 301 | the distribution. They can be built and run with: 302 | 303 | dune build @runtest 304 | 305 | Individual tests are built as executables (available in Dune's `_build` 306 | directory). 307 | 308 | ## Development 309 | 310 | ### Formatting 311 | 312 | This project uses [ocamlformat](https://github.com/ocaml-ppx/ocamlformat) (for 313 | OCaml) and [prettier](https://prettier.io/) (for Markdown). 314 | 315 | ### Internals quick start 316 | 317 | Reagents are largely driven by [kcas](https://github.com/ocaml-multicore/kcas). 318 | kcas is a software solution for executing multiple atomic operations as a single 319 | transaction on architectures providing a single-word CAS only. The current 320 | implementation of kcas requires k+1 atomic operations for k-location update. 321 | 322 | In the non-blocking case, Reagents constitute a convenient abstraction over the 323 | specification and aggregation of individual atomic operations. If the list of 324 | required atomic operations can be constructed and committed immediately, a 325 | reagent succeeds using the fast-path. 326 | 327 | However, an operation may be unable to proceed. If fast-path found that the 328 | operation cannot finish (e.g. pop on an empty stack), Reagents core generates an 329 | offer. The offer is then published in a relevant queue with extra information 330 | and fiber suspends on it. Once another thread comes, it sees the offer and 331 | resumes fibers that are now unblocked. This logic is reagent-specific. In the 332 | case of reference, it's going to wake up all waiters. In the case of channel, it 333 | will take suspended thread's transaction, merge it with its own, and try to 334 | commit everything at once. If the commit succeeds, it provides the suspended 335 | thread with the result and resumes it. Both actions cancel the offer. 336 | 337 | These two mechanisms are the key design choices behind Reagents. 338 | 339 | ## License 340 | 341 | Reagents are distributed under ISC license. 342 | 343 | ## Further Reading 344 | 345 | Talks: 346 | 347 | - [OCaml multicore and programming with Reagents](https://www.youtube.com/watch?v=qRWTws_YPBA&ab_channel=FunctionalWorks) 348 | 349 | Papers in the order of increasing detail: 350 | 351 | - [Lock-free programming for the masses](https://kcsrk.info/papers/reagents_ocaml16.pdf) 352 | 353 | - [Reagents: Expressing and Composing Fine-grained Concurrency](https://aturon.github.io/academic/reagents.pdf) 354 | 355 | - [Understanding and Expressing Scalable Concurrency](https://aturon.github.io/academic/turon-thesis.pdf) 356 | -------------------------------------------------------------------------------- /doc/api.odocl: -------------------------------------------------------------------------------- 1 | Reagents 2 | Reagents_data 3 | Reagents_sync 4 | -------------------------------------------------------------------------------- /doc/dev.odocl: -------------------------------------------------------------------------------- 1 | Reagents 2 | Reagents_data 3 | Reagents_sync 4 | -------------------------------------------------------------------------------- /doc/style.css: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 2 | Distributed under the ISC license, see terms at the end of the file. */ 3 | 4 | /* Reset a few things. */ 5 | html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre, 6 | a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp, 7 | small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset, 8 | form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td 9 | { margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; 10 | font-weight: inherit; font-style:inherit; font-family:inherit; 11 | line-height: inherit; vertical-align: baseline; text-align:inherit; 12 | color:inherit; background: transparent; } 13 | 14 | table { border-collapse: collapse; border-spacing: 0; } 15 | 16 | /* Basic page layout */ 17 | 18 | body { font: normal 10pt/1.375em helvetica, arial, sans-serif; text-align:left; 19 | margin: 1.375em 10%; min-width: 40ex; max-width: 72ex; 20 | color: black; background: transparent /* url(line-height-22.gif) */; } 21 | 22 | b { font-weight: bold } 23 | em { font-style: italic } 24 | 25 | tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; 26 | font-size: 1em; } 27 | pre code { font-size : inherit; } 28 | .codepre { margin-bottom:1.375em /* after code example we introduce space. */ } 29 | 30 | .superscript,.subscript 31 | { font-size : 0.813em; line-height:0; margin-left:0.4ex;} 32 | .superscript { vertical-align: super; } 33 | .subscript { vertical-align: sub; } 34 | 35 | /* ocamldoc markup workaround hacks */ 36 | 37 | hr, hr + br, div + br, center + br, span + br, ul + br, ol + br, pre + br 38 | { display: none } /* annoying */ 39 | 40 | div.info + br { display:block} 41 | 42 | .codepre br + br { display: none } 43 | h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ 44 | 45 | /* Sections and document divisions */ 46 | 47 | /* .navbar { margin-bottom: -1.375em } */ 48 | h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */ 49 | margin-top:0.917em; padding-top:0.875em; 50 | border-top-style:solid; border-width:1px; border-color:#AAA; } 51 | h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } 52 | h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 53 | h3 { font-weight: bold; font-size: 1em; margin-top: 1.375em} 54 | h4 { font-style: italic; } 55 | 56 | /* Used by OCaml's own library documentation. */ 57 | h6 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 58 | .h7 { font-weight: bold; font-size: 1em; margin-top: 1.375em } 59 | 60 | p { margin-top: 1.375em } 61 | pre { margin-top: 1.375em } 62 | .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */ 63 | td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ 64 | 65 | ul, ol { margin-top:0.688em; padding-bottom:0.687em; 66 | list-style-position:outside} 67 | ul + p, ol + p { margin-top: 0em } 68 | ul { list-style-type: square } 69 | 70 | 71 | /* h2 + ul, h3 + ul, p + ul { } */ 72 | ul > li { margin-left: 1.375em; } 73 | ol > li { margin-left: 1.7em; } 74 | /* Links */ 75 | 76 | a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } 77 | a:hover { text-decoration : underline } 78 | *:target {background-color: #FFFF99;} /* anchor highlight */ 79 | 80 | /* Code */ 81 | 82 | .keyword { font-weight: bold; } 83 | .comment { color : red } 84 | .constructor { color : green } 85 | .string { color : brown } 86 | .warning { color : red ; font-weight : bold } 87 | 88 | /* Functors */ 89 | 90 | .paramstable { border-style : hidden ; padding-bottom:1.375em} 91 | .paramstable code { margin-left: 1ex; margin-right: 1ex } 92 | .sig_block {margin-left: 1em} 93 | 94 | /* Images */ 95 | 96 | img { margin-top: 1.375em } 97 | 98 | /*--------------------------------------------------------------------------- 99 | Copyright (c) 2016 Daniel C. Bünzli 100 | 101 | Permission to use, copy, modify, and/or distribute this software for any 102 | purpose with or without fee is hereby granted, provided that the above 103 | copyright notice and this permission notice appear in all copies. 104 | 105 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 106 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 107 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 108 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 109 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 110 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 111 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 112 | ---------------------------------------------------------------------------*/ 113 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) 2 | (name reagents) 3 | 4 | (generate_opam_files true) 5 | 6 | (license BSD-3-clause) 7 | (maintainers "KC Sivaramakrishnan ") 8 | (authors "KC Sivaramakrishnan " ) 9 | (source (github ocaml-multicore/reagents)) 10 | (documentation "https://ocaml-multicore.github.io/reagents/") 11 | 12 | (package 13 | (name reagents) 14 | (depends 15 | (ocaml (>= 5.0)) 16 | (lockfree (>= 0.3.0)) 17 | (kcas (>= 0.2.0)) 18 | (alcotest (and :with-test (>= 1.6.0))) 19 | (kcas_data (and :with-test (>= 0.2.3))) 20 | ) 21 | (synopsis "Composable lock-free data and synchronization structures") 22 | (description "Reagents - Composable lock-free data and synchronization structures")) 23 | 24 | -------------------------------------------------------------------------------- /lib/base.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Base_intf.S 18 | 19 | module Make (Sched : Scheduler.S) : S = struct 20 | include Core.Make (Sched) 21 | module Ref = Ref.Make (Sched) 22 | module Channel = Channel.Make (Sched) 23 | end 24 | -------------------------------------------------------------------------------- /lib/base.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | module type S = Base_intf.S 17 | 18 | module Make (Sched : Scheduler.S) : S 19 | -------------------------------------------------------------------------------- /lib/base_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type ('a, 'b) t 3 | (** The type of a reagent computation which accepts a value of type ['a] and 4 | returns a value of type ['b]. *) 5 | 6 | val never : ('a, 'b) t 7 | (** A reagent that is never enabled. *) 8 | 9 | val constant : 'a -> ('b, 'a) t 10 | (** [constant v] is a reagent that always returns [v]. *) 11 | 12 | val post_commit : ('a -> unit) -> ('a, 'a) t 13 | (** [post_commit f] returns a reagent [r] that runs [f r] after the reagent 14 | [r] (or any reagent constructed using [r]) commits. *) 15 | 16 | val lift : ('a -> 'b) -> ('a, 'b) t 17 | (** [lift f] lifts a pure function [f] to a reagent. If [f] includes 18 | side-effects, then the side-effects may be performed zero or more times. 19 | It is expected that [f] does not perform any blocking operations. *) 20 | 21 | val lift_blocking : ('a -> 'b option) -> ('a, 'b) t 22 | (** [lift_blocking f] blocks if [f] returns [None]. Otherwise, it behaves 23 | like {!lift}. *) 24 | 25 | val return : ('a -> (unit, 'b) t) -> ('a, 'b) t 26 | (** The monadic return primitive for reagents. *) 27 | 28 | val ( >>= ) : ('a, 'b) t -> ('b -> (unit, 'c) t) -> ('a, 'c) t 29 | (** The monadic bind primitive for reagents. *) 30 | 31 | val ( >>> ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t 32 | (** The sequential composition operator. [a >>> b] perform [a] and [b] 33 | atomically. Corresponds to arrow bind. *) 34 | 35 | val ( <+> ) : ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t 36 | (** Left-biased choice. [a <+> b] first attempts [a]. If [a] blocks, then [b] 37 | is attempted. If both of them block, then the whole protocol blocks. *) 38 | 39 | val ( <*> ) : ('a, 'b) t -> ('a, 'c) t -> ('a, 'b * 'c) t 40 | (** Parallel composition operator. [a <*> b] is only enabled if both [a] and 41 | [b] are enabled. *) 42 | 43 | val attempt : ('a, 'b) t -> ('a, 'b option) t 44 | (** Convert a blocking reagent into a non-blocking one. If reagent [r] is a 45 | blocks, then [attempt r] return [None]. If [r] does not block and returns 46 | a value [v], then [attempt r] returns [Some v]. *) 47 | 48 | val run : ('a, 'b) t -> 'a -> 'b 49 | (** [run r v] runs the reagents [r] with value [v]. *) 50 | 51 | module Catalyst : sig 52 | type ('a, 'b) reagent := ('a, 'b) t 53 | 54 | type t 55 | (** Type providing a handle for passively invoked reagent. Such a reagent 56 | remains active and available to react with other reagents until cancelled. *) 57 | 58 | val catalyse : ('a, 'b) reagent -> 'a -> t 59 | (** [catalyse t v] invokes provided reagent as catalyst. *) 60 | 61 | val cancel : t -> unit 62 | (** [cancel c] cancels an active catalyst. If it was already cancelled, 63 | the call has no effect. *) 64 | end 65 | 66 | module Ref : Ref.S with type ('a, 'b) reagent = ('a, 'b) t 67 | (** Shared memory references. *) 68 | 69 | module Channel : Channel.S with type ('a, 'b) reagent = ('a, 'b) t 70 | (** Synchronous message-passing channels. *) 71 | end 72 | -------------------------------------------------------------------------------- /lib/channel.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Channel_intf.S 19 | 20 | module Make (Sched : Scheduler.S) : 21 | S with type ('a, 'b) reagent = ('a, 'b) Core.Make(Sched).t = struct 22 | module Core = Core.Make (Sched) 23 | module Reaction = Reaction.Make (Sched) 24 | module Offer = Offer.Make (Sched) 25 | open Core 26 | 27 | type ('a, 'b) reagent = ('a, 'b) Core.t 28 | 29 | type ('a, 'b) message = 30 | | Message : 'c Offer.t * ('b, 'a) t -> ('a, 'b) message 31 | 32 | let mk_message (type a b c) (payload : a) (sender_rx : Reaction.t) 33 | (sender_k : (b, c) t) (sender_offer : c Offer.t) = 34 | let try_react payload sender_offer sender_rx receiver_k c receiver_rx 35 | receiver_offer = 36 | let rx = Reaction.union sender_rx receiver_rx in 37 | let cas = Offer.complete sender_offer c in 38 | let new_rx = 39 | if can_cas_immediate receiver_k rx receiver_offer then ( 40 | match PostCommitCas.commit cas with 41 | | None -> None 42 | | Some f -> 43 | f (); 44 | Some rx) 45 | else Some (Reaction.with_CAS rx cas) 46 | in 47 | match new_rx with 48 | | None -> Retry 49 | | Some new_rx -> receiver_k.try_react payload new_rx receiver_offer 50 | in 51 | let rec complete_exchange : 'd. (a, 'd) t -> (c, 'd) t = 52 | fun receiver_k -> 53 | { 54 | always_commits = false; 55 | compose = (fun next -> complete_exchange (receiver_k.compose next)); 56 | try_react = try_react payload sender_offer sender_rx receiver_k; 57 | } 58 | in 59 | let complete_exchange = sender_k.compose (complete_exchange Core.commit) in 60 | Message (sender_offer, complete_exchange) 61 | 62 | type ('a, 'b) endpoint = { 63 | name : string; 64 | outgoing : ('a, 'b) message Lockfree.Michael_scott_queue.t; 65 | incoming : ('b, 'a) message Lockfree.Michael_scott_queue.t; 66 | } 67 | 68 | let mk_chan ?name () = 69 | let name = match name with None -> "" | Some n -> n in 70 | let l1 = Lockfree.Michael_scott_queue.create () in 71 | let l2 = Lockfree.Michael_scott_queue.create () in 72 | ( { name = "+" ^ name; incoming = l1; outgoing = l2 }, 73 | { name = "-" ^ name; incoming = l2; outgoing = l1 } ) 74 | 75 | let message_is_active (Message (o, _)) = Offer.is_active o 76 | 77 | let rec swap : 78 | 'a 'b 'r. ('a, 'b) endpoint -> ('b, 'r) reagent -> ('a, 'r) reagent 79 | = 80 | let try_react ep k a rx offer = 81 | let { name = _name; outgoing; incoming } = ep in 82 | (* Search for matching offers *) 83 | let rec try_from cursor retry = 84 | match Lockfree.Michael_scott_queue.next cursor with 85 | | None -> if retry then Retry else Block 86 | | Some (Message (sender_offer, exchange), cursor) -> ( 87 | let same_offer o = function 88 | | None -> false 89 | | Some o' -> Offer.equal o o' 90 | in 91 | if 92 | (not (Offer.is_active sender_offer)) 93 | || Reaction.has_offer rx (Offer.get_id sender_offer) 94 | || same_offer sender_offer offer 95 | then 96 | (* let _ = Printf.printf "me!!\n" in *) 97 | try_from cursor retry 98 | else 99 | (* Found matching offer *) 100 | (* let _ = Printf.printf "found matching offer!\n" in *) 101 | let new_rx = Reaction.with_offer rx (Offer.get_id sender_offer) in 102 | let merged = exchange.compose k in 103 | match merged.try_react a new_rx offer with 104 | | Retry -> try_from cursor true 105 | | Block | BlockAndRetry -> try_from cursor retry 106 | | v -> v) 107 | in 108 | (match offer with 109 | | Some offer (* when (not k.may_sync) *) -> 110 | (* Printf.printf "[%d,%s] pushing offer %d\n" *) 111 | (* (Sched.get_tid ()) name @@ Offer.get_id offer; *) 112 | Lockfree.Michael_scott_queue.push outgoing (mk_message a rx k offer) 113 | | _ -> ()); 114 | (* Printf.printf "[%d,%s] checking..\n" (Sched.get_tid()) name; *) 115 | Lockfree.Michael_scott_queue.clean_until incoming message_is_active; 116 | if Lockfree.Michael_scott_queue.is_empty incoming then Block 117 | else try_from (Lockfree.Michael_scott_queue.snapshot incoming) false 118 | in 119 | fun ep k -> 120 | { 121 | always_commits = false; 122 | compose = (fun next -> swap ep (k.compose next)); 123 | try_react = try_react ep k; 124 | } 125 | 126 | let swap ep = swap ep Core.commit 127 | end 128 | -------------------------------------------------------------------------------- /lib/channel.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Channel_intf.S 19 | 20 | module Make (Sched : Scheduler.S) : 21 | S with type ('a, 'b) reagent = ('a, 'b) Core.Make(Sched).t 22 | -------------------------------------------------------------------------------- /lib/channel_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type ('a, 'b) endpoint 3 | (** The type of endpoint which accepts value of type ['a] and return value of 4 | type ['b]. *) 5 | 6 | type ('a, 'b) reagent 7 | (** The type of reagent. See {!Reagents.S.t}. *) 8 | 9 | val mk_chan : ?name:string -> unit -> ('a, 'b) endpoint * ('b, 'a) endpoint 10 | (** Make a new channel. Returns a pair of dual endpoints. *) 11 | 12 | val swap : ('a, 'b) endpoint -> ('a, 'b) reagent 13 | (** Swap on the channel. *) 14 | end 15 | -------------------------------------------------------------------------------- /lib/core.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Core_intf.S 19 | 20 | module Make (Sched : Scheduler.S) : 21 | S 22 | with type reaction = Reaction.Make(Sched).t 23 | and type 'a offer = 'a Offer.Make(Sched).t = struct 24 | module Reaction = Reaction.Make (Sched) 25 | module Offer = Offer.Make (Sched) 26 | 27 | type reaction = Reaction.t 28 | type 'a offer = 'a Offer.t 29 | type 'a result = BlockAndRetry | Block | Retry | Done of 'a 30 | 31 | type ('a, 'b) t = { 32 | try_react : 'a -> Reaction.t -> 'b Offer.t option -> 'b result; 33 | compose : 'r. ('b, 'r) t -> ('a, 'r) t; 34 | always_commits : bool; 35 | } 36 | 37 | let ( >>> ) r1 r2 = r1.compose r2 38 | 39 | let rec never : 'a 'b. ('a, 'b) t = 40 | { 41 | try_react = (fun _ _ _ -> Block); 42 | always_commits = false; 43 | compose = (fun _ -> never); 44 | } 45 | 46 | let commit : ('a, 'a) t = 47 | let try_react a rx = function 48 | | None -> 49 | (* No offer *) 50 | if Reaction.try_commit rx then Done a else Retry 51 | | Some offer -> ( 52 | match Offer.rescind offer with 53 | | None -> 54 | (* Offer rescinded successfully *) 55 | if Reaction.try_commit rx then Done a else Retry 56 | | Some a' -> Done a') 57 | in 58 | { always_commits = true; compose = (fun next -> next); try_react } 59 | 60 | type ('a, 'b) mkr_info = { 61 | ret_val : 'a -> 'b result; 62 | new_rx : 'a -> Reaction.t -> Reaction.t; 63 | } 64 | 65 | let rec mk_reagent : 'a 'b 'r. ('a, 'b) mkr_info -> ('b, 'r) t -> ('a, 'r) t = 66 | fun m k -> 67 | { 68 | always_commits = k.always_commits; 69 | try_react = 70 | (fun a rx o -> 71 | match m.ret_val a with 72 | | Done b -> k.try_react b (m.new_rx a rx) o 73 | | Retry -> Retry 74 | | Block -> Block 75 | | BlockAndRetry -> BlockAndRetry); 76 | compose = (fun next -> mk_reagent m (k.compose next)); 77 | } 78 | 79 | let constant (x : 'a) : ('b, 'a) t = 80 | mk_reagent { ret_val = (fun _ -> Done x); new_rx = (fun _ v -> v) } commit 81 | 82 | let post_commit (f : 'a -> unit) : ('a, 'a) t = 83 | let ret_val v = Done v in 84 | let new_rx v rx = Reaction.with_post_commit rx (fun () -> f v) in 85 | mk_reagent { ret_val; new_rx } commit 86 | 87 | let lift (f : 'a -> 'b) : ('a, 'b) t = 88 | let ret_val v = Done (f v) in 89 | mk_reagent { ret_val; new_rx = (fun _ v -> v) } commit 90 | 91 | (* [f] should be a pure function *) 92 | let lift_blocking (f : 'a -> 'b option) : ('a, 'b) t = 93 | let ret_val v = match f v with None -> Block | Some r -> Done r in 94 | mk_reagent { ret_val; new_rx = (fun _ v -> v) } commit 95 | 96 | let rec return : 'a 'b 'r. ('a -> (unit, 'b) t) -> ('b, 'r) t -> ('a, 'r) t = 97 | fun f k -> 98 | { 99 | always_commits = false; 100 | compose = (fun next -> return f (k.compose next)); 101 | try_react = (fun a rx o -> ((f a).compose k).try_react () rx o); 102 | } 103 | 104 | let return f = return f commit 105 | let ( >>= ) r f = r >>> return f 106 | 107 | let rec ( <+> ) : 'a 'b 'r. ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t = 108 | fun r1 r2 -> 109 | { 110 | always_commits = r1.always_commits && r2.always_commits; 111 | compose = (fun next -> r1.compose next <+> r2.compose next); 112 | try_react = 113 | (fun a rx offer -> 114 | match r1.try_react a rx offer with 115 | | Done _ as v -> v 116 | | Block -> ( 117 | match r2.try_react a rx offer with 118 | | Retry -> BlockAndRetry 119 | | v -> v) 120 | | Retry -> ( 121 | match r2.try_react a rx offer with 122 | | Block -> BlockAndRetry 123 | | v -> v) 124 | | BlockAndRetry -> ( 125 | match r2.try_react a rx offer with 126 | | Retry | Block -> BlockAndRetry 127 | | v -> v)); 128 | } 129 | 130 | let attempt (r : ('a, 'b) t) : ('a, 'b option) t = 131 | r >>> lift (fun x -> Some x) <+> constant None 132 | 133 | let rec first : 'a 'b 'c 'r. ('a, 'b) t -> ('b * 'c, 'r) t -> ('a * 'c, 'r) t 134 | = 135 | fun r k -> 136 | let try_react (a, c) rx offer = 137 | (r >>> lift (fun b -> (b, c)) >>> k).try_react a rx offer 138 | in 139 | { 140 | always_commits = r.always_commits && k.always_commits; 141 | compose = (fun next -> first r (k.compose next)); 142 | try_react; 143 | } 144 | 145 | let first (r : ('a, 'b) t) : ('a * 'c, 'b * 'c) t = first r commit 146 | 147 | let rec second : 'a 'b 'c 'r. ('a, 'b) t -> ('c * 'b, 'r) t -> ('c * 'a, 'r) t 148 | = 149 | fun r k -> 150 | let try_react (c, a) rx offer = 151 | (r >>> lift (fun b -> (c, b)) >>> k).try_react a rx offer 152 | in 153 | { 154 | always_commits = r.always_commits && k.always_commits; 155 | compose = (fun next -> second r (k.compose next)); 156 | try_react; 157 | } 158 | 159 | let second (r : ('a, 'b) t) : ('c * 'a, 'c * 'b) t = second r commit 160 | 161 | let ( <*> ) (r1 : ('a, 'b) t) (r2 : ('a, 'c) t) : ('a, 'b * 'c) t = 162 | lift (fun a -> (a, a)) >>> first r1 >>> second r2 163 | 164 | let rec with_offer ?offer pause r v = 165 | let offer = 166 | match offer with None -> Offer.make () | Some offer -> offer 167 | in 168 | match r.try_react v Reaction.empty (Some offer) with 169 | | Done res -> res 170 | | f -> ( 171 | (match f with Block -> Offer.wait offer | _ -> pause ()); 172 | match Offer.rescind offer with 173 | | Some ans -> ans 174 | | None -> with_offer pause r v) 175 | 176 | let rec without_offer pause r v = 177 | match r.try_react v Reaction.empty None with 178 | | Done res -> res 179 | | Retry -> 180 | pause (); 181 | without_offer pause r v 182 | | BlockAndRetry -> 183 | pause (); 184 | with_offer pause r v 185 | | Block -> with_offer pause r v 186 | 187 | let run r v = 188 | let b = Lockfree.Backoff.create () in 189 | let pause () = Lockfree.Backoff.once b in 190 | without_offer pause r v 191 | 192 | module Catalyst = struct 193 | type t = Offer.catalyst 194 | 195 | let catalyse r v = 196 | let offer, catalyst = Offer.make_catalyst () in 197 | match r.try_react v Reaction.empty (Some offer) with 198 | | Done _ | Retry | Block | BlockAndRetry -> catalyst 199 | 200 | let cancel = Offer.cancel_catalyst 201 | end 202 | 203 | let can_cas_immediate k rx = function 204 | | Some _ -> false 205 | | None -> Reaction.cas_count rx = 0 && k.always_commits 206 | end 207 | -------------------------------------------------------------------------------- /lib/core.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Core_intf.S 19 | 20 | module Make (Sched : Scheduler.S) : 21 | S 22 | with type reaction = Reaction.Make(Sched).t 23 | and type 'a offer = 'a Offer.Make(Sched).t 24 | -------------------------------------------------------------------------------- /lib/core_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type reaction 3 | type 'a offer 4 | type 'a result = BlockAndRetry | Block | Retry | Done of 'a 5 | 6 | type ('a, 'b) t = { 7 | try_react : 'a -> reaction -> 'b offer option -> 'b result; 8 | compose : 'r. ('b, 'r) t -> ('a, 'r) t; 9 | always_commits : bool; 10 | } 11 | 12 | val never : ('a, 'b) t 13 | val constant : 'a -> ('b, 'a) t 14 | val post_commit : ('a -> unit) -> ('a, 'a) t 15 | val lift : ('a -> 'b) -> ('a, 'b) t 16 | val lift_blocking : ('a -> 'b option) -> ('a, 'b) t 17 | val return : ('a -> (unit, 'b) t) -> ('a, 'b) t 18 | val ( >>= ) : ('a, 'b) t -> ('b -> (unit, 'c) t) -> ('a, 'c) t 19 | val ( >>> ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t 20 | val ( <+> ) : ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t 21 | val ( <*> ) : ('a, 'b) t -> ('a, 'c) t -> ('a, 'b * 'c) t 22 | val attempt : ('a, 'b) t -> ('a, 'b option) t 23 | val run : ('a, 'b) t -> 'a -> 'b 24 | 25 | module Catalyst : sig 26 | type ('a, 'b) reagent := ('a, 'b) t 27 | type t 28 | 29 | val catalyse : ('a, 'b) reagent -> 'a -> t 30 | val cancel : t -> unit 31 | end 32 | 33 | val commit : ('a, 'a) t 34 | val can_cas_immediate : ('a, 'b) t -> reaction -> 'c offer option -> bool 35 | end 36 | -------------------------------------------------------------------------------- /lib/data/counter.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Counter_intf.S 18 | 19 | module Make (Base : Base.S) : 20 | Counter_intf.S with type ('a, 'b) reagent = ('a, 'b) Base.t = struct 21 | module Ref = Base.Ref 22 | 23 | type ('a, 'b) reagent = ('a, 'b) Base.t 24 | type t = int Ref.ref 25 | 26 | let create init = Ref.mk_ref init 27 | let get r = Ref.read r 28 | let inc r = Ref.upd r (fun i () -> Some (i + 1, i)) 29 | let dec r = Ref.upd r (fun i () -> if i > 0 then Some (i - 1, i) else None) 30 | 31 | let try_dec r = 32 | Ref.upd r (fun i () -> 33 | if i > 0 then Some (i - 1, Some i) else Some (0, None)) 34 | end 35 | -------------------------------------------------------------------------------- /lib/data/counter.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Counter_intf.S 18 | 19 | module Make (Base : Base.S) : 20 | Counter_intf.S with type ('a, 'b) reagent = ('a, 'b) Base.t 21 | -------------------------------------------------------------------------------- /lib/data/counter_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | type ('a, 'b) reagent 4 | 5 | val create : int -> t 6 | val get : t -> (unit, int) reagent 7 | val inc : t -> (unit, int) reagent 8 | val dec : t -> (unit, int) reagent 9 | val try_dec : t -> (unit, int option) reagent 10 | end 11 | -------------------------------------------------------------------------------- /lib/data/elimination_stack.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Elimination_stack_intf.S 18 | 19 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t = 20 | struct 21 | type ('a, 'b) reagent = ('a, 'b) Base.t 22 | 23 | module TS = Treiber_stack.Make (Base) 24 | module C = Base.Channel 25 | open Base 26 | 27 | type 'a t = { 28 | stack : 'a TS.t; 29 | elim_push : ('a, unit) C.endpoint; 30 | elim_pop : (unit, 'a) C.endpoint; 31 | } 32 | 33 | let create () = 34 | let elim_push, elim_pop = C.mk_chan () in 35 | { stack = TS.create (); elim_push; elim_pop } 36 | 37 | let push r = TS.push r.stack <+> C.swap r.elim_push 38 | let pop r = TS.pop r.stack <+> C.swap r.elim_pop 39 | 40 | let try_pop r = 41 | let side_chan = C.swap r.elim_pop >>= fun x -> constant (Some x) in 42 | TS.try_pop r.stack <+> side_chan 43 | end 44 | -------------------------------------------------------------------------------- /lib/data/elimination_stack.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Elimination_stack_intf.S 18 | 19 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t 20 | -------------------------------------------------------------------------------- /lib/data/elimination_stack_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a t 3 | type ('a, 'b) reagent 4 | 5 | val create : unit -> 'a t 6 | val push : 'a t -> ('a, unit) reagent 7 | val pop : 'a t -> (unit, 'a) reagent 8 | val try_pop : 'a t -> (unit, 'a option) reagent 9 | end 10 | -------------------------------------------------------------------------------- /lib/data/exchanger.ml: -------------------------------------------------------------------------------- 1 | module type S = Exchanger_intf.S 2 | 3 | module Make (Base : Base.S) : 4 | Exchanger_intf.S with type ('a, 'b) reagent = ('a, 'b) Base.t = struct 5 | type ('a, 'b) reagent = ('a, 'b) Base.t 6 | 7 | module C = Base.Channel 8 | open Base 9 | 10 | type 'a t = ('a, 'a) C.endpoint * ('a, 'a) C.endpoint 11 | 12 | let create = C.mk_chan 13 | let exchange e = C.swap (fst e) <+> C.swap (snd e) 14 | end 15 | -------------------------------------------------------------------------------- /lib/data/exchanger.mli: -------------------------------------------------------------------------------- 1 | (* A two-way exchanger. Unlike channels, exchanger does not distinguish between 2 | * the two channel endpoints. *) 3 | 4 | module type S = Exchanger_intf.S 5 | 6 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t 7 | -------------------------------------------------------------------------------- /lib/data/exchanger_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a t 3 | type ('a, 'b) reagent 4 | 5 | val create : ?name:string -> unit -> 'a t 6 | val exchange : 'a t -> ('a, 'a) reagent 7 | end 8 | -------------------------------------------------------------------------------- /lib/data/michaelScott_queue.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = MichaelScott_queue_intf.S 18 | 19 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t = 20 | struct 21 | type ('a, 'b) reagent = ('a, 'b) Base.t 22 | 23 | module Ref = Base.Ref 24 | open Base 25 | 26 | type 'a node = Nil | Next of 'a * 'a node Ref.ref 27 | type 'a t = { head : 'a node Ref.ref; tail : 'a node Ref.ref } 28 | 29 | let create () = 30 | let init_sentinal = Next (Obj.magic (), Ref.mk_ref Nil) in 31 | { head = Ref.mk_ref init_sentinal; tail = Ref.mk_ref init_sentinal } 32 | 33 | let pop q = 34 | Ref.upd q.head (fun s () -> 35 | match s with 36 | | Nil -> failwith "MSQueue.pop: impossible" 37 | | Next (_, x) -> ( 38 | match Ref.read_imm x with 39 | | Nil -> None 40 | | Next (v, _) as n -> Some (n, v))) 41 | 42 | let try_pop q = 43 | Ref.upd q.head (fun s () -> 44 | match s with 45 | | Nil -> failwith "MSQueue.try_pop: impossible" 46 | | Next (_, x) as n -> ( 47 | match Ref.read_imm x with 48 | | Nil -> Some (n, None) 49 | | Next (v, _) as n -> Some (n, Some v))) 50 | 51 | let rec find_and_enq n tail = 52 | match Ref.read_imm tail with 53 | | Nil -> failwith "MSQueue.push: impossible" 54 | | Next (_, r) as ov -> ( 55 | let s = Ref.read_imm r in 56 | let fwd_tail nv () = ignore @@ Ref.cas_imm tail ov nv in 57 | match s with 58 | | Nil -> Ref.cas ~never_block:true r s n >>> post_commit (fwd_tail n) 59 | | Next (_, _) as nv -> 60 | fwd_tail nv (); 61 | find_and_enq n tail) 62 | 63 | let push q = 64 | return (fun x -> 65 | let new_node = Next (x, Ref.mk_ref Nil) in 66 | find_and_enq new_node q.tail) 67 | end 68 | -------------------------------------------------------------------------------- /lib/data/michaelScott_queue.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = MichaelScott_queue_intf.S 18 | 19 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t 20 | -------------------------------------------------------------------------------- /lib/data/michaelScott_queue_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a t 3 | type ('a, 'b) reagent 4 | 5 | val create : unit -> 'a t 6 | val push : 'a t -> ('a, unit) reagent 7 | val pop : 'a t -> (unit, 'a) reagent 8 | val try_pop : 'a t -> (unit, 'a option) reagent 9 | end 10 | -------------------------------------------------------------------------------- /lib/data/treiber_stack.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Treiber_stack_intf.S 18 | 19 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t = 20 | struct 21 | module Ref = Base.Ref 22 | 23 | type ('a, 'b) reagent = ('a, 'b) Base.t 24 | type 'a t = 'a list Ref.ref 25 | 26 | let create () = Ref.mk_ref [] 27 | let push r = Ref.upd r (fun xs x -> Some (x :: xs, ())) 28 | 29 | let pop r = 30 | Ref.upd r (fun l () -> match l with [] -> None | x :: xs -> Some (xs, x)) 31 | 32 | let try_pop r = 33 | Ref.upd r (fun l () -> 34 | match l with [] -> Some ([], None) | x :: xs -> Some (xs, Some x)) 35 | end 36 | -------------------------------------------------------------------------------- /lib/data/treiber_stack.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Treiber_stack_intf.S 18 | 19 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t 20 | -------------------------------------------------------------------------------- /lib/data/treiber_stack_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a t 3 | type ('a, 'b) reagent 4 | 5 | val create : unit -> 'a t 6 | val push : 'a t -> ('a, unit) reagent 7 | val pop : 'a t -> (unit, 'a) reagent 8 | val try_pop : 'a t -> (unit, 'a option) reagent 9 | end 10 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs unqualified) 2 | 3 | (library 4 | (name reagents) 5 | (public_name reagents) 6 | (libraries lockfree kcas)) 7 | -------------------------------------------------------------------------------- /lib/offer.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Offer_intf.S 19 | 20 | module Make (Sched : Scheduler.S) : S = struct 21 | module Loc = Kcas.Loc 22 | 23 | type 'a status = 24 | | Empty 25 | | Waiting of unit Sched.cont 26 | | Catalyst 27 | | Rescinded 28 | | Completed of 'a 29 | 30 | type 'a t = 'a status Loc.t 31 | 32 | let make () = Loc.make Empty 33 | let get_id r = Offer_id.make (Loc.get_id r) 34 | let equal o1 o2 = Loc.get_id o1 = Loc.get_id o2 35 | 36 | let is_active o = 37 | match Loc.get o with 38 | | Empty | Waiting _ | Catalyst -> true 39 | | Rescinded | Completed _ -> false 40 | 41 | let wait r = 42 | Sched.suspend (fun k -> 43 | match 44 | Loc.update r (fun v -> 45 | match v with 46 | | Empty -> Waiting k 47 | | Waiting _ | Catalyst -> failwith "Offer.wait(1)" 48 | | Completed _ | Rescinded -> raise Exit) 49 | with 50 | (* If CAS was a success, then it is no longer this thread's responsibiliy to 51 | * resume itself. *) 52 | | _ -> None 53 | (* If the CAS failed, then another thread has already changed the offer from 54 | * [Empty] to [Completed] or [Rescinded]. In this case, thread shouldn't 55 | * wait. *) 56 | | exception Exit -> Some ()) 57 | 58 | let complete r new_v = 59 | let old_v = Loc.get r in 60 | match old_v with 61 | | Waiting k -> 62 | PostCommitCas.cas r old_v (Completed new_v) (fun () -> 63 | Sched.resume k ()) 64 | | Catalyst -> PostCommitCas.return true (fun () -> ()) 65 | | Empty -> PostCommitCas.cas r old_v (Completed new_v) (fun () -> ()) 66 | | Rescinded | Completed _ -> PostCommitCas.return false (fun () -> ()) 67 | 68 | let rescind r = 69 | (match 70 | Loc.update r (fun v -> 71 | match v with 72 | | Empty | Waiting _ -> Rescinded 73 | | Rescinded | Completed _ | Catalyst -> raise Exit) 74 | with 75 | | Waiting t -> Sched.resume t () 76 | | _ | (exception Exit) -> ()); 77 | match Loc.get r with 78 | | Rescinded | Catalyst -> None 79 | | Completed v -> Some v 80 | | _ -> failwith "Offer.rescind" 81 | 82 | let get_result r = match Loc.get r with Completed v -> Some v | _ -> None 83 | 84 | type catalyst = unit -> unit 85 | 86 | let make_catalyst () = 87 | let offer = Loc.make Catalyst in 88 | let cancel () = Loc.set offer Rescinded in 89 | (offer, cancel) 90 | 91 | let cancel_catalyst f = f () 92 | end 93 | -------------------------------------------------------------------------------- /lib/offer.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Offer_intf.S 19 | 20 | module Make (Sched : Scheduler.S) : S 21 | -------------------------------------------------------------------------------- /lib/offer_id.ml: -------------------------------------------------------------------------------- 1 | type t = int 2 | 3 | let make v = v 4 | 5 | module Set = Set.Make (struct 6 | type t = int 7 | 8 | let compare = compare 9 | end) 10 | -------------------------------------------------------------------------------- /lib/offer_id.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val make : int -> t 4 | 5 | module Set : sig 6 | include Set.S with type elt := t 7 | end 8 | -------------------------------------------------------------------------------- /lib/offer_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a t 3 | 4 | val make : unit -> 'a t 5 | val equal : 'a t -> 'b t -> bool 6 | val is_active : 'a t -> bool 7 | val get_id : 'a t -> Offer_id.t 8 | val wait : 'a t -> unit 9 | val complete : 'a t -> 'a -> PostCommitCas.t 10 | val rescind : 'a t -> 'a option 11 | val get_result : 'a t -> 'a option 12 | 13 | type catalyst 14 | 15 | val make_catalyst : unit -> 'a t * catalyst 16 | val cancel_catalyst : catalyst -> unit 17 | end 18 | -------------------------------------------------------------------------------- /lib/postCommitCas.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Loc = Kcas.Loc 18 | module Op = Kcas.Op 19 | 20 | type 'a ref = 'a Loc.t 21 | 22 | let ref x = Loc.make x 23 | let get = Loc.get 24 | 25 | type cas_kind = Real of Op.t | Imm of bool 26 | type t = cas_kind * (unit -> unit) 27 | 28 | let cas r old_v new_v post_commit = 29 | (Real (Op.make_cas r old_v new_v), post_commit) 30 | 31 | let is_on_ref (c, _) r = 32 | match c with 33 | (* | Real cas -> Kcas.is_on_ref cas r *) 34 | | Real cas -> Op.is_on_loc cas r 35 | | _ -> false 36 | 37 | let commit (cas, post_commit) = 38 | match cas with 39 | | Real cas -> if Op.atomic cas then Some post_commit else None 40 | | Imm v -> if v then Some post_commit else None 41 | 42 | let return v post_commit = (Imm v, post_commit) 43 | let ( >> ) f g x = f (g x) 44 | 45 | let kCAS lst = 46 | let cas_list, post_commit, live = 47 | List.fold_left 48 | (fun (l1, l2, live) (cas, pc) -> 49 | match cas with 50 | | Real c -> (c :: l1, pc >> l2, live) 51 | | Imm v -> (l1, pc >> l2, v && live)) 52 | ([], (fun () -> ()), true) 53 | lst 54 | in 55 | if live && Op.atomically cas_list then Some post_commit else None 56 | -------------------------------------------------------------------------------- /lib/postCommitCas.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type 'a ref = 'a Kcas.Loc.t 18 | 19 | val ref : 'a -> 'a ref 20 | val get : 'a ref -> 'a 21 | 22 | type t 23 | 24 | val return : bool -> (unit -> unit) -> t 25 | val cas : 'a ref -> 'a -> 'a -> (unit -> unit) -> t 26 | val is_on_ref : t -> 'a ref -> bool 27 | val commit : t -> (unit -> unit) option 28 | val kCAS : t list -> (unit -> unit) option 29 | -------------------------------------------------------------------------------- /lib/reaction.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Reaction_intf.S 18 | 19 | module Make (Sched : Scheduler.S) : S = struct 20 | type t = { 21 | cases : PostCommitCas.t list; 22 | offers : Offer_id.Set.t; 23 | post_commits : (unit -> unit) list; 24 | } 25 | 26 | let empty = { cases = []; offers = Offer_id.Set.empty; post_commits = [] } 27 | let has_offer { offers; _ } offer_id = Offer_id.Set.mem offer_id offers 28 | let with_CAS r cas = { r with cases = cas :: r.cases } 29 | let with_post_commit r pc = { r with post_commits = pc :: r.post_commits } 30 | 31 | let with_offer r offer_id = 32 | { r with offers = Offer_id.Set.add offer_id r.offers } 33 | 34 | let cas_count r = List.length r.cases 35 | 36 | let union r1 r2 = 37 | { 38 | cases = r1.cases @ r2.cases; 39 | offers = Offer_id.Set.union r1.offers r2.offers; 40 | post_commits = r1.post_commits @ r2.post_commits; 41 | } 42 | 43 | let try_commit r = 44 | let do_post_commit r = function 45 | | None -> false 46 | | Some pc -> 47 | pc (); 48 | List.iter (fun f -> f ()) r.post_commits; 49 | true 50 | in 51 | match r.cases with 52 | | [] -> true 53 | | [ cas ] -> do_post_commit r @@ PostCommitCas.commit cas 54 | | l -> do_post_commit r @@ PostCommitCas.kCAS l 55 | end 56 | -------------------------------------------------------------------------------- /lib/reaction.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Reaction_intf.S 18 | 19 | module Make (Sched : Scheduler.S) : S 20 | -------------------------------------------------------------------------------- /lib/reaction_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | 4 | val empty : t 5 | val with_CAS : t -> PostCommitCas.t -> t 6 | val with_offer : t -> Offer_id.t -> t 7 | val try_commit : t -> bool 8 | val cas_count : t -> int 9 | val has_offer : t -> Offer_id.t -> bool 10 | val union : t -> t -> t 11 | val with_post_commit : t -> (unit -> unit) -> t 12 | end 13 | -------------------------------------------------------------------------------- /lib/reagents.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Reagents_intf.S 18 | 19 | module Make (Sched : Scheduler.S) : S = struct 20 | module B = struct 21 | include Core.Make (Sched) 22 | module Ref = Ref.Make (Sched) 23 | module Channel = Channel.Make (Sched) 24 | end 25 | 26 | include B 27 | 28 | module Data = struct 29 | module Counter = Counter.Make (B) 30 | module Treiber_stack = Treiber_stack.Make (B) 31 | module Elimination_stack = Elimination_stack.Make (B) 32 | module MichaelScott_queue = MichaelScott_queue.Make (B) 33 | end 34 | 35 | module Sync = struct 36 | module Countdown_latch = Countdown_latch.Make (B) 37 | module Exchanger = Exchanger.Make (B) 38 | module Lock = Lock.Make (B) 39 | module Recursive_lock = Recursive_lock.Make (B) 40 | module Condition_variable = Condition_variable.Make (B) (Lock) 41 | end 42 | end 43 | 44 | module Toy_scheduler = Toy_scheduler 45 | -------------------------------------------------------------------------------- /lib/reagents.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = Reagents_intf.S 18 | 19 | module Make (Sched : Scheduler.S) : S 20 | module Toy_scheduler = Toy_scheduler 21 | -------------------------------------------------------------------------------- /lib/reagents_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | include Base.S 3 | 4 | module Data : sig 5 | module Counter : Counter.S with type ('a, 'b) reagent = ('a, 'b) t 6 | 7 | module Treiber_stack : 8 | Treiber_stack.S with type ('a, 'b) reagent = ('a, 'b) t 9 | 10 | module Elimination_stack : 11 | Elimination_stack.S with type ('a, 'b) reagent = ('a, 'b) t 12 | 13 | module MichaelScott_queue : 14 | MichaelScott_queue.S with type ('a, 'b) reagent = ('a, 'b) t 15 | end 16 | 17 | module Sync : sig 18 | module Countdown_latch : 19 | Countdown_latch.S with type ('a, 'b) reagent = ('a, 'b) t 20 | 21 | module Exchanger : Exchanger.S with type ('a, 'b) reagent = ('a, 'b) t 22 | module Lock : Lock.S with type ('a, 'b) reagent = ('a, 'b) t 23 | 24 | module Recursive_lock (Tid : sig 25 | val get_tid : unit -> int 26 | end) : Recursive_lock.S with type ('a, 'b) reagent = ('a, 'b) t 27 | 28 | module Condition_variable : 29 | Condition_variable.S 30 | with type ('a, 'b) reagent = ('a, 'b) t 31 | and type lock = Lock.t 32 | end 33 | end 34 | -------------------------------------------------------------------------------- /lib/ref.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Ref_intf.S 19 | 20 | module Make (Sched : Scheduler.S) : 21 | S with type ('a, 'b) reagent = ('a, 'b) Core.Make(Sched).t = struct 22 | module Loc = Kcas.Loc 23 | module Op = Kcas.Op 24 | module Offer = Offer.Make (Sched) 25 | module Core = Core.Make (Sched) 26 | module Reaction = Reaction.Make (Sched) 27 | 28 | type mono_offer = Offer : 'a Offer.t -> mono_offer 29 | 30 | type 'a ref = { 31 | data : 'a Loc.t; 32 | offers : mono_offer Lockfree.Michael_scott_queue.t; 33 | } 34 | 35 | type ('a, 'b) reagent = ('a, 'b) Core.t 36 | 37 | open Core 38 | 39 | let mk_ref v = 40 | { data = Loc.make v; offers = Lockfree.Michael_scott_queue.create () } 41 | 42 | let rec read : 'a 'r. 'a ref -> ('a, 'r) reagent -> (unit, 'r) reagent = 43 | fun r k -> 44 | let try_react () reaction offer = 45 | let () = 46 | match offer with 47 | | None -> () 48 | | Some offer -> Lockfree.Michael_scott_queue.push r.offers (Offer offer) 49 | in 50 | let v = Loc.get r.data in 51 | k.try_react v reaction offer 52 | in 53 | { 54 | always_commits = k.always_commits; 55 | compose = (fun next -> read r (k.compose next)); 56 | try_react; 57 | } 58 | 59 | let read r = read r Core.commit 60 | let read_imm r = Loc.get r.data 61 | 62 | let wake_all q = 63 | let rec drain_offers offers = 64 | match Lockfree.Michael_scott_queue.pop q with 65 | | None -> offers 66 | | Some offer -> drain_offers (offer :: offers) 67 | in 68 | let offers = drain_offers [] in 69 | List.iter 70 | (fun (Offer offer) -> ignore (Option.is_none (Offer.rescind offer))) 71 | offers 72 | 73 | let cas_imm r expect update = Loc.compare_and_set r.data expect update 74 | 75 | let rec upd : 76 | 'a 'b 'c 'r. 77 | never_block:bool -> 78 | 'a ref -> 79 | ('a -> 'b -> ('a * 'c) option) -> 80 | ('c, 'r) reagent -> 81 | ('b, 'r) reagent = 82 | fun ~never_block ref f next_reagent -> 83 | let on_failure = if never_block then Core.Retry else Core.Block in 84 | let try_react arg reaction offer = 85 | if can_cas_immediate next_reagent reaction offer then 86 | let old_value = Loc.get ref.data in 87 | match f old_value arg with 88 | | None -> on_failure 89 | | Some (new_value, c) -> 90 | if cas_imm ref old_value new_value then ( 91 | wake_all ref.offers; 92 | next_reagent.try_react c reaction offer) 93 | else Retry 94 | else 95 | let () = 96 | match offer with 97 | | None -> () 98 | | Some offer -> 99 | Lockfree.Michael_scott_queue.push ref.offers (Offer offer) 100 | in 101 | let old_value = Loc.get ref.data in 102 | match f old_value arg with 103 | | None -> on_failure 104 | | Some (new_value, return_value) -> 105 | let cas = 106 | PostCommitCas.cas ref.data old_value new_value (fun () -> 107 | wake_all ref.offers) 108 | in 109 | next_reagent.try_react return_value 110 | (Reaction.with_CAS reaction cas) 111 | offer 112 | in 113 | { 114 | always_commits = false; 115 | compose = (fun next -> upd ~never_block ref f (next_reagent.compose next)); 116 | try_react; 117 | } 118 | 119 | let upd ?(never_block = false) r f = upd ~never_block r f Core.commit 120 | 121 | let cas ?(never_block = false) r expect update = 122 | upd ~never_block r (fun current () -> 123 | if current == expect then Some (update, ()) else None) 124 | end 125 | -------------------------------------------------------------------------------- /lib/ref.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Ref_intf.S 19 | 20 | module Make (Sched : Scheduler.S) : 21 | S with type ('a, 'b) reagent = ('a, 'b) Core.Make(Sched).t 22 | -------------------------------------------------------------------------------- /lib/ref_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a ref 3 | (** The type of shared memory reference. *) 4 | 5 | type ('a, 'b) reagent 6 | (** The type of reagent. *) 7 | 8 | val mk_ref : 'a -> 'a ref 9 | (** Make a new reference. *) 10 | 11 | val read : 'a ref -> (unit, 'a) reagent 12 | (** [read r] returns a reagent, which when run returns the value of the reference. *) 13 | 14 | val read_imm : 'a ref -> 'a 15 | (** [read_imm r] immediately returns the value of the reference. *) 16 | 17 | val cas : ?never_block:bool -> 'a ref -> 'a -> 'a -> (unit, unit) reagent 18 | (** [cas r e u] returns a reagent, which when run attempts to update the 19 | reference to [u] if the reference has value [e]. Otherwise, the protocol 20 | is retried until success. The retry is efficient and does not actively 21 | consume CPU. The fiber is suspended until there is a possibility of 22 | success. 23 | 24 | [never_block] is a safety hatch that lets us force failures to be retried. 25 | It should be never needed when using the [Ref] directly, but might be 26 | useful to re-use [Ref] while implementing another reagent. In such a case, a 27 | failure that looks permanent at the level of [Ref] can in fact be transient. 28 | 29 | For example, failure to [push] in Michael-Scott queue is never permanent, 30 | instead cas has to be retried on further node. 31 | 32 | *) 33 | 34 | val cas_imm : 'a ref -> 'a -> 'a -> bool 35 | (** [cas_imm r e u] attempts to atomically update [r] from [e] to [u]. If 36 | successful, the function returns [true]. Otherwise, returns [false]. *) 37 | 38 | val upd : 39 | ?never_block:bool -> 40 | 'a ref -> 41 | ('a -> 'b -> ('a * 'c) option) -> 42 | ('b, 'c) reagent 43 | (** [upd r f] returns a reagent value which when run applies [f] to the 44 | current value [c] of the reference and the input value of the reagent. If 45 | [f] returns, [None] the protocol is retried. If [f] returns [Some v], the 46 | reference is attempted to atomically update from [c] to [v]. If the 47 | update, fails the protocol is retried. 48 | 49 | The retry is efficient and does not actively consume CPU. The fiber is 50 | suspended until there is a possibility of success. *) 51 | end 52 | -------------------------------------------------------------------------------- /lib/scheduler.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Scheduler_intf.S 19 | -------------------------------------------------------------------------------- /lib/scheduler.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module type S = Scheduler_intf.S 19 | -------------------------------------------------------------------------------- /lib/scheduler_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a cont 3 | (** The type of continuation. *) 4 | 5 | val suspend : ('a cont -> 'a option) -> 'a 6 | (** [suspend f] applies [f] to the current continuation. If [f] returns 7 | [Some v], then the function returns [v] immediately. Otherwise, if [f] 8 | returns [None], then the current fiber is suspended and the control 9 | switches to the next fiber from the scheduler. *) 10 | 11 | val resume : 'a cont -> 'a -> unit 12 | (** [resume k v] prepares to resume the continuation [k] with value [v] and 13 | enqueues the continuation to the scheduler queue. *) 14 | 15 | val get_tid : unit -> int 16 | (** Return the current thread id. *) 17 | end 18 | -------------------------------------------------------------------------------- /lib/sync/condition_variable.ml: -------------------------------------------------------------------------------- 1 | module type S = Condition_variable_intf.S 2 | 3 | module Make 4 | (Base : Base.S) 5 | (Lock : Lock.S with type ('a, 'b) reagent = ('a, 'b) Base.t) : 6 | S with type ('a, 'b) reagent = ('a, 'b) Base.t and type lock = Lock.t = struct 7 | type ('a, 'b) reagent = ('a, 'b) Base.t 8 | 9 | open Base 10 | module Q = MichaelScott_queue.Make (Base) 11 | module X = Exchanger.Make (Base) 12 | 13 | type lock = Lock.t 14 | type t = unit X.t Q.t 15 | 16 | let create () = Q.create () 17 | 18 | let wait l cv = 19 | let x = X.create () in 20 | run (constant x >>> Q.push cv) (); 21 | if run (Lock.rel l) () then ( 22 | (* Successfully released lock. Wait for signal.. *) 23 | run (X.exchange x) (); 24 | run (Lock.acq l) (); 25 | true) 26 | else (* Error! Lock not owned. TODO: Remove/satisfy x.*) 27 | false 28 | 29 | let signal_bool cv = 30 | let xo = run (Q.try_pop cv) () in 31 | match xo with 32 | | None -> false 33 | | Some x -> 34 | run (X.exchange x) (); 35 | true 36 | 37 | let signal cv = ignore (signal_bool cv) 38 | let rec broadcast cv = if signal_bool cv then broadcast cv else () 39 | end 40 | -------------------------------------------------------------------------------- /lib/sync/condition_variable.mli: -------------------------------------------------------------------------------- 1 | module type S = Condition_variable_intf.S 2 | 3 | module Make 4 | (Base : Base.S) 5 | (Lock : Lock.S with type ('a, 'b) reagent = ('a, 'b) Base.t) : 6 | S with type ('a, 'b) reagent = ('a, 'b) Base.t and type lock = Lock.t 7 | -------------------------------------------------------------------------------- /lib/sync/condition_variable_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type ('a, 'b) reagent 3 | type lock 4 | type t 5 | 6 | val create : unit -> t 7 | 8 | val wait : lock -> t -> bool 9 | (** [wait l c] returns [false] if the lock is not currently held. *) 10 | 11 | val signal : t -> unit 12 | val broadcast : t -> unit 13 | end 14 | -------------------------------------------------------------------------------- /lib/sync/countdown_latch.ml: -------------------------------------------------------------------------------- 1 | module type S = Countdown_latch_intf.S 2 | 3 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t = 4 | struct 5 | type ('a, 'b) reagent = ('a, 'b) Base.t 6 | 7 | module C = Counter.Make (Base) 8 | open Base 9 | 10 | type t = C.t 11 | 12 | let create = C.create 13 | let get_count = C.get 14 | let count_down c = C.try_dec c >>= fun _ -> constant () 15 | 16 | let await c = 17 | C.get c >>> lift_blocking (fun v -> if v = 0 then Some () else None) 18 | end 19 | -------------------------------------------------------------------------------- /lib/sync/countdown_latch.mli: -------------------------------------------------------------------------------- 1 | module type S = Countdown_latch_intf.S 2 | 3 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t 4 | -------------------------------------------------------------------------------- /lib/sync/countdown_latch_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | type ('a, 'b) reagent 4 | 5 | val create : int -> t 6 | val get_count : t -> (unit, int) reagent 7 | val await : t -> (unit, unit) reagent 8 | val count_down : t -> (unit, unit) reagent 9 | end 10 | -------------------------------------------------------------------------------- /lib/sync/lock.ml: -------------------------------------------------------------------------------- 1 | module type S = Lock_intf.S 2 | 3 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t = 4 | struct 5 | type ('a, 'b) reagent = ('a, 'b) Base.t 6 | 7 | open Base 8 | 9 | type status = Locked | Unlocked 10 | type t = status Ref.ref 11 | 12 | let create () = Ref.mk_ref Unlocked 13 | 14 | let acq r = 15 | Ref.upd r (fun s () -> 16 | match s with Unlocked -> Some (Locked, ()) | Locked -> None) 17 | 18 | let rel r = 19 | Ref.upd r (fun s () -> 20 | match s with 21 | | Locked -> Some (Unlocked, true) 22 | | Unlocked -> Some (Unlocked, false)) 23 | 24 | let try_acq r = 25 | Ref.upd r (fun s () -> 26 | match s with 27 | | Unlocked -> Some (Locked, true) 28 | | Locked -> Some (Locked, false)) 29 | end 30 | -------------------------------------------------------------------------------- /lib/sync/lock.mli: -------------------------------------------------------------------------------- 1 | module type S = Lock_intf.S 2 | 3 | module Make (Base : Base.S) : S with type ('a, 'b) reagent = ('a, 'b) Base.t 4 | -------------------------------------------------------------------------------- /lib/sync/lock_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type ('a, 'b) reagent 3 | type t 4 | 5 | val create : unit -> t 6 | val acq : t -> (unit, unit) reagent 7 | val try_acq : t -> (unit, bool) reagent 8 | 9 | val rel : t -> (unit, bool) reagent 10 | (** [run (rel l) ()] returns [false] if the lock is not currently held. *) 11 | end 12 | -------------------------------------------------------------------------------- /lib/sync/recursive_lock.ml: -------------------------------------------------------------------------------- 1 | module type S = Recursive_lock_intf.S 2 | 3 | module Make 4 | (Base : Base.S) (Tid : sig 5 | val get_tid : unit -> int 6 | end) : S with type ('a, 'b) reagent = ('a, 'b) Base.t = struct 7 | type ('a, 'b) reagent = ('a, 'b) Base.t 8 | 9 | open Base 10 | 11 | type thread_id = int 12 | type count = int 13 | 14 | (** A recursive lock is either recursively locked [count] times by [thread_id] or unlocked *) 15 | type status = Locked of thread_id * count | Unlocked 16 | 17 | type t = status Ref.ref 18 | 19 | let create () = Ref.mk_ref Unlocked 20 | 21 | let acq r = 22 | Ref.upd r (fun s () -> 23 | let tid = Tid.get_tid () in 24 | match s with 25 | | Unlocked -> 26 | (* No current owner, take the lock *) 27 | Some (Locked (tid, 1), ()) 28 | | Locked (owner, count) -> 29 | if owner = tid then Some (Locked (tid, count + 1), ()) else None) 30 | 31 | let rel r = 32 | Ref.upd r (fun s () -> 33 | let tid = Tid.get_tid () in 34 | match s with 35 | | Unlocked -> Some (Unlocked, false) 36 | | Locked (owner, count) -> 37 | if owner = tid then 38 | let new_count = count - 1 in 39 | if new_count = 0 then Some (Unlocked, true) 40 | else Some (Locked (tid, new_count), true) 41 | else Some (Locked (owner, count), false)) 42 | 43 | let try_acq r = 44 | Ref.upd r (fun s () -> 45 | let tid = Tid.get_tid () in 46 | match s with 47 | | Unlocked -> Some (Locked (tid, 1), true) 48 | | Locked (owner, count) -> 49 | if owner = tid then 50 | (* Already the owner, increase lock count *) 51 | Some (Locked (tid, count + 1), true) 52 | else 53 | (* Not the owner, don't wait on lock *) 54 | Some (Locked (owner, count), false)) 55 | end 56 | -------------------------------------------------------------------------------- /lib/sync/recursive_lock.mli: -------------------------------------------------------------------------------- 1 | module type S = Recursive_lock_intf.S 2 | 3 | module Make 4 | (Base : Base.S) (Tid : sig 5 | val get_tid : unit -> int 6 | end) : S with type ('a, 'b) reagent = ('a, 'b) Base.t 7 | -------------------------------------------------------------------------------- /lib/sync/recursive_lock_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type ('a, 'b) reagent 3 | type t 4 | 5 | val create : unit -> t 6 | val acq : t -> (unit, unit) reagent 7 | 8 | val try_acq : t -> (unit, bool) reagent 9 | (** [run (try_acq l) ()] returns [true] if the lock was successful *) 10 | 11 | val rel : t -> (unit, bool) reagent 12 | (** [run (rel l) ()] returns [false] if the lock is either not held or held by another thread *) 13 | end 14 | -------------------------------------------------------------------------------- /lib/toy_scheduler.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | exception All_domains_idle 18 | 19 | module Make (S : sig 20 | val num_domains : int 21 | 22 | val raise_if_all_idle : bool 23 | (** [raise_if_all_idle] may throw spuriously with multiple domains. *) 24 | end) : Toy_scheduler_intf.S = struct 25 | open Effect 26 | open Effect.Deep 27 | 28 | type 'a cont = ('a, unit) continuation 29 | type _ Effect.t += Suspend : ('a cont -> 'a option) -> 'a Effect.t 30 | type _ Effect.t += Resume : ('a cont * 'a) -> unit Effect.t 31 | type _ Effect.t += Fork : (unit -> unit) -> unit Effect.t 32 | type _ Effect.t += Yield : unit Effect.t 33 | type _ Effect.t += GetTid : int Effect.t 34 | 35 | exception All_domains_idle 36 | 37 | let suspend f = perform (Suspend f) 38 | let resume t v = perform (Resume (t, v)) 39 | let fork f = perform (Fork f) 40 | let yield () = perform Yield 41 | let get_tid () = perform GetTid 42 | 43 | type t = { 44 | num_threads : int Atomic.t; 45 | num_idling_domains : int Atomic.t; 46 | mutable domain_ids : Domain.id list; 47 | queues : 48 | (Domain.id, (unit -> unit) Lockfree.Michael_scott_queue.t) Hashtbl.t; 49 | current_tid : int Atomic.t; 50 | } 51 | 52 | let fresh_tid t = Atomic.fetch_and_add t.current_tid 1 53 | 54 | let enqueue t (task : unit -> unit) = 55 | let queue = Hashtbl.find t.queues (Domain.self ()) in 56 | Lockfree.Michael_scott_queue.push queue task 57 | 58 | let take_one t (source : [ `Own | `Any ]) = 59 | let domain_id = 60 | match source with 61 | | `Own -> Domain.self () 62 | | `Any -> 63 | let k = Random.int (List.length t.domain_ids) in 64 | List.nth t.domain_ids k 65 | in 66 | let queue = Hashtbl.find t.queues domain_id in 67 | Lockfree.Michael_scott_queue.pop queue 68 | 69 | let dequeue t = 70 | let rec loop ~idling = 71 | match take_one t (if idling then `Any else `Own) with 72 | | Some k -> 73 | if idling then Atomic.decr t.num_idling_domains; 74 | k () 75 | | None -> 76 | if 77 | S.raise_if_all_idle 78 | && S.num_domains == Atomic.get t.num_idling_domains 79 | then raise All_domains_idle; 80 | 81 | if Atomic.get t.num_threads == 0 then () 82 | else ( 83 | if not idling then Atomic.incr t.num_idling_domains; 84 | loop ~idling:true) 85 | in 86 | loop ~idling:false 87 | 88 | let rec spawn (t : t) f = 89 | let tid = fresh_tid t in 90 | Atomic.incr t.num_threads; 91 | (* begin *) 92 | match_with f () 93 | { 94 | retc = 95 | (fun () -> 96 | Atomic.decr t.num_threads; 97 | dequeue t); 98 | exnc = 99 | (fun e -> 100 | Printf.eprintf "uncaught exn: %s%!" (Printexc.to_string e); 101 | Stdlib.exit 1); 102 | effc = 103 | (fun (type a) (e : a Effect.t) -> 104 | match e with 105 | | Suspend f -> 106 | Some 107 | (fun (k : (a, _) continuation) -> 108 | match f k with None -> dequeue t | Some v -> continue k v) 109 | | Resume (l, v) -> 110 | Some 111 | (fun (k : (a, _) continuation) -> 112 | enqueue t (continue k); 113 | continue l v) 114 | | Fork f -> 115 | Some 116 | (fun (k : (unit, unit) continuation) -> 117 | enqueue t (continue k); 118 | spawn t f) 119 | | Yield -> 120 | Some 121 | (fun (k : (a, _) continuation) -> 122 | enqueue t (continue k); 123 | dequeue t) 124 | | GetTid -> Some (fun (k : (a, _) continuation) -> continue k tid) 125 | | _ -> None (* forward the unhandled effects to the outer handler *)); 126 | } 127 | 128 | let run f = 129 | let t = 130 | { 131 | num_threads = Atomic.make 0; 132 | num_idling_domains = Atomic.make 0; 133 | domain_ids = []; 134 | queues = Hashtbl.create 32; 135 | current_tid = Atomic.make 0; 136 | } 137 | in 138 | 139 | let started = Atomic.make false in 140 | let worker () = 141 | let rec loop () = if Atomic.get started then dequeue t else loop () in 142 | loop () 143 | in 144 | let domains = 145 | let spawned = 146 | List.init (S.num_domains - 1) (fun _ -> Domain.spawn worker) 147 | |> List.map Domain.get_id 148 | in 149 | Domain.self () :: spawned 150 | in 151 | List.iter 152 | (fun domain_id -> 153 | Hashtbl.add t.queues domain_id (Lockfree.Michael_scott_queue.create ())) 154 | domains; 155 | t.domain_ids <- domains; 156 | 157 | spawn t (fun () -> 158 | Atomic.set started true; 159 | f ()) 160 | 161 | let run_allow_deadlock f = 162 | match run f with exception All_domains_idle -> () | _ -> () 163 | end 164 | 165 | let make ?(raise_if_all_idle = false) num_domains () = 166 | let module M = Make (struct 167 | let num_domains = num_domains 168 | let raise_if_all_idle = raise_if_all_idle 169 | end) in 170 | (module M : Toy_scheduler_intf.S) 171 | -------------------------------------------------------------------------------- /lib/toy_scheduler.mli: -------------------------------------------------------------------------------- 1 | (** Toy scheduler to run tests and have something working in utop. 2 | Do not use in actual applications. 3 | *) 4 | 5 | exception All_domains_idle 6 | 7 | val make : 8 | ?raise_if_all_idle:bool -> int -> unit -> (module Toy_scheduler_intf.S) 9 | (** [make k ()] instantiates a scheduler with k domains in the pool. 10 | 11 | [raise_if_all_idle] controls whether the scheduler is going to raise 12 | [All_domains_idle] when it runs out of tasks, while the initial task 13 | is suspended. It may raise spuriously in multi-domain setting, thus 14 | it is turned off by default. 15 | *) 16 | -------------------------------------------------------------------------------- /lib/toy_scheduler_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a cont 3 | 4 | val suspend : ('a cont -> 'a option) -> 'a 5 | val resume : 'a cont -> 'a -> unit 6 | val fork : (unit -> unit) -> unit 7 | val yield : unit -> unit 8 | val get_tid : unit -> int 9 | val run : (unit -> unit) -> unit 10 | 11 | (* wrapper for tests that are expected to block (be it desirable or not) *) 12 | val run_allow_deadlock : (unit -> unit) -> unit 13 | end 14 | -------------------------------------------------------------------------------- /reagents.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Composable lock-free data and synchronization structures" 4 | description: 5 | "Reagents - Composable lock-free data and synchronization structures" 6 | maintainer: ["KC Sivaramakrishnan "] 7 | authors: ["KC Sivaramakrishnan "] 8 | license: "BSD-3-clause" 9 | homepage: "https://github.com/ocaml-multicore/reagents" 10 | doc: "https://ocaml-multicore.github.io/reagents/" 11 | bug-reports: "https://github.com/ocaml-multicore/reagents/issues" 12 | depends: [ 13 | "dune" {>= "3.0"} 14 | "ocaml" {>= "5.0"} 15 | "lockfree" {>= "0.3.0"} 16 | "kcas" {>= "0.2.0"} 17 | "alcotest" {with-test & >= "1.6.0"} 18 | "kcas_data" {with-test & >= "0.2.3"} 19 | "odoc" {with-doc} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {dev} 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/ocaml-multicore/reagents.git" 36 | -------------------------------------------------------------------------------- /tests/catalyst_test.ml: -------------------------------------------------------------------------------- 1 | module Scheduler = (val Reagents.Toy_scheduler.make 1 ()) 2 | module Reagents = Reagents.Make (Scheduler) 3 | module Counter = Reagents.Data.Counter 4 | open Reagents 5 | 6 | let message_counter () = 7 | Scheduler.run (fun () -> 8 | let receiver_counter = Atomic.make 0 in 9 | let assert_counter v = assert (Atomic.get receiver_counter == v) in 10 | 11 | let (c1 : (unit, unit) Channel.endpoint), c2 = Channel.mk_chan () in 12 | 13 | let receiver = 14 | let open Reagents in 15 | Channel.swap c2 >>> lift (fun () -> Atomic.incr receiver_counter) 16 | in 17 | Reagents.Catalyst.catalyse receiver () |> ignore; 18 | 19 | assert_counter 0; 20 | Reagents.run (Channel.swap c1) (); 21 | assert_counter 1; 22 | Reagents.run (Channel.swap c1) (); 23 | assert_counter 2) 24 | 25 | let three_channels_joined () = 26 | Scheduler.run (fun () -> 27 | let transferred = Atomic.make 0 in 28 | 29 | let (a1 : (int, unit) Channel.endpoint), a2 = Channel.mk_chan () in 30 | let (b1 : (int, unit) Channel.endpoint), b2 = Channel.mk_chan () in 31 | let (c1 : (int, unit) Channel.endpoint), c2 = Channel.mk_chan () in 32 | 33 | let forward receive send = 34 | let open Reagents in 35 | Channel.swap receive >>> Channel.swap send 36 | in 37 | Reagents.Catalyst.catalyse (forward a2 b1) () |> ignore; 38 | Reagents.Catalyst.catalyse (forward b2 c1) () |> ignore; 39 | 40 | Scheduler.fork (fun () -> 41 | let v = Reagents.run (Channel.swap c2) () in 42 | Atomic.set transferred v); 43 | 44 | Reagents.run (Channel.swap a1) 1; 45 | 46 | while Atomic.get transferred == 0 do 47 | () (* not necessary with 1 thr *) 48 | done; 49 | assert (Atomic.get transferred == 1); 50 | ()) 51 | 52 | let message_counter_stress () = 53 | Scheduler.run (fun () -> 54 | let receiver_counter = Atomic.make 0 in 55 | let assert_counter v = assert (Atomic.get receiver_counter == v) in 56 | 57 | let (c1 : (unit, unit) Channel.endpoint), c2 = Channel.mk_chan () in 58 | 59 | let receiver = 60 | let open Reagents in 61 | Channel.swap c2 >>> lift (fun () -> Atomic.incr receiver_counter) 62 | in 63 | Reagents.Catalyst.catalyse receiver () |> ignore; 64 | 65 | let count = 1_000_000 in 66 | for _ = 1 to count do 67 | Reagents.run (Channel.swap c1) (Sys.opaque_identity ()) 68 | done; 69 | assert_counter count) 70 | 71 | let () = 72 | let open Alcotest in 73 | run "catalyst test" 74 | [ 75 | ( "simple", 76 | [ 77 | test_case "message counter" `Quick message_counter; 78 | test_case "three channels joined" `Quick three_channels_joined; 79 | test_case "message counter, 10^6 items" `Quick message_counter_stress; 80 | ] ); 81 | ] 82 | -------------------------------------------------------------------------------- /tests/counter_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Scheduler = 18 | (val Reagents.Toy_scheduler.make ~raise_if_all_idle:true 1 ()) 19 | 20 | module Reagents = Reagents.Make (Scheduler) 21 | open Reagents 22 | module Counter = Data.Counter 23 | 24 | let counter () = 25 | Scheduler.run (fun () -> 26 | let c = Counter.create 0 in 27 | assert (run (Counter.get c) () == 0); 28 | assert (run (Counter.inc c) () == 0); 29 | assert (run (Counter.inc c) () == 1); 30 | assert (run (Counter.dec c) () == 2); 31 | assert (run (Counter.get c) () == 1)) 32 | 33 | let counter_await_value () = 34 | Scheduler.run_allow_deadlock (fun () -> 35 | let c = Counter.create 0 in 36 | assert (run (Counter.inc c) () == 0); 37 | run 38 | ( Counter.try_dec c >>= fun ov -> 39 | match ov with 40 | | Some 1 -> 41 | Printf.printf 42 | "Counter is 0. Further decrement blocks the thread!\n%!"; 43 | constant () 44 | | _ -> failwith "impossible" ) 45 | (); 46 | run (Counter.dec c) () |> ignore; 47 | ()) 48 | 49 | let () = 50 | let open Alcotest in 51 | run "counter test" 52 | [ 53 | ( "simple", 54 | [ 55 | test_case "get, inc, dec" `Quick counter; 56 | test_case "blocking" `Quick counter_await_value; 57 | ] ); 58 | ] 59 | -------------------------------------------------------------------------------- /tests/dining_philosophers.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Theoéo Laurent 3 | * Copyright (c) 2015-2016, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | let num_philosophers = 3 19 | let num_rounds = 10_000 20 | 21 | module S = (val Reagents.Toy_scheduler.make 3 ()) 22 | module Reagents = Reagents.Make (S) 23 | open Reagents 24 | open Channel 25 | module Sync = Reagents.Sync 26 | module CDL = Sync.Countdown_latch 27 | 28 | type fork = { drop : (unit, unit) endpoint; take : (unit, unit) endpoint } 29 | 30 | let mk_fork () = 31 | let drop, take = mk_chan () in 32 | { drop; take } 33 | 34 | let drop f = swap f.drop 35 | let take f = swap f.take 36 | 37 | let eat l_fork r_fork _i _j = 38 | ignore @@ run (take l_fork <*> take r_fork) (); 39 | (* Printf.printf "Philosopher %d eating in round %d\n%!" i j; *) 40 | S.fork @@ run (drop l_fork); 41 | S.fork @@ run (drop r_fork) 42 | 43 | let main () = 44 | let b = CDL.create num_philosophers in 45 | let forks = Array.init num_philosophers (fun _ -> mk_fork ()) in 46 | Array.iter (fun fork -> S.fork @@ run (drop fork)) forks; 47 | 48 | let work i () = 49 | let l_fork = forks.(i) in 50 | let r_fork = forks.((i + 1) mod num_philosophers) in 51 | for j = 1 to num_rounds do 52 | eat l_fork r_fork i j 53 | done; 54 | run (CDL.count_down b) () 55 | in 56 | 57 | for i = 1 to num_philosophers - 1 do 58 | S.fork (work i) 59 | done; 60 | work 0 (); 61 | run (CDL.await b) (); 62 | exit 0 63 | 64 | let () = S.run main 65 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name counter_test) 3 | (modules counter_test) 4 | (libraries reagents alcotest)) 5 | 6 | (test 7 | (name dining_philosophers) 8 | (modules dining_philosophers) 9 | (libraries reagents)) 10 | 11 | (test 12 | (name eli_stack) 13 | (modules eli_stack) 14 | (libraries reagents)) 15 | 16 | (test 17 | (name lock_test) 18 | (modules lock_test) 19 | (libraries reagents alcotest)) 20 | 21 | (test 22 | (name ref_channel) 23 | (modules ref_channel) 24 | (libraries reagents alcotest)) 25 | 26 | (test 27 | (name ref_test) 28 | (modules ref_test) 29 | (libraries reagents alcotest)) 30 | 31 | (test 32 | (name queue_test) 33 | (modules queue_test) 34 | (libraries reagents references kcas_data)) 35 | 36 | (test 37 | (name reagent_queue_test) 38 | (modules reagent_queue_test) 39 | (libraries reagents)) 40 | 41 | (test 42 | (name sat) 43 | (modules sat) 44 | (libraries reagents alcotest)) 45 | 46 | (test 47 | (name rec_test) 48 | (modules rec_test) 49 | (libraries reagents alcotest)) 50 | 51 | (test 52 | (name stack_test) 53 | (modules stack_test) 54 | (libraries reagents references)) 55 | 56 | (test 57 | (name stack_test_compose) 58 | (modules stack_test_compose) 59 | (libraries reagents)) 60 | 61 | (test 62 | (name swap_test) 63 | (modules swap_test) 64 | (libraries reagents alcotest)) 65 | 66 | (test 67 | (name hw_queue) 68 | (modules hw_queue) 69 | (libraries reagents)) 70 | 71 | (test 72 | (name catalyst_test) 73 | (modules catalyst_test) 74 | (libraries reagents alcotest)) 75 | 76 | (test 77 | (name pair_not_parallel) 78 | (modules pair_not_parallel) 79 | (libraries reagents alcotest)) 80 | -------------------------------------------------------------------------------- /tests/eli_stack.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let num_doms = 4 18 | let num_items = 1_000_000 19 | let items_per_dom = num_items / num_doms 20 | let () = Printf.printf "items_per_domain = %d\n%!" items_per_dom 21 | 22 | module S = (val Reagents.Toy_scheduler.make num_doms ()) 23 | module Reagents = Reagents.Make (S) 24 | open Reagents 25 | 26 | module type STACK = sig 27 | type 'a t 28 | 29 | val create : unit -> 'a t 30 | val push : 'a t -> 'a -> unit 31 | val pop : 'a t -> 'a option 32 | end 33 | 34 | module type RSTACK = sig 35 | type 'a t 36 | 37 | val create : unit -> 'a t 38 | val push : 'a t -> ('a, unit) Reagents.t 39 | val try_pop : 'a t -> (unit, 'a option) Reagents.t 40 | end 41 | 42 | module MakeS (RQ : RSTACK) : STACK = struct 43 | type 'a t = 'a RQ.t 44 | 45 | let create = RQ.create 46 | let push q v = Reagents.run (RQ.push q) v 47 | let pop q = Reagents.run (RQ.try_pop q) () 48 | end 49 | 50 | module Benchmark = struct 51 | let get_mean_sd l = 52 | let get_mean l = 53 | List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) 54 | in 55 | let mean = get_mean l in 56 | let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in 57 | (mean, sd) 58 | 59 | let benchmark f n = 60 | let rec run acc = function 61 | | 0 -> acc 62 | | n -> 63 | let t1 = Unix.gettimeofday () in 64 | let () = f () in 65 | let d = Unix.gettimeofday () -. t1 in 66 | run (d :: acc) (n - 1) 67 | in 68 | let r = run [] n in 69 | get_mean_sd r 70 | end 71 | 72 | module Sync = Reagents.Sync 73 | module CDL = Sync.Countdown_latch 74 | 75 | module Test (Q : STACK) = struct 76 | let run num_doms items_per_domain = 77 | let q : int Q.t = Q.create () in 78 | let b = CDL.create num_doms in 79 | (* initialize work *) 80 | let rec produce = function 81 | | 0 -> () 82 | (* printf "production complete\n%!" *) 83 | | i -> 84 | Q.push q i; 85 | produce (i - 1) 86 | in 87 | let rec consume i = 88 | match Q.pop q with 89 | | None -> () 90 | (* printf "consumed=%d\n%!" i *) 91 | | Some _ -> consume (i + 1) 92 | in 93 | for _ = 1 to num_doms - 1 do 94 | S.fork (fun () -> 95 | produce items_per_domain; 96 | consume 0; 97 | run (CDL.count_down b) ()) 98 | done; 99 | produce items_per_domain; 100 | consume 0; 101 | run (CDL.count_down b) (); 102 | run (CDL.await b) () 103 | end 104 | 105 | module Data = Reagents.Data 106 | 107 | let main () = 108 | let module M = Test (MakeS (Data.Elimination_stack)) in 109 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 10 in 110 | Printf.printf "Elimination stack: mean = %f, sd = %f tp=%f\n%!" m sd 111 | (float_of_int num_items /. m) 112 | 113 | let () = S.run main 114 | -------------------------------------------------------------------------------- /tests/hw_queue.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let num_doms = 4 18 | let num_items = 1_000_000 19 | let items_per_dom = num_items / num_doms 20 | 21 | module S = (val Reagents.Toy_scheduler.make num_doms ()) 22 | module Reagents = Reagents.Make (S) 23 | open Reagents 24 | 25 | module type QUEUE = sig 26 | type 'a t 27 | 28 | val create : unit -> 'a t 29 | val push : 'a t -> 'a -> unit 30 | val pop : 'a t -> 'a option 31 | end 32 | 33 | module type RQUEUE = sig 34 | type 'a t 35 | 36 | val create : unit -> 'a t 37 | val push : 'a t -> ('a, unit) Reagents.t 38 | val try_pop : 'a t -> (unit, 'a option) Reagents.t 39 | end 40 | 41 | module MakeQ (RQ : RQUEUE) : QUEUE = struct 42 | type 'a t = 'a RQ.t 43 | 44 | let create = RQ.create 45 | let push q v = Reagents.run (RQ.push q) v 46 | let pop q = Reagents.run (RQ.try_pop q) () 47 | end 48 | 49 | module Benchmark = struct 50 | let get_mean_sd l = 51 | let get_mean l = 52 | List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) 53 | in 54 | let mean = get_mean l in 55 | let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in 56 | (mean, sd) 57 | 58 | let benchmark f n = 59 | let rec run acc = function 60 | | 0 -> acc 61 | | n -> 62 | let t1 = Unix.gettimeofday () in 63 | let () = f () in 64 | let d = Unix.gettimeofday () -. t1 in 65 | run (d :: acc) (n - 1) 66 | in 67 | let r = run [] n in 68 | get_mean_sd r 69 | end 70 | 71 | module CDL = Sync.Countdown_latch 72 | 73 | module Test (Q : QUEUE) = struct 74 | let run num_doms items_per_domain = 75 | let q : int Q.t = Q.create () in 76 | let b = CDL.create num_doms in 77 | (* initialize work *) 78 | let rec produce = function 79 | | 0 -> () 80 | | i -> 81 | Q.push q i; 82 | produce (i - 1) 83 | in 84 | let rec consume i = 85 | match Q.pop q with 86 | | None -> () 87 | (* printf "consumed=%d\n%!" i *) 88 | | Some _ -> consume (i + 1) 89 | in 90 | for _ = 1 to num_doms - 1 do 91 | S.fork (fun () -> 92 | produce items_per_domain; 93 | consume 0; 94 | run (CDL.count_down b) ()) 95 | done; 96 | produce items_per_domain; 97 | consume 0; 98 | run (CDL.count_down b) (); 99 | run (CDL.await b) () 100 | end 101 | 102 | let main () = 103 | let module M = Test (Lockfree.Michael_scott_queue) in 104 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 105 | Printf.printf "Hand-written Lockfree.MSQueue: mean = %f, sd = %f tp=%f\n%!" m 106 | sd 107 | (float_of_int num_items /. m) 108 | 109 | let () = S.run main 110 | -------------------------------------------------------------------------------- /tests/lock_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Scheduler = (val Reagents.Toy_scheduler.make 1 ()) 18 | module Reagents = Reagents.Make (Scheduler) 19 | open Reagents 20 | module Lock = Sync.Lock 21 | module CV = Sync.Condition_variable 22 | 23 | let test () = 24 | Scheduler.run (fun () -> 25 | let l = Lock.create () in 26 | let cv = CV.create () in 27 | run (Lock.acq l) (); 28 | Scheduler.fork (fun () -> 29 | run (Lock.acq l) (); 30 | CV.signal cv; 31 | assert (run (Lock.rel l) ())); 32 | assert (CV.wait l cv); 33 | assert (run (Lock.rel l) ())) 34 | 35 | let () = 36 | let open Alcotest in 37 | run "lock test" [ ("simple", [ test_case "lock and cond-var" `Quick test ]) ] 38 | -------------------------------------------------------------------------------- /tests/pair_not_parallel.ml: -------------------------------------------------------------------------------- 1 | module Scheduler = 2 | (val Reagents.Toy_scheduler.make ~raise_if_all_idle:true 1 ()) 3 | 4 | module Reagents = Reagents.Make (Scheduler) 5 | open Reagents 6 | 7 | (* This file contains two tests which fail due to pair composition not executing in parallel. 8 | 9 | For example: A <*> B actually requires A to execute before B, and that cannot terminate 10 | if A depends on B. Note, the first test does not use <*> explicitely, but said composition 11 | still happens inside channel implementation. 12 | *) 13 | 14 | (* Test 1 *) 15 | let mk_tw_chan () = 16 | let a_p, a_m = Channel.mk_chan ~name:"a" () in 17 | let b_p, b_m = Channel.mk_chan ~name:"b" () in 18 | ((a_p, b_p), (a_m, b_m)) 19 | 20 | let tw_swap (c1, c2) = Channel.swap c1 >>> Channel.swap c2 21 | 22 | let work sw v () = 23 | let x = run (tw_swap sw) v in 24 | Printf.printf "%d" x 25 | 26 | let two_way () = 27 | Scheduler.run_allow_deadlock (fun () -> 28 | let sw1, sw2 = mk_tw_chan () in 29 | Scheduler.fork (work sw1 1); 30 | work sw2 2 ()) 31 | 32 | (* Test 2 *) 33 | let mk_tw_chan () = 34 | let ab, ba = Channel.mk_chan ~name:"ab" () in 35 | let bc, cb = Channel.mk_chan ~name:"bc" () in 36 | let ac, ca = Channel.mk_chan ~name:"ac" () in 37 | ((ab, ac), (ba, bc), (ca, cb)) 38 | 39 | let tw_swap (c1, c2) = Channel.swap c1 <*> Channel.swap c2 40 | 41 | let work sw v () = 42 | let x, y = run (tw_swap sw) v in 43 | Printf.printf "%d %d" x y 44 | 45 | let three_way () = 46 | Scheduler.run_allow_deadlock (fun () -> 47 | let sw1, sw2, sw3 = mk_tw_chan () in 48 | Scheduler.fork (work sw1 1); 49 | Scheduler.fork (work sw2 2); 50 | work sw3 3 ()) 51 | 52 | let () = 53 | let open Alcotest in 54 | run "paired composition not parallel" 55 | [ 56 | ( "simple", 57 | [ 58 | test_case "two-way swap" `Quick two_way; 59 | test_case "three-way swap" `Quick three_way; 60 | ] ); 61 | ] 62 | -------------------------------------------------------------------------------- /tests/queue_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let num_doms = 4 18 | let num_items = 300_000 19 | let items_per_dom = num_items / num_doms 20 | 21 | module S = (val Reagents.Toy_scheduler.make num_doms ()) 22 | module Reagents = Reagents.Make (S) 23 | 24 | module type QUEUE = sig 25 | type 'a t 26 | 27 | val create : unit -> 'a t 28 | val push : 'a t -> 'a -> unit 29 | val pop : 'a t -> 'a option 30 | end 31 | 32 | module type RQUEUE = sig 33 | type 'a t 34 | 35 | val create : unit -> 'a t 36 | val push : 'a t -> ('a, unit) Reagents.t 37 | val try_pop : 'a t -> (unit, 'a option) Reagents.t 38 | end 39 | 40 | module MakeQ (RQ : RQUEUE) : QUEUE = struct 41 | type 'a t = 'a RQ.t 42 | 43 | let create = RQ.create 44 | let push q v = Reagents.run (RQ.push q) v 45 | let pop q = Reagents.run (RQ.try_pop q) () 46 | end 47 | 48 | module Benchmark = struct 49 | let get_mean_sd l = 50 | let get_mean l = 51 | List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) 52 | in 53 | let mean = get_mean l in 54 | let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in 55 | (mean, sd) 56 | 57 | let benchmark f n = 58 | let rec run acc = function 59 | | 0 -> acc 60 | | n -> 61 | let t1 = Unix.gettimeofday () in 62 | let () = f () in 63 | let d = Unix.gettimeofday () -. t1 in 64 | run (d :: acc) (n - 1) 65 | in 66 | let r = run [] n in 67 | get_mean_sd r 68 | end 69 | 70 | module CDL = Reagents.Sync.Countdown_latch 71 | 72 | module Test (Q : QUEUE) = struct 73 | let run num_doms items_per_domain = 74 | let q : int Q.t = Q.create () in 75 | let b = CDL.create num_doms in 76 | (* initialize work *) 77 | let rec produce = function 78 | | 0 -> () 79 | | i -> 80 | Q.push q i; 81 | produce (i - 1) 82 | in 83 | let rec consume i = 84 | if i >= items_per_domain then () 85 | else match Q.pop q with None -> consume i | Some _ -> consume (i + 1) 86 | in 87 | for i = 1 to num_doms - 1 do 88 | S.fork (fun () -> 89 | if i mod 2 == 0 then produce items_per_domain else consume 0; 90 | Reagents.run (CDL.count_down b) ()) 91 | done; 92 | produce items_per_domain; 93 | Reagents.run (CDL.count_down b) (); 94 | Reagents.run (CDL.await b) () 95 | end 96 | 97 | module Make_queue (T : sig 98 | type 'a t 99 | 100 | val create : unit -> 'a t 101 | val push : 'a -> 'a t -> unit 102 | val take_opt : 'a t -> 'a option 103 | end) : QUEUE = struct 104 | type 'a t = 'a T.t 105 | 106 | let create = T.create 107 | let push queue value = T.push value queue 108 | let pop queue = T.take_opt queue 109 | end 110 | 111 | let main () = 112 | let module M = Test (References.Lock_queue) in 113 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 114 | Printf.printf "Lock_queue : mean = %f, sd = %f tp=%f\n%!" m sd 115 | (float_of_int num_items /. m); 116 | 117 | let module M = Test (References.Two_lock_queue) in 118 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 119 | Printf.printf "Two_lock_queue : mean = %f, sd = %f tp=%f\n%!" m sd 120 | (float_of_int num_items /. m); 121 | 122 | let module M = Test (Make_queue (Kcas_data.Queue)) in 123 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 124 | Printf.printf "Kcas_data.Queue : mean = %f, sd = %f tp=%f\n%!" m sd 125 | (float_of_int num_items /. m); 126 | 127 | let module M = Test (MakeQ (Reagents.Data.MichaelScott_queue)) in 128 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 129 | Printf.printf "Reagent Lockfree.MSQueue: mean = %f, sd = %f tp=%f\n%!" m sd 130 | (float_of_int num_items /. m); 131 | 132 | let module M = Test (Lockfree.Michael_scott_queue) in 133 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 134 | Printf.printf "Hand-written Lockfree.MSQueue: mean = %f, sd = %f tp=%f\n%!" m 135 | sd 136 | (float_of_int num_items /. m) 137 | 138 | let () = S.run main 139 | -------------------------------------------------------------------------------- /tests/reagent_queue_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let num_doms = 2 18 | let num_items = 300_000 19 | let items_per_dom = num_items / num_doms 20 | 21 | module S = (val Reagents.Toy_scheduler.make num_doms ()) 22 | module Reagents = Reagents.Make (S) 23 | open Reagents 24 | 25 | module type QUEUE = sig 26 | type 'a t 27 | 28 | val create : unit -> 'a t 29 | val push : 'a t -> 'a -> unit 30 | val pop : 'a t -> 'a option 31 | end 32 | 33 | module type RQUEUE = sig 34 | type 'a t 35 | 36 | val create : unit -> 'a t 37 | val push : 'a t -> ('a, unit) Reagents.t 38 | val try_pop : 'a t -> (unit, 'a option) Reagents.t 39 | end 40 | 41 | module MakeQ (RQ : RQUEUE) : QUEUE = struct 42 | type 'a t = 'a RQ.t 43 | 44 | let create = RQ.create 45 | let push q v = Reagents.run (RQ.push q) v 46 | let pop q = Reagents.run (RQ.try_pop q) () 47 | end 48 | 49 | module Benchmark = struct 50 | let get_mean_sd l = 51 | let get_mean l = 52 | List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) 53 | in 54 | let mean = get_mean l in 55 | let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in 56 | (mean, sd) 57 | 58 | let benchmark f n = 59 | let rec run acc = function 60 | | 0 -> acc 61 | | n -> 62 | let t1 = Unix.gettimeofday () in 63 | let () = f () in 64 | let d = Unix.gettimeofday () -. t1 in 65 | run (d :: acc) (n - 1) 66 | in 67 | let r = run [] n in 68 | get_mean_sd r 69 | end 70 | 71 | module CDL = Sync.Countdown_latch 72 | 73 | module Test (Q : QUEUE) = struct 74 | let run num_doms items_per_domain = 75 | let q : int Q.t = Q.create () in 76 | let b = CDL.create num_doms in 77 | (* initialize work *) 78 | let rec produce = function 79 | | 0 -> () 80 | | i -> 81 | Q.push q i; 82 | produce (i - 1) 83 | in 84 | let rec consume i = 85 | if i >= items_per_domain then () 86 | else match Q.pop q with None -> consume i | Some _ -> consume (i + 1) 87 | in 88 | for _ = 1 to num_doms - 1 do 89 | S.fork (fun () -> 90 | produce items_per_domain; 91 | consume 0; 92 | run (CDL.count_down b) ()) 93 | done; 94 | produce items_per_domain; 95 | consume 0; 96 | run (CDL.count_down b) (); 97 | run (CDL.await b) () 98 | end 99 | 100 | let main () = 101 | let module M = Test (MakeQ (Reagents.Data.MichaelScott_queue)) in 102 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 103 | Printf.printf "Reagent Lockfree.MSQueue: mean = %f, sd = %f tp=%f\n%!" m sd 104 | (float_of_int num_items /. m) 105 | 106 | let () = S.run main 107 | -------------------------------------------------------------------------------- /tests/rec_test.ml: -------------------------------------------------------------------------------- 1 | let num_domains = 4 2 | 3 | module Scheduler = (val Reagents.Toy_scheduler.make num_domains ()) 4 | module Reagents = Reagents.Make (Scheduler) 5 | open Reagents 6 | module RLock = Sync.Recursive_lock (Scheduler) 7 | module CDL = Sync.Countdown_latch 8 | 9 | let rec lock_and_call l i = 10 | run (RLock.acq l) (); 11 | if i > 0 then lock_and_call l (i - 1); 12 | assert (run (RLock.rel l) ()) 13 | 14 | let test1 () = 15 | Scheduler.run (fun () -> 16 | let l = RLock.create () in 17 | 18 | Scheduler.fork (fun () -> 19 | run (RLock.acq l) (); 20 | lock_and_call l 1; 21 | ignore (run (RLock.rel l) ())); 22 | 23 | let cdl = CDL.create (100 + (100 * 2)) in 24 | (* ... *) 25 | for _ = 0 to 99 do 26 | Scheduler.fork (fun () -> 27 | lock_and_call l 100; 28 | run (CDL.count_down cdl) ()) 29 | done; 30 | (* ... *) 31 | for _ = 0 to 99 do 32 | Scheduler.fork (fun () -> 33 | run (RLock.acq l) (); 34 | assert (run (RLock.try_acq l) ()); 35 | assert (run (RLock.rel l) ()); 36 | assert (run (RLock.rel l) ()); 37 | run (CDL.count_down cdl) ()); 38 | Scheduler.fork (fun () -> 39 | if run (RLock.try_acq l) () then ( 40 | lock_and_call l 100; 41 | assert (run (RLock.rel l) ())); 42 | run (CDL.count_down cdl) ()) 43 | done; 44 | run (CDL.await cdl) ()) 45 | 46 | let () = 47 | let open Alcotest in 48 | run "recursive lock test" 49 | [ ("simple", [ test_case "4-domain" `Quick test1 ]) ] 50 | -------------------------------------------------------------------------------- /tests/ref_channel.ml: -------------------------------------------------------------------------------- 1 | module type REF_CHANNEL = sig 2 | type ('a, 'b) reagent 3 | type 'a channel 4 | 5 | val mk_chan : unit -> 'a channel 6 | val send : 'a channel -> ('a, unit) reagent 7 | val recv : 'a channel -> (unit, 'a) reagent 8 | end 9 | 10 | module Ref_channel (Reagents : Reagents.S) : 11 | REF_CHANNEL with type ('a, 'b) reagent = ('a, 'b) Reagents.t = struct 12 | type ('a, 'b) reagent = ('a, 'b) Reagents.t 13 | 14 | open Reagents 15 | 16 | type 'a channel = 'a option Ref.ref 17 | 18 | let mk_chan () = Ref.mk_ref None 19 | 20 | let send r = 21 | Ref.upd r (fun st v -> 22 | match st with None -> Some (Some v, ()) | _ -> None) 23 | 24 | let recv r = 25 | Ref.upd r (fun st _ -> 26 | match st with None -> None | Some v -> Some (None, v)) 27 | end 28 | 29 | module Scheduler = (val Reagents.Toy_scheduler.make 1 ()) 30 | module Reagents = Reagents.Make (Scheduler) 31 | open Reagents 32 | module Channel = Ref_channel (Reagents) 33 | 34 | let chan_send_receive () = 35 | Scheduler.run (fun () -> 36 | let c = Channel.mk_chan () in 37 | Scheduler.fork (fun () -> Printf.printf "%d\n" (run (Channel.recv c) ())); 38 | run (Channel.send c) 10) 39 | 40 | let () = 41 | let open Alcotest in 42 | run "ref channel" 43 | [ ("simple", [ test_case "send receive" `Quick chan_send_receive ]) ] 44 | -------------------------------------------------------------------------------- /tests/ref_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Scheduler = (val Reagents.Toy_scheduler.make 1 ()) 18 | module Reagents = Reagents.Make (Scheduler) 19 | open Reagents 20 | 21 | let update () = 22 | Scheduler.run (fun () -> 23 | let r = Ref.mk_ref 0 in 24 | let foo ov () = if ov = 0 then None else Some (2, ()) in 25 | Scheduler.fork (fun () -> run (Ref.upd r foo) ()); 26 | run (Ref.cas r 0 1) ()) 27 | 28 | let update_monadic () = 29 | Scheduler.run (fun () -> 30 | let r = Ref.mk_ref 2 in 31 | let test2_rg = 32 | Ref.read r >>= fun i -> if i <> 3 then never else constant () 33 | in 34 | Scheduler.fork (run test2_rg); 35 | run (Ref.cas r 2 3) ()) 36 | 37 | let () = 38 | let open Alcotest in 39 | run "ref test" 40 | [ 41 | ( "simple", 42 | [ 43 | test_case "upd" `Quick update; 44 | test_case "monadic upd" `Quick update_monadic; 45 | ] ); 46 | ] 47 | -------------------------------------------------------------------------------- /tests/references/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name references) 3 | (libraries unix)) 4 | -------------------------------------------------------------------------------- /tests/references/lock.ml: -------------------------------------------------------------------------------- 1 | type 'a holder = 'a option ref 2 | type 'a t = 'a holder Atomic.t 3 | 4 | let make initial = Atomic.make (ref (Some initial)) 5 | 6 | let rec wait prev = 7 | match !prev with 8 | | None -> 9 | Domain.cpu_relax (); 10 | wait prev 11 | | Some value -> value 12 | 13 | let acquire m = 14 | let next = ref None in 15 | (next, wait @@ Atomic.exchange m next) 16 | 17 | let release holder value = 18 | assert (None == !holder); 19 | holder := Some value 20 | [@@inline] 21 | -------------------------------------------------------------------------------- /tests/references/lock.mli: -------------------------------------------------------------------------------- 1 | (** Scalable lock mechanism based on the CLH algorithm. *) 2 | 3 | type 'a t 4 | (** Represents a lock that protects an immutable value of type ['a]. *) 5 | 6 | type 'a holder 7 | (** Represents an exclusive hold of an immutable value of type ['a] protected by 8 | an associated lock. *) 9 | 10 | val make : 'a -> 'a t 11 | (** [make value] creates a new lock protecting the given immutable [value]. *) 12 | 13 | val acquire : 'a t -> 'a holder * 'a 14 | (** [acquire lock] acquires the lock and returns a pair of a {!holder} and the 15 | protected immutable value. *) 16 | 17 | val release : 'a holder -> 'a -> unit 18 | (** [release hold value] releases the lock and allows the next {!acquire} in 19 | queue to proceed with the given immutable [value]. 20 | 21 | WARNING: [release] does not perform an atomic release fence. This means 22 | that non-initialising stores performed inside the critical section between 23 | {!acquire} and [release] may not be published before the [value] is seen by 24 | the next {!acquire}. *) 25 | -------------------------------------------------------------------------------- /tests/references/lock_queue.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type 'a t = ('a list * 'a list) Lock.t 18 | 19 | let create () : 'a t = Lock.make ([], []) 20 | 21 | let push q v = 22 | let hold, (front, back) = Lock.acquire q in 23 | Lock.release hold (front, v :: back) 24 | 25 | let pop q = 26 | let hold, (front, back) = Lock.acquire q in 27 | match front with 28 | | x :: xs -> 29 | Lock.release hold (xs, back); 30 | Some x 31 | | [] -> ( 32 | match back with 33 | | [] -> 34 | Lock.release hold ([], []); 35 | None 36 | | xs -> ( 37 | match List.rev xs with 38 | | [] -> failwith "impossible" 39 | | x :: xs -> 40 | Lock.release hold (xs, []); 41 | Some x)) 42 | -------------------------------------------------------------------------------- /tests/references/lock_queue.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val create : unit -> 'a t 4 | val push : 'a t -> 'a -> unit 5 | val pop : 'a t -> 'a option 6 | -------------------------------------------------------------------------------- /tests/references/lock_stack.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type 'a t = 'a list ref * bool Atomic.t 18 | 19 | let max_iters = 100000 20 | 21 | let rec lock m = function 22 | | 0 -> 23 | ignore (Unix.select [] [] [] 0.1); 24 | lock m max_iters 25 | | n -> if Atomic.compare_and_set m false true then () else lock m (n - 1) 26 | 27 | let lock m = lock m max_iters 28 | let rec unlock m = if Atomic.compare_and_set m true false then () else unlock m 29 | let create () : 'a t = (ref [], Atomic.make false) 30 | 31 | let push (l, m) v = 32 | lock m; 33 | l := v :: !l; 34 | unlock m 35 | 36 | let pop (l, m) = 37 | lock m; 38 | let r = 39 | match !l with 40 | | [] -> None 41 | | x :: xl -> 42 | l := xl; 43 | Some x 44 | in 45 | unlock m; 46 | r 47 | -------------------------------------------------------------------------------- /tests/references/lock_stack.mli: -------------------------------------------------------------------------------- 1 | type 'a t = 'a list ref * bool Atomic.t 2 | 3 | val max_iters : int 4 | val lock : bool Atomic.t -> unit 5 | val unlock : bool Atomic.t -> unit 6 | val create : unit -> 'a t 7 | val push : 'a list ref * bool Atomic.t -> 'a -> unit 8 | val pop : 'a list ref * bool Atomic.t -> 'a option 9 | -------------------------------------------------------------------------------- /tests/references/two_lock_queue.ml: -------------------------------------------------------------------------------- 1 | type 'a t = { front : 'a list Lock.t; back : 'a list Lock.t } 2 | 3 | let create () : 'a t = { front = Lock.make []; back = Lock.make [] } 4 | 5 | let push q v = 6 | let hold, back = Lock.acquire q.back in 7 | Lock.release hold (v :: back) 8 | 9 | let pop q = 10 | let hold_of_front, front = Lock.acquire q.front in 11 | match front with 12 | | x :: xs -> 13 | Lock.release hold_of_front xs; 14 | Some x 15 | | [] -> ( 16 | let hold_of_back, back = Lock.acquire q.back in 17 | Lock.release hold_of_back []; 18 | match back with 19 | | [] -> 20 | Lock.release hold_of_front []; 21 | None 22 | | xs -> ( 23 | match List.rev xs with 24 | | [] -> failwith "impossible" 25 | | x :: xs -> 26 | Lock.release hold_of_front xs; 27 | Some x)) 28 | -------------------------------------------------------------------------------- /tests/references/two_lock_queue.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val create : unit -> 'a t 4 | val push : 'a t -> 'a -> unit 5 | val pop : 'a t -> 'a option 6 | -------------------------------------------------------------------------------- /tests/sat.ml: -------------------------------------------------------------------------------- 1 | module Scheduler = (val Reagents.Toy_scheduler.make 1 ()) 2 | module Reagents = Reagents.Make (Scheduler) 3 | open Reagents 4 | 5 | let n = 20 6 | 7 | let rec mk_answer acc = function 8 | | 0 -> acc 9 | | n -> mk_answer (Random.bool () :: acc) (n - 1) 10 | 11 | let answer = mk_answer [] n 12 | 13 | let rec make acc = function 14 | | 0 -> acc 15 | | n -> 16 | let r = constant true <+> constant false in 17 | make (r :: acc) (n - 1) 18 | 19 | let rec join acc = function 20 | | [] -> constant (List.rev acc) 21 | | x :: xs -> x >>= fun v -> join (v :: acc) xs 22 | 23 | let join l = join [] l 24 | 25 | let test1 () = 26 | Scheduler.run (fun () -> 27 | let r = 28 | join (make [] n) >>= fun l -> 29 | (* instead of l = answer, assume `eval_formula l formula` where 30 | eval_formula : input:bool list -> formula -> bool *) 31 | if l = answer then ( 32 | Printf.printf "SAT\n%!"; 33 | constant ()) 34 | else never 35 | in 36 | run r ()) 37 | 38 | let () = 39 | let open Alcotest in 40 | run "sat test" [ ("simple", [ test_case "test 1" `Quick test1 ]) ] 41 | -------------------------------------------------------------------------------- /tests/stack_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015-2016, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | let num_doms = 4 19 | let num_items = 1_000_000 20 | 21 | let () = 22 | if num_doms mod 2 <> 0 then ( 23 | print_endline @@ " must be multiple of 2"; 24 | exit 0) 25 | 26 | let items_per_dom = num_items / num_doms 27 | let () = Printf.printf "items_per_domain = %d\n%!" items_per_dom 28 | 29 | module S = (val Reagents.Toy_scheduler.make num_doms ()) 30 | module Reagents = Reagents.Make (S) 31 | open Reagents 32 | 33 | module type STACK = sig 34 | type 'a t 35 | 36 | val create : unit -> 'a t 37 | val push : 'a t -> 'a -> unit 38 | val pop : 'a t -> 'a option 39 | end 40 | 41 | module type RSTACK = sig 42 | type 'a t 43 | 44 | val create : unit -> 'a t 45 | val push : 'a t -> ('a, unit) Reagents.t 46 | val try_pop : 'a t -> (unit, 'a option) Reagents.t 47 | end 48 | 49 | module MakeS (RQ : RSTACK) : STACK = struct 50 | type 'a t = 'a RQ.t 51 | 52 | let create = RQ.create 53 | let push q v = Reagents.run (RQ.push q) v 54 | let pop q = Reagents.run (RQ.try_pop q) () 55 | end 56 | 57 | module Benchmark = struct 58 | let get_mean_sd l = 59 | let get_mean l = 60 | List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) 61 | in 62 | let mean = get_mean l in 63 | let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in 64 | (mean, sd) 65 | 66 | let benchmark f n = 67 | let rec run acc = function 68 | | 0 -> acc 69 | | n -> 70 | Gc.full_major (); 71 | let t1 = Unix.gettimeofday () in 72 | let () = f () in 73 | let d = Unix.gettimeofday () -. t1 in 74 | run (d :: acc) (n - 1) 75 | in 76 | let r = run [] n in 77 | get_mean_sd r 78 | end 79 | 80 | module CDL = Sync.Countdown_latch 81 | 82 | module Test (Q : STACK) = struct 83 | let run num_doms items_per_domain = 84 | let q : int Q.t = Q.create () in 85 | let b = CDL.create num_doms in 86 | (* initialize work *) 87 | let rec produce = function 88 | | 0 -> () 89 | | i -> 90 | Q.push q i; 91 | produce (i - 1) 92 | in 93 | let rec consume i = 94 | if i >= items_per_domain then () 95 | else match Q.pop q with None -> consume i | Some _ -> consume (i + 1) 96 | in 97 | for i = 0 to num_doms - 1 do 98 | S.fork (fun () -> 99 | if i mod 2 == 0 then produce items_per_domain else consume 0; 100 | run (CDL.count_down b) ()) 101 | done; 102 | produce items_per_domain; 103 | run (CDL.count_down b) (); 104 | run (CDL.await b) () 105 | end 106 | 107 | module Channel_stack : STACK = struct 108 | module TS = Data.Treiber_stack 109 | module Channel = Reagents.Channel 110 | 111 | type 'a t = { 112 | stack : 'a TS.t; 113 | elim_push : ('a, unit) Channel.endpoint; 114 | elim_pop : (unit, 'a) Channel.endpoint; 115 | } 116 | 117 | let create () = 118 | let elim_push, elim_pop = Channel.mk_chan () in 119 | { stack = TS.create (); elim_push; elim_pop } 120 | 121 | let push q v = 122 | let r = Channel.swap q.elim_push <+> TS.push q.stack in 123 | Reagents.run r v 124 | 125 | let pop q = 126 | let side_chan = Channel.swap q.elim_pop >>= fun x -> constant (Some x) in 127 | let r = side_chan <+> TS.try_pop q.stack in 128 | Reagents.run r () 129 | end 130 | 131 | let main () = 132 | let module M = Test (Lockfree.Michael_scott_queue) in 133 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 134 | Printf.printf "Hand-written Treiber Stack: mean = %f, sd = %f tp=%f\n%!" m sd 135 | (float_of_int num_items /. m); 136 | 137 | Gc.full_major (); 138 | let module M = Test (MakeS (Data.Treiber_stack)) in 139 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 140 | Printf.printf "Treiber stack: mean = %f, sd = %f tp=%f\n%!" m sd 141 | (float_of_int num_items /. m); 142 | 143 | Gc.full_major (); 144 | let module M = Test (References.Lock_stack) in 145 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 146 | Printf.printf "Lock stack: mean = %f, sd = %f tp=%f\n%!" m sd 147 | (float_of_int num_items /. m); 148 | 149 | Gc.full_major (); 150 | let module M = Test (MakeS (Data.Elimination_stack)) in 151 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 152 | Printf.printf "Elimination stack: mean = %f, sd = %f tp=%f\n%!" m sd 153 | (float_of_int num_items /. m); 154 | 155 | Gc.full_major (); 156 | let module M = Test (Channel_stack) in 157 | let m, sd = Benchmark.benchmark (fun () -> M.run num_doms items_per_dom) 5 in 158 | Printf.printf "Channel-based stack: mean = %f, sd = %f tp=%f\n%!" m sd 159 | (float_of_int num_items /. m) 160 | 161 | let () = S.run main 162 | -------------------------------------------------------------------------------- /tests/stack_test_compose.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * Copyright (c) 2015-2016, KC Sivaramakrishnan 4 | * 5 | * Permission to use, copy, modify, and/or distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | let num_items = 1_000_000 19 | let items_per_dom = num_items / 2 20 | let () = Printf.printf "items_per_domain = %d\n%!" @@ items_per_dom 21 | 22 | module S = (val Reagents.Toy_scheduler.make 4 ()) 23 | module Reagents = Reagents.Make (S) 24 | open Reagents 25 | 26 | module Benchmark = struct 27 | let get_mean_sd l = 28 | let get_mean l = 29 | List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) 30 | in 31 | let mean = get_mean l in 32 | let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in 33 | (mean, sd) 34 | 35 | let benchmark f n = 36 | let rec run acc = function 37 | | 0 -> acc 38 | | n -> 39 | Gc.full_major (); 40 | let t1 = Unix.gettimeofday () in 41 | let () = f () in 42 | let d = Unix.gettimeofday () -. t1 in 43 | run (d :: acc) (n - 1) 44 | in 45 | let r = run [] n in 46 | get_mean_sd r 47 | end 48 | 49 | module type STACK = sig 50 | type t 51 | 52 | val create : unit -> t * t 53 | val push : t -> int -> unit 54 | val pop : t -> t -> int * int 55 | end 56 | 57 | module Sync = Reagents.Sync 58 | module CDL = Sync.Countdown_latch 59 | 60 | module Test (Stack : STACK) = struct 61 | let run items_per_domain = 62 | let q1, q2 = Stack.create () in 63 | let b = CDL.create 3 in 64 | (* initialize work *) 65 | let rec produce id q = function 66 | | 0 -> () 67 | | i -> 68 | let v = Random.int 1000 in 69 | Stack.push q v; 70 | produce id q (i - 1) 71 | in 72 | let rec consume = function 73 | | 0 -> () 74 | | i -> 75 | let _ = Stack.pop q1 q2 in 76 | consume (i - 1) 77 | in 78 | S.fork (fun () -> 79 | produce 1 q1 items_per_domain; 80 | run (CDL.count_down b) ()); 81 | S.fork (fun () -> 82 | produce 2 q2 items_per_domain; 83 | run (CDL.count_down b) ()); 84 | consume items_per_domain; 85 | run (CDL.count_down b) (); 86 | run (CDL.await b) () 87 | end 88 | 89 | module T = Data.Treiber_stack 90 | 91 | module M1 : STACK = struct 92 | type t = int T.t 93 | 94 | let create () = (T.create (), T.create ()) 95 | let push s v = Reagents.run (T.push s) v 96 | 97 | let pop s1 s2 = 98 | let a = Reagents.run (T.pop s1) () in 99 | let b = Reagents.run (T.pop s2) () in 100 | (a, b) 101 | end 102 | 103 | module M2 : STACK = struct 104 | type t = int T.t 105 | 106 | let create () = (T.create (), T.create ()) 107 | let push s v = Reagents.run (T.push s) v 108 | let pop s1 s2 = Reagents.run (T.pop s1 <*> T.pop s2) () 109 | end 110 | 111 | module M3 : STACK = struct 112 | type t = int T.t 113 | 114 | let create () = (T.create (), T.create ()) 115 | let push s v = Reagents.run (T.push s) v 116 | 117 | let pop s1 s2 = 118 | Reagents.run 119 | (T.pop s1 120 | >>> lift (fun _ -> ()) 121 | >>> T.pop s2 122 | >>> lift (fun _ -> (0, 0)) 123 | <+> (T.pop s2 124 | >>> lift (fun _ -> ()) 125 | >>> T.pop s1 126 | >>> lift (fun _ -> (0, 0)))) 127 | () 128 | end 129 | 130 | let main () = 131 | let module M = Test (M2) in 132 | let m, sd = Benchmark.benchmark (fun () -> M.run items_per_dom) 5 in 133 | Printf.printf "<*>: mean = %f, sd = %f tp=%f\n%!" m sd 134 | (float_of_int num_items /. m); 135 | Gc.full_major (); 136 | 137 | let module M = Test (M3) in 138 | let m, sd = Benchmark.benchmark (fun () -> M.run items_per_dom) 5 in 139 | Printf.printf "<+>: mean = %f, sd = %f tp=%f\n%!" m sd 140 | (float_of_int num_items /. m); 141 | Gc.full_major (); 142 | 143 | let module M = Test (M1) in 144 | let m, sd = Benchmark.benchmark (fun () -> M.run items_per_dom) 5 in 145 | Printf.printf "Non-atomic: mean = %f, sd = %f tp=%f\n%!" m sd 146 | (float_of_int num_items /. m); 147 | Gc.full_major (); 148 | 149 | () 150 | 151 | let () = S.run main 152 | -------------------------------------------------------------------------------- /tests/swap_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015, Théo Laurent 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Scheduler = 18 | (val Reagents.Toy_scheduler.make ~raise_if_all_idle:true 1 ()) 19 | 20 | module Reagents = Reagents.Make (Scheduler) 21 | open Reagents 22 | open Reagents.Channel 23 | 24 | let two_chan_passthrough () = 25 | Scheduler.run (fun () -> 26 | let ep1, ep2 = mk_chan () in 27 | let fp1, fp2 = mk_chan () in 28 | Scheduler.fork (fun () -> assert (run (swap fp1 >>> swap ep1) 1 == 2)); 29 | Scheduler.fork (fun () -> assert (run (swap fp2) 0 == 1)); 30 | assert (run (swap ep2) 2 == 0)) 31 | 32 | let one_chan_loopback () = 33 | Scheduler.run (fun () -> 34 | let ep1, ep2 = mk_chan () in 35 | Scheduler.fork (fun () -> assert (run (swap ep1 >>> swap ep1) 1 == 0)); 36 | Scheduler.fork (fun () -> assert (run (swap ep2) 0 == 2)); 37 | assert (run (swap ep2) 2 == 1)) 38 | 39 | let chan_with_choice () = 40 | Scheduler.run (fun () -> 41 | let ep1, ep2 = mk_chan () in 42 | Scheduler.fork (fun () -> assert (run (swap ep1 <+> swap ep2) 0 == 1)); 43 | assert (run (swap ep2) 1 == 0)) 44 | 45 | let chan_swap_on_overlapping_locs () = 46 | (* Reagents are not as powerful as communicating transactions. *) 47 | Scheduler.run_allow_deadlock (fun () -> 48 | let ep1, ep2 = mk_chan () in 49 | Scheduler.fork (fun () -> 50 | Printf.printf "%d\n%!" (run (swap ep1 >>> swap ep1) 0)); 51 | Printf.printf "%d\n%!" (run (swap ep2 >>> swap ep2) 1)) 52 | 53 | let ref_upd_on_overlapping_locs () = 54 | (* This test should not succeed; expecting kcas failure *) 55 | Scheduler.run_allow_deadlock (fun () -> 56 | let a, b = mk_chan () in 57 | let r = Ref.mk_ref 0 in 58 | Scheduler.fork (fun () -> 59 | run (swap a >>> Ref.upd r (fun _ () -> Some (1, ()))) ()); 60 | match run (swap b >>> Ref.upd r (fun _ () -> Some (2, ()))) () with 61 | | exception _ -> () 62 | | _ -> assert false) 63 | 64 | let () = 65 | let open Alcotest in 66 | run "channel test" 67 | [ 68 | ( "simple", 69 | [ 70 | test_case "two channels connected" `Quick two_chan_passthrough; 71 | test_case "one channel, pass item back" `Quick one_chan_loopback; 72 | test_case "channel with choice" `Quick chan_with_choice; 73 | test_case "overlapping locations; blocking" `Quick 74 | chan_swap_on_overlapping_locs; 75 | test_case "overlapping locations; failing" `Quick 76 | ref_upd_on_overlapping_locs; 77 | ] ); 78 | ] 79 | --------------------------------------------------------------------------------