[
  {
    "path": ".github/workflows/main.yml",
    "content": "name: main\n\non:\n  pull_request:\n  push:\n  schedule:\n    # Prime the caches every Monday\n    - cron: 0 1 * * MON\n\njobs:\n  windows:\n    runs-on: windows-latest\n\n    env:\n      QCHECK_MSG_INTERVAL: '60'\n\n    steps:\n      - name: Checkout code\n        uses: actions/checkout@v2\n\n      - name: Use OCaml ${{ matrix.ocaml-compiler }}\n        uses: ocaml/setup-ocaml@v2\n        with:\n          opam-pin: false\n          opam-depext: false\n          ocaml-compiler: ocaml.5.0.0,ocaml-option-mingw\n          opam-repositories: |\n            dra27: https://github.com/dra27/opam-repository.git#windows-5.0\n            default: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset\n            upstream: https://github.com/ocaml/opam-repository.git\n          cache-prefix: ${{ steps.multicore_hash.outputs.commit }}\n\n      - run: opam install . --deps-only --with-test\n\n      - run: opam exec -- dune build\n\n      - run: opam exec -- dune runtest"
  },
  {
    "path": ".gitignore",
    "content": "*~\n_build\n.merlin\n"
  },
  {
    "path": "CHANGES.md",
    "content": "## 0.5.2\n\n* Upgrade to Saturn 1.0 (#129, @Sudha247)\n* Update README.md instruction to use OCaml 5.1.0 (#123, @punchagan)\n* Fix Saturn.Queue function (#121, @Sudha247)\n* Make parallel_scan work on noncommutative functions (#118, @aytao)\n* Test condition tweaks (#113, @jmid)\n* Adjust PBTs based on recommended_domain_count (#112, @jmid)\n\n## 0.5.1\n\n* Add parallel_find (#90, @gasche)\n* Update CI (#93, @Sudha247)\n* Optimisation to work-stealing (#96, @art-w)\n* Improve docs presentation (#99, @metanivek)\n* Property based tests (#100, jmid)\n* Task: avoid double handler installation (#101, @gasche & @clef-men)\n* Fix a benign data-race in Chan reported by ocaml-tsan (#103, @art-w)\n* Dune, opam, and GitHub Actions fixes (#105, @MisterDA)\n* domain local await support (#107, @polytypic)\n* Windows run on GitHub Actions (#110, @Sudha247)\n* Adjust PBTs based on recommended_domain_count (#112, @jmid)\n* Test condition tweaks (#113, @jmid)\n\n## 0.5.0\n\nThis release includes:\n\n* Bug fix for `parallel_for_reduce` on empty loops.\n* Make Chan.t and Task.promise injective #69\n* Add lockfree dependency #70\n* CI fixes (#73, #76)\n* Breaking change: Rename `num_additional_domains` to `num_domains` for setup_pool\n* Documentation updates (#80, #81, #82)\n\n## 0.4.2\n\nIncludes Effect.eff -> Effect.t change from OCaml trunk. (#65)\n\n## 0.4.1\n\nThis release fixes compatibility with OCaml 5.00.0+trunk in #61. Breaks compatibility with older Multicore variants 4.12.0+domains and 4.12.0+domains+effects\n\n## 0.4.0\n\nThis release includes:\n\n* Usage of effect handlers for task creation. This introduces a breaking change; all computations need to be enclosed in a Task.run function. See #51.\n* Multi_channel uses a per-channel domain-local key, removing the global key. #50\n* Bug fixes in parallel_scan. #60\n\n## 0.3.2\n\nCorresponding updates for breaking changes introduced in ocaml-multicore/ocaml-multicore#704\n\n* Updated with the new interface Domain.cpu_relax\n* Domain.timer_ticks replaced with Mirage clock.\n\n## 0.3.1\n\n* #45 adds support for named pools. This is a breaking change with setup_pool taking an optional name parameter and an extra unit parameter.\n* A minor bug fix in parallel_for_reduce.\n\n## 0.3.0\n\nThis release includes:\n\n* A breaking change for Task pools where the num_domains argument has been renamed num_additional_domains to clear up potential confusion; see #31.\n* A new work-stealing scheduler for Task pools using domain local Chase Lev deques #29; this can improve performance significantly for some workloads.\n* A removal of closure allocation in Chan #28.\n* A move to using the Mutex & Condition modules for the implementation of Chan #24.\n* Various documentation and packaging improvements (#21, #27, #30, #32).\n\n## 0.2.2\n\nUpdates to:\n\n* parallel_for to use new task distribution algorithm and allow default chunk_size (#16)\n* parallel_for_reduce to use new task distribution algorithm and allow default chunk_size parameter (#18)\n\n## 0.2.1\n\n* `recv_poll` made non-allocating\n* Addition of parallel_scan #5\n\n## 0.2.0\n\n* New Tasks library with support for async/await parallelism and parallel for loops.\n* Adds support for non-blocking Chan.send_poll and Chan.recv_poll.\n\nThanks to @gasche for API design discussions.\n\n## 0.1.0\n\nInitial release"
  },
  {
    "path": "CODE_OF_CONDUCT.md",
    "content": "# Code of Conduct\n\nThis project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md).\n\n# Enforcement\n\nThis project follows the OCaml Code of Conduct\n[enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement).\n\nTo report any violations, please contact:\n\n* KC Sivaramakrishnan <kc [at] tarides [dot] com>\n* Sudha Parimala <sudha [at] tarides [dot] com>\n* Vesa Karvonen <vesa [at] tarides [dot] com>\n"
  },
  {
    "path": "LICENSE.md",
    "content": "Copyright (c) 2016 KC Sivaramakrishnan\n\nPermission to use, copy, modify, and/or distribute this software for any\npurpose with or without fee is hereby granted, provided that the above\ncopyright notice and this permission notice appear in all copies.\n\nTHE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\nWITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\nMERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\nANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\nWHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\nACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\nOR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n"
  },
  {
    "path": "Makefile",
    "content": "all:\n\tdune build @install\n\nrun_test:\n\tOCAMLRUNPARAM=\"b=1\" dune runtest -f\n\nclean:\n\tdune clean\n"
  },
  {
    "path": "README.md",
    "content": "# Domainslib - Nested-parallel programming\n\nDomainslib provides support for nested-parallel programming. Domainslib provides async/await mechanism for spawning parallel tasks and awaiting their results. On top of this mechanism, domainslib provides parallel iteration functions. At its core, domainslib has an efficient implementation of work-stealing queue in order to efficiently share tasks with other domains.\n\nHere is a _sequential_ program that computes nth Fibonacci number using recursion:\n\n```ocaml\n(* fib.ml *)\nlet n = try int_of_string Sys.argv.(1) with _ -> 1\n\nlet rec fib n = if n < 2 then 1 else fib (n - 1) + fib (n - 2)\n\nlet main () =\n  let r = fib n in\n  Printf.printf \"fib(%d) = %d\\n%!\" n r\n\nlet _ = main ()\n```\n\nWe can parallelise this program using Domainslib:\n\n```ocaml\n(* fib_par.ml *)\nlet num_domains = try int_of_string Sys.argv.(1) with _ -> 1\nlet n = try int_of_string Sys.argv.(2) with _ -> 1\n\n(* Sequential Fibonacci *)\nlet rec fib n = \n  if n < 2 then 1 else fib (n - 1) + fib (n - 2)\n\nmodule T = Domainslib.Task\n\nlet rec fib_par pool n =\n  if n > 20 then begin\n    let a = T.async pool (fun _ -> fib_par pool (n-1)) in\n    let b = T.async pool (fun _ -> fib_par pool (n-2)) in\n    T.await pool a + T.await pool b\n  end else \n    (* Call sequential Fibonacci if the available work is small *)\n    fib n\n\nlet main () =\n  let pool = T.setup_pool ~num_domains:(num_domains - 1) () in\n  let res = T.run pool (fun _ -> fib_par pool n) in\n  T.teardown_pool pool;\n  Printf.printf \"fib(%d) = %d\\n\" n res\n\nlet _ = main ()\n```\n\nThe parallel program scales nicely compared to the sequential version. The results presented below were obtained on a 2.3 GHz Quad-Core Intel Core i7 MacBook Pro with 4 cores and 8 hardware threads.\n\n```bash\n$ hyperfine './fib.exe 42' './fib_par.exe 2 42' \\\n            './fib_par.exe 4 42' './fib_par.exe 8 42'\nBenchmark 1: ./fib.exe 42\n  Time (mean ± sd):     1.217 s ±  0.018 s    [User: 1.203 s, System: 0.004 s]\n  Range (min … max):    1.202 s …  1.261 s    10 runs\n\nBenchmark 2: ./fib_par.exe 2 42\n  Time (mean ± sd):    628.2 ms ±   2.9 ms    [User: 1243.1 ms, System: 4.9 ms]\n  Range (min … max):   625.7 ms … 634.5 ms    10 runs\n\nBenchmark 3: ./fib_par.exe 4 42\n  Time (mean ± sd):    337.6 ms ±  23.4 ms    [User: 1321.8 ms, System: 8.4 ms]\n  Range (min … max):   318.5 ms … 377.6 ms    10 runs\n\nBenchmark 4: ./fib_par.exe 8 42\n  Time (mean ± sd):    250.0 ms ±   9.4 ms    [User: 1877.1 ms, System: 12.6 ms]\n  Range (min … max):   242.5 ms … 277.3 ms    11 runs\n\nSummary\n  './fib_par2.exe 8 42' ran\n    1.35 ± 0.11 times faster than './fib_par.exe 4 42'\n    2.51 ± 0.10 times faster than './fib_par.exe 2 42'\n    4.87 ± 0.20 times faster than './fib.exe 42'\n```\n\nMore example programs are available [here](https://github.com/ocaml-multicore/domainslib/tree/master/test).\n\n## Installation\n\nYou can install this library using `OPAM`. \n\n```bash\n$ opam switch create 5.3.0\n$ opam install domainslib\n```\n\n## Development\n\nIf you are interested in hacking on the implementation, then `opam pin` this repository:\n\n```bash\n$ opam switch create 5.0.0+trunk --repo=default,alpha=git+https://github.com/kit-ty-kate/opam-alpha-repository.git\n$ git clone https://github.com/ocaml-multicore/domainslib\n$ cd domainslib\n$ opam pin add domainslib file://`pwd`\n```\n"
  },
  {
    "path": "domainslib.opam",
    "content": "# This file is generated by dune, edit dune-project instead\nopam-version: \"2.0\"\nsynopsis: \"Parallel Structures over Domains for Multicore OCaml\"\nmaintainer: [\"KC Sivaramakrishnan <kc@kcsrk.info>\" \"Sudha Parimala\"]\nauthors: [\"KC Sivaramakrishnan <kc@kcsrk.info>\"]\nlicense: \"ISC\"\nhomepage: \"https://github.com/ocaml-multicore/domainslib\"\ndoc: \"https://ocaml-multicore.github.io/domainslib/doc\"\nbug-reports: \"https://github.com/ocaml-multicore/domainslib/issues\"\ndepends: [\n  \"dune\" {>= \"3.0\"}\n  \"ocaml\" {>= \"5.0\"}\n  \"saturn\" {>= \"1.0.0\"}\n  \"domain-local-await\" {>= \"0.1.0\"}\n  \"kcas\" {>= \"0.3.0\" & with-test}\n  \"mirage-clock-unix\" {with-test & >= \"4.2.0\"}\n  \"qcheck-core\" {with-test & >= \"0.20\"}\n  \"qcheck-multicoretests-util\" {with-test & >= \"0.1\"}\n  \"qcheck-stm\" {with-test & >= \"0.1\"}\n  \"odoc\" {with-doc}\n]\nbuild: [\n  [\"dune\" \"subst\"] {dev}\n  [\n    \"dune\"\n    \"build\"\n    \"-p\"\n    name\n    \"-j\"\n    jobs\n    \"@install\"\n    \"@runtest\" {with-test}\n    \"@doc\" {with-doc}\n  ]\n]\ndev-repo: \"git+https://github.com/ocaml-multicore/domainslib.git\"\n"
  },
  {
    "path": "dune-project",
    "content": "(lang dune 3.0)\n(name domainslib)\n(formatting disabled)\n(generate_opam_files true)\n\n(source (github ocaml-multicore/domainslib))\n(authors \"KC Sivaramakrishnan <kc@kcsrk.info>\")\n(maintainers \"KC Sivaramakrishnan <kc@kcsrk.info>\" \"Sudha Parimala\")\n(documentation \"https://ocaml-multicore.github.io/domainslib/doc\")\n(license \"ISC\")\n\n(package\n (name domainslib)\n (synopsis \"Parallel Structures over Domains for Multicore OCaml\")\n (depends\n  (ocaml (>= \"5.0\"))\n  (saturn (>= \"0.4.0\"))\n  (domain-local-await (>= 0.1.0))\n  (kcas (and (>= 0.3.0) :with-test))\n  (mirage-clock-unix (and :with-test (>= \"4.2.0\")))\n  (qcheck-core (and :with-test (>= \"0.20\")))\n  (qcheck-multicoretests-util (and :with-test (>= \"0.1\")))\n  (qcheck-stm (and :with-test (>= \"0.1\")))))\n"
  },
  {
    "path": "lib/chan.ml",
    "content": "(* mutex_condvar will be used per domain; so multiple fibers or\n   systhreads may share a mutex_condvar variable *)\ntype mutex_condvar = {\n  mutex: Mutex.t;\n  condition: Condition.t\n}\n\ntype waiting_notified =\n  | Waiting\n  | Notified\n\ntype 'a contents =\n  | Empty of {receivers: ('a option ref * mutex_condvar) Fun_queue.t}\n  | NotEmpty of {senders: ('a * waiting_notified ref * mutex_condvar) Fun_queue.t; messages: 'a Fun_queue.t}\n\ntype 'a t = {\n  buffer_size: int option;\n  contents: 'a contents Atomic.t\n}\n\nlet mutex_condvar_key =\n  Domain.DLS.new_key (fun () ->\n    let m = Mutex.create () in\n    let c = Condition.create () in\n    {mutex=m; condition=c})\n\nlet make_bounded n =\n  if n < 0 then invalid_arg \"Chan.make_bounded\" ;\n  {buffer_size= Some n;\n   contents = Atomic.make (Empty {receivers= Fun_queue.empty; })}\n\nlet make_unbounded () =\n  {buffer_size= None;\n   contents = Atomic.make (Empty {receivers= Fun_queue.empty})}\n\n(* [send'] is shared by both the blocking and polling versions. Returns a\n * boolean indicating whether the send was successful. Hence, it always returns\n * [true] if [polling] is [false]. *)\nlet rec send' {buffer_size; contents} v ~polling =\n  let open Fun_queue in\n  let old_contents = Atomic.get contents in\n  match old_contents with\n  | Empty {receivers} -> begin\n    (* The channel is empty (no senders) *)\n    match pop receivers with\n    | None ->\n        (* The channel is empty (no senders) and no waiting receivers *)\n        if buffer_size = Some 0 then\n          (* The channel is empty (no senders), no waiting receivers, and\n            * buffer size is 0 *)\n          begin if not polling then begin\n            (* The channel is empty (no senders), no waiting receivers,\n              * buffer size is 0 and we're not polling *)\n            let mc = Domain.DLS.get mutex_condvar_key in\n            let cond_slot = ref Waiting in\n            let new_contents =\n              NotEmpty\n                {messages= empty; senders= push empty (v, cond_slot, mc)}\n            in\n            if Atomic.compare_and_set contents old_contents new_contents\n            then begin\n              Mutex.lock mc.mutex;\n              while !cond_slot = Waiting do\n                Condition.wait mc.condition mc.mutex\n              done;\n              Mutex.unlock mc.mutex;\n              true\n            end else send' {buffer_size; contents} v ~polling\n          end else\n            (* The channel is empty (no senders), no waiting receivers,\n              * buffer size is 0 and we're polling *)\n            false\n          end\n        else\n          (* The channel is empty (no senders), no waiting receivers, and\n            * the buffer size is non-zero *)\n          let new_contents =\n            NotEmpty {messages= push empty v; senders= empty}\n          in\n          if Atomic.compare_and_set contents old_contents new_contents\n          then true\n          else send' {buffer_size; contents} v ~polling\n    | Some ((r, mc), receivers') ->\n        (* The channel is empty (no senders) and there are waiting receivers\n         * *)\n        let new_contents = Empty {receivers= receivers'} in\n        if Atomic.compare_and_set contents old_contents new_contents\n        then begin\n          Mutex.lock mc.mutex;\n          r := Some v;\n          Mutex.unlock mc.mutex;\n          Condition.broadcast mc.condition;\n          true\n         end else send' {buffer_size; contents} v ~polling\n  end\n  | NotEmpty {senders; messages} ->\n      (* The channel is not empty *)\n      if buffer_size = Some (length messages) then\n        (* The channel is not empty, and the buffer is full *)\n        begin if not polling then\n          (* The channel is not empty, the buffer is full and we're not\n            * polling *)\n          let cond_slot = ref Waiting in\n          let mc = Domain.DLS.get mutex_condvar_key in\n          let new_contents =\n            NotEmpty {senders= push senders (v, cond_slot, mc); messages}\n          in\n          if Atomic.compare_and_set contents old_contents new_contents then begin\n            Mutex.lock mc.mutex;\n            while !cond_slot = Waiting do\n              Condition.wait mc.condition mc.mutex;\n            done;\n            Mutex.unlock mc.mutex;\n            true\n          end else send' {buffer_size; contents} v ~polling\n        else\n          (* The channel is not empty, the buffer is full and we're\n            * polling *)\n          false\n        end\n      else\n        (* The channel is not empty, and the buffer is not full *)\n        let new_contents =\n          NotEmpty {messages= push messages v; senders}\n        in\n        if Atomic.compare_and_set contents old_contents new_contents\n        then true\n        else send' {buffer_size; contents} v ~polling\n\nlet send c v =\n  let r = send' c v ~polling:false in\n  assert r\n\nlet send_poll c v = send' c v ~polling:true\n\n(* [recv'] is shared by both the blocking and polling versions. Returns a an\n * optional value indicating whether the receive was successful. Hence, it\n * always returns [Some v] if [polling] is [false]. *)\nlet rec recv' {buffer_size; contents} ~polling =\n  let open Fun_queue in\n  let old_contents = Atomic.get contents in\n  match old_contents with\n  | Empty {receivers} ->\n      (* The channel is empty (no senders) *)\n      if not polling then begin\n        (* The channel is empty (no senders), and we're not polling *)\n        let msg_slot = ref None in\n        let mc = Domain.DLS.get mutex_condvar_key in\n        let new_contents =\n          Empty {receivers= push receivers (msg_slot, mc)}\n        in\n        if Atomic.compare_and_set contents old_contents new_contents then\n        begin\n          Mutex.lock mc.mutex;\n          while !msg_slot = None do\n            Condition.wait mc.condition mc.mutex;\n          done;\n          Mutex.unlock mc.mutex;\n          !msg_slot\n        end else recv' {buffer_size; contents} ~polling\n      end else\n        (* The channel is empty (no senders), and we're polling *)\n        None\n  | NotEmpty {senders; messages} ->\n      (* The channel is not empty *)\n      match (pop messages, pop senders) with\n      | None, None ->\n          (* The channel is not empty, but no senders or messages *)\n          failwith \"Chan.recv: Impossible - channel state\"\n      | Some (m, messages'), None ->\n          (* The channel is not empty, there is a message and no\n            * waiting senders *)\n          let new_contents =\n            if length messages' = 0 then\n              Empty {receivers = empty}\n            else\n              NotEmpty {messages= messages'; senders}\n          in\n          if Atomic.compare_and_set contents old_contents new_contents\n          then Some m\n          else recv' {buffer_size; contents} ~polling\n      | None, Some ((m, c, mc), senders') ->\n          (* The channel is not empty, there are no messages, and there\n            * is a waiting sender. This is only possible is the buffer\n            * size is 0. *)\n          assert (buffer_size = Some 0) ;\n          let new_contents =\n            if length senders' = 0 then\n              Empty {receivers = empty}\n            else\n              NotEmpty {messages; senders= senders'}\n          in\n          if Atomic.compare_and_set contents old_contents new_contents\n          then begin\n            Mutex.lock mc.mutex;\n            c := Notified;\n            Mutex.unlock mc.mutex;\n            Condition.broadcast mc.condition;\n            Some m\n          end else recv' {buffer_size; contents} ~polling\n      | Some (m, messages'), Some ((ms, sc, mc), senders') ->\n          (* The channel is not empty, there is a message, and there is a\n            * waiting sender. *)\n          let new_contents =\n            NotEmpty {messages= push messages' ms; senders= senders'}\n          in\n          if Atomic.compare_and_set contents old_contents new_contents\n          then begin\n            Mutex.lock mc.mutex;\n            sc := Notified;\n            Mutex.unlock mc.mutex;\n            Condition.broadcast mc.condition;\n            Some m\n          end else recv' {buffer_size; contents} ~polling\n\nlet recv c =\n  match recv' c ~polling:false with\n  | None -> failwith \"Chan.recv: impossible - no message\"\n  | Some m -> m\n\nlet recv_poll c =\n  match Atomic.get c.contents with\n  | Empty _ -> None\n  | _ -> recv' c ~polling:true\n"
  },
  {
    "path": "lib/chan.mli",
    "content": "type !'a t\n(** The type of channels *)\n\nval make_bounded : int -> 'a t\n(** [make_bounded n] makes a bounded channel with a buffer of size [n]. Raises\n    [Invalid_argument \"Chan.make_bounded\"] if the buffer size is less than 0.\n\n    With a buffer size of 0, the send operation becomes synchronous. With a\n    buffer size of 1, you get the familiar MVar structure. The channel may be\n    shared between many sending and receiving domains. *)\n\nval make_unbounded : unit -> 'a t\n(** Returns an unbounded channel *)\n\nval send : 'a t -> 'a -> unit\n(** [send c v] sends the values [v] over the channel [c]. If the channel buffer\n    is full then the sending domain blocks until space becomes available. *)\n\nval send_poll : 'a t -> 'a -> bool\n(** [send_poll c v] attempts to send the value [v] over the channel [c]. If the\n    channel buffer is not full, the message is sent and returns [true]. Otherwise,\n    returns [false]. *)\n\nval recv : 'a t -> 'a\n(** [recv c] returns a value [v] received over the channel. If the channel\n    buffer is empty then the domain blocks until a message is sent on the\n    channel. *)\n\nval recv_poll : 'a t -> 'a option\n(** [recv_poll c] attempts to receive a message on the channel [c]. If a\n    message [v] is available on the channel then [Some v] is returned.\n    Otherwise, returns [None]. *)\n"
  },
  {
    "path": "lib/domainslib.ml",
    "content": "module Chan = Chan\nmodule Task = Task\n"
  },
  {
    "path": "lib/dune",
    "content": "(library\n (name domainslib)\n (public_name domainslib)\n (libraries saturn domain-local-await))\n"
  },
  {
    "path": "lib/fun_queue.ml",
    "content": "type 'a t = {length: int; front: 'a list; back: 'a list}\n\nlet empty = {length= 0; front= []; back= []}\n\nlet push {length; front; back} v = {length= length + 1; front; back= v :: back}\n\nlet length {length; _} = length\n\nlet pop {length; front; back} =\n  match front with\n  | [] -> (\n    match List.rev back with\n    | [] ->\n        None\n    | x :: xs ->\n        Some (x, {front= xs; length= length - 1; back= []}) )\n  | x :: xs ->\n      Some (x, {front= xs; length= length - 1; back})\n"
  },
  {
    "path": "lib/fun_queue.mli",
    "content": "type 'a t\n(** The type of functional queue *)\n\nval empty : 'a t\n(** Empty queue *)\n\nval length : 'a t -> int\n(** Returns the length of the queue *)\n\nval push : 'a t -> 'a -> 'a t\n(** [push q v] returns a new queue with [v] pushed to the back of [q] *)\n\nval pop : 'a t -> ('a * 'a t) option\n(** [pop q] returns [None] if the queue is empty. If the queue is non-empty, it\n    returns [Some (v,q')] where [v] is the element popped from the head of [q]\n    and [q'] is the rest of the queue. *)\n"
  },
  {
    "path": "lib/multi_channel.ml",
    "content": "(*\n * Copyright (c) 2021, Tom Kelly <ctk21@cl.cam.ac.uk>\n *\n * Permission to use, copy, modify, and/or distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule Ws_deque = Saturn.Work_stealing_deque\n\ntype mutex_condvar = {\n  mutex: Mutex.t;\n  condition: Condition.t\n}\n\ntype waiting_status =\n  | Waiting\n  | Released\n\ntype dls_state = {\n  mutable id: int;\n  mutable steal_offsets: int array;\n  rng_state: Random.State.t;\n  mc: mutex_condvar;\n}\n\nmodule Foreign_queue = Saturn.Queue\n\ntype 'a t = {\n  channels: 'a Ws_deque.t array;\n  (* Queue for enqueuing work from outside of the pool. *)\n  foreign_queue: 'a Foreign_queue.t;\n  waiters: (waiting_status ref * mutex_condvar ) Chan.t;\n  next_domain_id: int Atomic.t;\n  recv_block_spins: int;\n  dls_key: dls_state Domain.DLS.key;\n}\n\nlet dls_make_key () =\n  Domain.DLS.new_key (fun () ->\n    {\n      id = -1;\n      steal_offsets = Array.make 1 0;\n      rng_state = Random.State.make_self_init ();\n      mc = {mutex=Mutex.create (); condition=Condition.create ()};\n    })\n\nlet rec log2 n =\n  if n <= 1 then 0 else 1 + (log2 (n asr 1))\n\nlet make ?(recv_block_spins = 2048) n =\n  { channels = Array.init n (fun _ -> Ws_deque.create ());\n    foreign_queue = Foreign_queue.create ();\n    waiters = Chan.make_unbounded ();\n    next_domain_id = Atomic.make 0;\n    recv_block_spins;\n    dls_key = dls_make_key ()\n    }\n\nlet register_domain mchan =\n  let id = Atomic.fetch_and_add mchan.next_domain_id 1 in\n  assert(id < Array.length mchan.channels);\n  id\n\nlet init_domain_state mchan dls_state =\n  let id = register_domain mchan in\n  let len = Array.length mchan.channels in\n  dls_state.id <- id;\n  dls_state.steal_offsets <- Array.init (len - 1) (fun i -> (id + i + 1) mod len);\n  dls_state\n  [@@inline never]\n\nlet get_local_state mchan =\n  let dls_state = Domain.DLS.get mchan.dls_key in\n  if dls_state.id >= 0 then begin\n    assert (dls_state.id < Array.length mchan.channels);\n    dls_state\n  end\n  else (init_domain_state mchan dls_state)\n  [@@inline]\n\nlet clear_local_state mchan =\n  let dls_state = Domain.DLS.get mchan.dls_key in\n  dls_state.id <- (-1)\n\nlet rec check_waiters mchan =\n  match Chan.recv_poll mchan.waiters with\n    | None -> ()\n    | Some (status, mc) ->\n      (* avoid the lock if we possibly can *)\n      if !status = Released then check_waiters mchan\n      else begin\n        Mutex.lock mc.mutex;\n        match !status with\n        | Waiting ->\n          begin\n            status := Released;\n            Mutex.unlock mc.mutex;\n            Condition.broadcast mc.condition\n          end\n        | Released ->\n          begin\n            (* this waiter is already released, it might have found something on a poll *)\n            Mutex.unlock mc.mutex;\n            check_waiters mchan\n          end\n      end\n\nlet send_foreign mchan v =\n  Foreign_queue.push mchan.foreign_queue v;\n  check_waiters mchan\n\nlet send mchan v =\n  let id = (get_local_state mchan).id in\n  Ws_deque.push (Array.unsafe_get mchan.channels id) v;\n  check_waiters mchan\n\nlet rec recv_poll_loop mchan dls cur_offset =\n  let offsets = dls.steal_offsets in\n  let k = (Array.length offsets) - cur_offset in\n  if k = 0 then raise Exit\n  else begin\n    let idx = cur_offset + (Random.State.int dls.rng_state k) in\n    let t = Array.unsafe_get offsets idx in\n    let channel = Array.unsafe_get mchan.channels t in\n    try\n      Ws_deque.steal_exn channel\n    with\n      | Saturn.Work_stealing_deque.Empty ->\n        begin\n          Array.unsafe_set offsets idx (Array.unsafe_get offsets cur_offset);\n          Array.unsafe_set offsets cur_offset t;\n          recv_poll_loop mchan dls (cur_offset+1)\n        end\n  end\n\nlet recv_poll_with_dls mchan dls =\n  try\n    Ws_deque.pop_exn (Array.unsafe_get mchan.channels dls.id)\n  with\n    | Saturn.Work_stealing_deque.Empty ->\n      match Foreign_queue.pop_opt mchan.foreign_queue with\n      | None -> recv_poll_loop mchan dls 0\n      | Some v -> v\n  [@@inline]\n\nlet recv_poll mchan =\n  recv_poll_with_dls mchan (get_local_state mchan)\n\nlet rec recv_poll_repeated mchan dls repeats =\n  try\n    recv_poll_with_dls mchan dls\n  with\n    | Exit ->\n      if repeats = 1 then raise Exit\n      else begin\n        Domain.cpu_relax ();\n        recv_poll_repeated mchan dls (repeats - 1)\n      end\n\nlet rec recv mchan =\n  let dls = get_local_state mchan in\n  try\n    recv_poll_repeated mchan dls mchan.recv_block_spins\n  with\n    Exit ->\n      begin\n        (* Didn't find anything, prepare to block:\n         *  - enqueue our wait block in the waiter queue\n         *  - check the queue again\n         *  - go to sleep if our wait block has not been notified\n         *  - when notified retry the recieve\n         *)\n        let status = ref Waiting in\n        let mc = dls.mc in\n        Chan.send mchan.waiters (status, mc);\n        try\n          let v = recv_poll mchan in\n          (* need to check the status as might take an item\n            which is not the one an existing sender has woken us\n            to take *)\n          Mutex.lock mc.mutex;\n          begin match !status with\n          | Waiting -> (status := Released; Mutex.unlock mc.mutex)\n          | Released ->\n            (* we were simultaneously released from a sender;\n              so need to release a waiter *)\n            (Mutex.unlock mc.mutex; check_waiters mchan)\n          end;\n          v\n        with\n          | Exit ->\n            if !status = Waiting then begin\n               Mutex.lock mc.mutex;\n               while !status = Waiting do\n                 Condition.wait mc.condition mc.mutex\n               done;\n               Mutex.unlock mc.mutex\n            end;\n            recv mchan\n      end\n"
  },
  {
    "path": "lib/task.ml",
    "content": "open Effect\nopen Effect.Deep\n\ntype 'a task = unit -> 'a\n\ntype message =\n| Work of (unit -> unit)\n  (* Invariant: the Work function does not need to run under the 'step' handler,\n     it installs its own handler or re-invokes a deep-handler continuation. *)\n| Quit\n\ntype task_chan = message Multi_channel.t\n\ntype pool_data = {\n  domains : unit Domain.t array;\n  task_chan : task_chan;\n  name: string option\n}\n\ntype pool = pool_data option Atomic.t\n\ntype 'a promise_state =\n  Returned of 'a\n| Raised of exn * Printexc.raw_backtrace\n| Pending of (('a, unit) continuation * task_chan) list\n\ntype 'a promise = 'a promise_state Atomic.t\n\ntype _ t += Wait : 'a promise * task_chan -> 'a t\n\nlet get_pool_data p =\n  match Atomic.get p with\n  | None -> invalid_arg \"pool already torn down\"\n  | Some p -> p\n\nlet cont v (k, c) = Multi_channel.send c (Work (fun _ -> continue k v))\nlet discont e bt (k, c) = Multi_channel.send c (Work (fun _ ->\n  discontinue_with_backtrace k e bt))\n\nlet do_task (type a) (f : unit -> a) (p : a promise) : unit =\n  let action, result =\n    try\n      let v = f () in\n      cont v, Returned v\n    with e ->\n      let bt = Printexc.get_raw_backtrace () in\n      discont e bt, Raised (e, bt)\n  in\n  match Atomic.exchange p result with\n  | Pending l -> List.iter action l\n  |  _ -> failwith \"Task.do_task: impossible, can only set result of task once\"\n\nlet await pool promise =\n  let pd = get_pool_data pool in\n  match Atomic.get promise with\n  | Returned v -> v\n  | Raised (e, bt) -> Printexc.raise_with_backtrace e bt\n  | Pending _ -> perform (Wait (promise, pd.task_chan))\n\nlet step (type a) (f : a -> unit) (v : a) : unit =\n  try_with f v\n  { effc = fun (type a) (e : a t) ->\n      match e with\n      | Wait (p,c) -> Some (fun (k : (a, _) continuation) ->\n          let rec loop () =\n            let old = Atomic.get p in\n            match old with\n            | Pending l ->\n                if Atomic.compare_and_set p old (Pending ((k,c)::l)) then ()\n                else (Domain.cpu_relax (); loop ())\n            | Returned v -> continue k v\n            | Raised (e,bt) -> discontinue_with_backtrace k e bt\n          in\n          loop ())\n      | _ -> None }\n\nlet async pool f =\n  let pd = get_pool_data pool in\n  let p = Atomic.make (Pending []) in\n  Multi_channel.send pd.task_chan (Work (fun _ -> step (do_task f) p));\n  p\n\nlet prepare_for_await chan () =\n  let promise = Atomic.make (Pending []) in\n  let release () =\n    match Atomic.get promise with\n    | (Returned _ | Raised _) -> ()\n    | Pending _ ->\n      match Atomic.exchange promise (Returned ()) with\n      | Pending ks ->\n        ks\n        |> List.iter @@ fun (k, c) ->\n           Multi_channel.send_foreign c (Work (fun _ -> continue k ()))\n      | _ -> ()\n  and await () =\n    match Atomic.get promise with\n    | (Returned _ | Raised _) -> ()\n    | Pending _ -> perform (Wait (promise, chan))\n  in\n  Domain_local_await.{ release; await }\n\nlet rec worker task_chan =\n  match Multi_channel.recv task_chan with\n  | Quit -> Multi_channel.clear_local_state task_chan\n  | Work f -> f (); worker task_chan\n\nlet worker task_chan =\n  Domain_local_await.using\n    ~prepare_for_await:(prepare_for_await task_chan)\n    ~while_running:(fun () -> worker task_chan)\n\nlet run (type a) pool (f : unit -> a) : a =\n  let pd = get_pool_data pool in\n  let p = Atomic.make (Pending []) in\n  step (fun _ -> do_task f p) ();\n  let rec loop () : a =\n    match Atomic.get p with\n    | Pending _ ->\n        begin\n          try\n            match Multi_channel.recv_poll pd.task_chan with\n            | Work f -> f ()\n            | Quit -> failwith \"Task.run: tasks are active on pool\"\n          with Exit -> Domain.cpu_relax ()\n        end;\n        loop ()\n   | Returned v -> v\n   | Raised (e, bt) -> Printexc.raise_with_backtrace e bt\n  in\n  loop ()\n\nlet run pool f =\n  Domain_local_await.using\n    ~prepare_for_await:(prepare_for_await (get_pool_data pool).task_chan)\n    ~while_running:(fun () -> run pool f)\n\nlet named_pools = Hashtbl.create 8\nlet named_pools_mutex = Mutex.create ()\n\nlet setup_pool ?name ~num_domains () =\n  if num_domains < 0 then\n    invalid_arg \"Task.setup_pool: num_domains must be at least 0\"\n  else\n  let task_chan = Multi_channel.make (num_domains+1) in\n  let domains = Array.init num_domains (fun _ ->\n    Domain.spawn (fun _ -> worker task_chan))\n  in\n  let p = Atomic.make (Some {domains; task_chan; name}) in\n  begin match name with\n    | None -> ()\n    | Some x ->\n        Mutex.lock named_pools_mutex;\n        Hashtbl.add named_pools x p;\n        Mutex.unlock named_pools_mutex\n  end;\n  p\n\nlet teardown_pool pool =\n  let pd = get_pool_data pool in\n  for _i=1 to Array.length pd.domains do\n    Multi_channel.send pd.task_chan Quit\n  done;\n  Multi_channel.clear_local_state pd.task_chan;\n  Array.iter Domain.join pd.domains;\n  (* Remove the pool from the table *)\n  begin match pd.name with\n  | None -> ()\n  | Some n ->\n      Mutex.lock named_pools_mutex;\n      Hashtbl.remove named_pools n;\n      Mutex.unlock named_pools_mutex\n  end;\n  Atomic.set pool None\n\nlet lookup_pool name =\n  Mutex.lock named_pools_mutex;\n  let p = Hashtbl.find_opt named_pools name in\n  Mutex.unlock named_pools_mutex;\n  p\n\nlet get_num_domains pool =\n  let pd = get_pool_data pool in\n  Array.length pd.domains + 1\n\nlet parallel_for_reduce ?(chunk_size=0) ~start ~finish ~body pool reduce_fun init =\n  let pd = get_pool_data pool in\n  let chunk_size = if chunk_size > 0 then chunk_size\n      else begin\n        let n_domains = (Array.length pd.domains) + 1 in\n        let n_tasks = finish - start + 1 in\n        if n_domains = 1 then n_tasks\n        else max 1 (n_tasks/(8*n_domains))\n      end\n  in\n  let rec work s e =\n    if e - s < chunk_size then\n      let rec loop i acc =\n        if i > e then acc\n        else loop (i+1) (reduce_fun acc (body i))\n      in\n      loop (s+1) (body s)\n    else begin\n      let d = s + ((e - s) / 2) in\n      let p = async pool (fun _ -> work s d) in\n      let right = work (d+1) e in\n      let left = await pool p in\n      reduce_fun left right\n    end\n  in\n  if finish < start\n  then init\n  else reduce_fun init (work start finish)\n\nlet parallel_for ?(chunk_size=0) ~start ~finish ~body pool =\n  let pd = get_pool_data pool in\n  let chunk_size = if chunk_size > 0 then chunk_size\n      else begin\n        let n_domains = (Array.length pd.domains) + 1 in\n        let n_tasks = finish - start + 1 in\n        if n_domains = 1 then n_tasks\n        else max 1 (n_tasks/(8*n_domains))\n      end\n  in\n  let rec work pool fn s e =\n    if e - s < chunk_size then\n      for i = s to e do fn i done\n    else begin\n      let d = s + ((e - s) / 2) in\n      let left = async pool (fun _ -> work pool fn s d) in\n      work pool fn (d+1) e;\n      await pool left\n    end\n  in\n  work pool body start finish\n\nlet parallel_scan pool op elements =\n  let pd = get_pool_data pool in\n  let n = Array.length elements in\n  let p = min (n - 1) ((Array.length pd.domains) + 1) in\n  let prefix_s = Array.copy elements in\n  let scan_part op elements prefix_sum start finish =\n    assert (Array.length elements > (finish - start));\n    for i = (start + 1) to finish do\n      prefix_sum.(i) <- op prefix_sum.(i - 1) elements.(i)\n    done\n  in\n  if p < 2 then begin\n    (* Do a sequential scan when number of domains or array's length is less\n    than 2 *)\n    scan_part op elements prefix_s 0 (n - 1);\n    prefix_s\n  end\n  else begin\n  let add_offset op prefix_sum offset start finish =\n    assert (Array.length prefix_sum > (finish - start));\n    for i = start to finish do\n      prefix_sum.(i) <- op offset prefix_sum.(i)\n    done\n  in\n\n  parallel_for pool ~chunk_size:1 ~start:0 ~finish:(p - 1)\n  ~body:(fun i ->\n    let s = (i * n) / (p ) in\n    let e = (i + 1) * n / (p ) - 1 in\n    scan_part op elements prefix_s s e);\n\n  let x = ref prefix_s.(n/p - 1) in\n  for i = 2 to p do\n      let ind = i * n / p - 1 in\n      x := op !x prefix_s.(ind);\n      prefix_s.(ind) <- !x\n  done;\n\n  parallel_for pool ~chunk_size:1 ~start:1 ~finish:(p - 1)\n  ~body:( fun i ->\n    let s = i * n / (p) in\n    let e = (i + 1) * n / (p) - 2 in\n    let offset = prefix_s.(s - 1) in\n      add_offset op prefix_s offset s e\n    );\n\n  prefix_s\n  end\n\nlet parallel_find (type a) ?(chunk_size=0) ~start ~finish ~body pool =\n  let pd = get_pool_data pool in\n  let found : a option Atomic.t = Atomic.make None in\n  let chunk_size = if chunk_size > 0 then chunk_size\n      else begin\n        let n_domains = (Array.length pd.domains) + 1 in\n        let n_tasks = finish - start + 1 in\n        if n_domains = 1 then n_tasks\n        else max 1 (n_tasks/(8*n_domains))\n      end\n  in\n  let rec work pool fn s e =\n    if e - s < chunk_size then\n      let i = ref s in\n      while !i <= e && Option.is_none (Atomic.get found) do\n        begin match fn !i with\n          | None -> ()\n          | Some _ as some -> Atomic.set found some\n        end;\n        incr i;\n      done\n    else if Option.is_some (Atomic.get found) then ()\n    else begin\n      let d = s + ((e - s) / 2) in\n      let left = async pool (fun _ -> work pool fn s d) in\n      work pool fn (d+1) e;\n      await pool left\n    end\n  in\n  work pool body start finish;\n  Atomic.get found\n"
  },
  {
    "path": "lib/task.mli",
    "content": "type 'a task = unit -> 'a\n(** Type of task *)\n\ntype !'a promise\n(** Type of promises *)\n\ntype pool\n(** Type of task pool *)\n\nval setup_pool : ?name:string -> num_domains:int -> unit -> pool\n(** Sets up a task execution pool with [num_domains] new domains. If [name] is\n    provided, the pool is mapped to [name] which can be looked up later with\n    [lookup_pool name].\n\n    When [num_domains] is 0, the new pool will be empty, and when an empty\n    pool is in use, every function in this module will run effectively\n    sequentially, using the calling domain as the only available domain.\n\n    Raises {!Invalid_argument} when [num_domains] is less than 0. *)\n\nval teardown_pool : pool -> unit\n(** Tears down the task execution pool. *)\n\nval lookup_pool : string -> pool option\n(** [lookup_pool name] returns [Some pool] if [pool] is associated to [name] or\n    returns [None] if no value is associated to it. *)\n\nval get_num_domains : pool -> int\n(** [get_num_domains pool] returns the total number of domains in [pool]\n    including the parent domain. *)\n\nval run : pool -> 'a task -> 'a\n(** [run p t] runs the task [t] synchronously with the calling domain and the\n    domains in the pool [p]. If the task [t] blocks on a promise, then tasks\n    from the pool [p] are executed until the promise blocking [t] is resolved.\n\n    This function should be used at the top level to enclose the calls to other\n    functions that may await on promises. This includes {!await},\n    {!parallel_for} and its variants. Otherwise, those functions will raise\n    [Unhandled] exception. *)\n\nval async : pool -> 'a task -> 'a promise\n(** [async p t] runs the task [t] asynchronously in the pool [p]. The function\n    returns a promise [r] in which the result of the task [t] will be stored. *)\n\nval await : pool -> 'a promise -> 'a\n(** [await p r] waits for the promise [r] to be resolved. During the resolution,\n    other tasks in the pool [p] might be run using the calling domain and/or the\n    domains in the pool [p]. If the task associated with the promise have\n    completed successfully, then the result of the task will be returned. If the\n    task have raised an exception, then [await] raises the same exception.\n\n    Must be called with a call to {!run} in the dynamic scope to handle the\n    internal algebraic effects for task synchronization. *)\n\nval parallel_for : ?chunk_size:int -> start:int -> finish:int ->\n                   body:(int -> unit) -> pool -> unit\n(** [parallel_for c s f b p] behaves similar to [for i=s to f do b i done], but\n    runs the for loop in parallel with the calling domain and/or the domains in\n    the pool [p]. The chunk size [c] determines the number of body applications\n    done in one task; this will default to [max(1, (finish-start + 1) / (8 *\n    num_domains))]. Individual iterations may be run in any order. Tasks are\n    distributed to the participating domains using a divide-and-conquer scheme.\n\n    Must be called with a call to {!run} in the dynamic scope to handle the\n    internal algebraic effects for task synchronization. *)\n\nval parallel_for_reduce : ?chunk_size:int -> start:int -> finish:int ->\n                body:(int -> 'a) -> pool -> ('a -> 'a -> 'a) -> 'a -> 'a\n(** [parallel_for_reduce c s f b p r i] is similar to [parallel_for] except\n    that the result returned by each iteration is reduced with [r] with initial\n    value [i]. The reduce operations are performed in an arbitrary order and\n    the reduce function needs to be associative in order to obtain a\n    deterministic result.\n\n    Must be called with a call to {!run} in the dynamic scope to handle the\n    internal algebraic effects for task synchronization. *)\n\nval parallel_scan : pool -> ('a -> 'a -> 'a) -> 'a array -> 'a array\n(** [parallel_scan p op a] computes the scan of the array [a] in parallel with\n    binary operator [op] and returns the result array, using the calling domain\n    and/or the domains in the pool [p]. Scan is similar to [Array.fold_left]\n    but returns an array of reduced intermediate values. The reduce operations\n    are performed in an arbitrary order and the reduce function needs to be\n    associative in order to obtain a deterministic result.\n\n    Must be called with a call to {!run} in the dynamic scope to handle the\n    internal algebraic effects for task synchronization. *)\n\nval parallel_find : ?chunk_size:int -> start:int -> finish:int ->\n  body:(int -> 'a option) -> pool -> 'a option\n(** [parallel_find ~start ~finish ~body pool] calls [body] in parallel\n    on the indices from [start] to [finish], in any order, until at\n    least one of them returns [Some v].\n\n    Search stops when a value is found, but there is no guarantee that\n    it stops as early as possible, other calls to [body] may happen in\n    parallel or afterwards.\n\n    See {!parallel_for} for the description of the [chunk_size]\n    parameter and the scheduling strategy.\n\n    Must be called with a call to {!run} in the dynamic scope to\n    handle the internal algebraic effects for task synchronization.\n*)\n"
  },
  {
    "path": "test/LU_decomposition_multicore.ml",
    "content": "module T = Domainslib.Task\nlet num_domains = try int_of_string Sys.argv.(1) with _ -> 1\nlet mat_size = try int_of_string Sys.argv.(2) with _ -> 1200\n\nlet k = Domain.DLS.new_key Random.State.make_self_init\n\nmodule SquareMatrix = struct\n  let parallel_create pool f : float array =\n    let fa = Array.create_float (mat_size * mat_size) in\n    T.parallel_for pool ~start:0 ~finish:( mat_size * mat_size - 1)\n      ~body:(fun i -> fa.(i) <- f (i / mat_size) (i mod mat_size));\n    fa\n\n  let get (m : float array) r c = m.(r * mat_size + c)\n  let set (m : float array) r c v = m.(r * mat_size + c) <- v\n  let parallel_copy pool a =\n    let n = Array.length a in\n    let copy_part a b i =\n      let s = (i * n / num_domains) in\n      let e = (i+1) * n / num_domains - 1 in\n      Array.blit a s b s (e - s + 1) in\n    let b = Array.create_float n in\n    let rec aux acc num_domains i =\n      if (i = num_domains) then\n        (List.iter (fun e -> T.await pool e) acc)\n      else begin\n        aux ((T.async pool (fun _ -> copy_part a b i))::acc) num_domains (i+1)\n      end\n    in\n    aux [] num_domains 0;\n    b\nend\n\nopen SquareMatrix\n\nlet lup pool (a0 : float array) =\n  let a = parallel_copy pool a0 in\n  for k = 0 to (mat_size - 2) do\n  T.parallel_for pool ~start:(k + 1) ~finish:(mat_size  -1)\n  ~body:(fun row ->\n    let factor = get a row k /. get a k k in\n    for col = k + 1 to mat_size-1 do\n      set a row col (get a row col -. factor *. (get a k col))\n      done;\n    set a row k factor )\n  done ;\n  a\n\nlet () =\n  let pool = T.setup_pool ~num_domains:(num_domains - 1) () in\n  T.run pool (fun _ ->\n    let a = parallel_create pool\n      (fun _ _ -> (Random.State.float (Domain.DLS.get k) 100.0) +. 1.0 ) in\n    let lu = lup pool a in\n    let _l = parallel_create pool (fun i j -> if i > j then get lu i j else if i = j then 1.0 else 0.0) in\n    let _u = parallel_create pool (fun i j -> if i <= j then get lu i j else 0.0) in\n    ());\n  T.teardown_pool pool\n"
  },
  {
    "path": "test/backtrace.ml",
    "content": "module T = Domainslib.Task\n\nlet rec foo i =\n  if i = 0 then ()\n  else begin\n    ignore (failwith \"exn\");\n    foo i\n  end\n  [@@inline never]\n\nlet rec bar i =\n  if i = 0 then ()\n  else begin\n    foo i;\n    bar i\n  end\n  [@@inline never]\n\nlet main () =\n  let pool = T.setup_pool ~num_domains:0 () in\n  T.run pool (fun _ ->\n    let p = T.async pool (fun _ -> bar 42) in\n    T.await pool p;\n    Printf.printf \"should not reach here\\n%!\");\n  T.teardown_pool pool\n\nlet _ =\n  Printexc.record_backtrace true;\n  try main ()\n  with _ ->\n    let open Printexc in\n    let bt = get_raw_backtrace () in\n    let bt_slot_arr = Option.get (backtrace_slots bt) in\n    let name = Option.get (Slot.name bt_slot_arr.(1)) in\n    assert (name = \"Backtrace.foo\" || name = \"Dune__exe__Backtrace.foo\");\n    let s = raw_backtrace_to_string bt in\n    print_string s\n"
  },
  {
    "path": "test/chan_stm_tests.ml",
    "content": "open QCheck\nopen Domainslib\nopen STM\n\n(** This contains sequential and parallel model-based tests of [Domainslib.Chan] *)\n\nmodule ChConf =\nstruct\n  type state = int list\n  type sut = int Domainslib.Chan.t\n  type cmd =\n    | Send of int\n    | Send_poll of int\n    | Recv\n    | Recv_poll\n\n  let show_cmd c = match c with\n    | Send i -> \"Send\" ^ (string_of_int i)\n    | Send_poll i -> \"Send_poll\" ^ (string_of_int i)\n    | Recv -> \"Recv\"\n    | Recv_poll -> \"Recv_poll\"\n\n  let capacity = 8\n\n  let arb_cmd s =\n    let int_gen = Gen.nat in\n    QCheck.make ~print:show_cmd\n      (if s=[]\n       then\n         Gen.oneof\n           [Gen.map (fun i -> Send i) int_gen;\n\t    Gen.map (fun i -> Send_poll i) int_gen;\n\t    Gen.return Recv_poll] (* don't generate blocking Recv cmds on an empty channel *)\n       else\n       if List.length s >= capacity\n       then\n         Gen.oneof\n           [Gen.map (fun i -> Send_poll i) int_gen;\n            Gen.return Recv;\n\t    Gen.return Recv_poll] (* don't generate blocking Send cmds on a full channel *)\n       else\n         Gen.oneof\n           [Gen.map (fun i -> Send i) int_gen;\n\t    Gen.map (fun i -> Send_poll i) int_gen;\n            Gen.return Recv;\n\t    Gen.return Recv_poll])\n  let init_state  = []\n  let init_sut () = Chan.make_bounded capacity\n  let cleanup _   = ()\n\n  let next_state c s = match c with\n    | Send i      -> if List.length s < capacity then s@[i] else s\n    | Send_poll i -> if List.length s < capacity then s@[i] else s\n    | Recv        -> begin match s with [] -> [] | _::s' -> s' end\n    | Recv_poll   -> begin match s with [] -> [] | _::s' -> s' end\n\n  let precond c s = match c,s with\n    | Recv,   [] -> false\n    | Send _, _  -> List.length s < capacity\n    | _,      _  -> true\n\n  let run c chan =\n    match c with\n    | Send i       -> Res (unit, Chan.send chan i)\n    | Send_poll i  -> Res (bool, Chan.send_poll chan i)\n    | Recv         -> Res (int, Chan.recv chan)\n    | Recv_poll    -> Res (option int, Chan.recv_poll chan)\n\n  let postcond c s res = match c,res with\n    | Send _,      Res ((Unit,_),_) -> (List.length s < capacity)\n    | Send_poll _, Res ((Bool,_),res) -> res = (List.length s < capacity)\n    | Recv,        Res ((Int,_),res) -> (match s with [] -> false | res'::_ -> Int.equal res res')\n    | Recv_poll,   Res ((Option Int,_),opt) -> (match s with [] -> None | res'::_ -> Some res') = opt\n    | _,_ -> false\nend\n\n\nmodule ChT_seq = STM_sequential.Make(ChConf)\nmodule ChT_dom = STM_domain.Make(ChConf)\n\nlet () =\n  let count = 500 in\n  QCheck_base_runner.run_tests_main [\n    ChT_seq.agree_test     ~count ~name:\"STM Domainslib.Chan test sequential\";\n    ChT_dom.agree_test_par ~count ~name:\"STM Domainslib.Chan test parallel\";\n  ]\n"
  },
  {
    "path": "test/dune",
    "content": "(test\n (name test_chan)\n (libraries domainslib)\n (modules test_chan))\n\n(test\n (name fib)\n (modules fib))\n\n(test\n (name fib_par)\n (libraries domainslib)\n (modules fib_par))\n\n(test\n (name kcas_integration)\n (libraries domainslib kcas)\n (modules kcas_integration))\n\n(test\n (name enumerate_par)\n (libraries domainslib)\n (modules enumerate_par))\n\n(test\n (name game_of_life)\n (modules game_of_life))\n\n(test\n (name game_of_life_multicore)\n (libraries domainslib)\n (modules game_of_life_multicore))\n\n(test\n (name LU_decomposition_multicore)\n (libraries domainslib)\n (flags (:standard -runtime-variant d))\n (modules LU_decomposition_multicore)\n (enabled_if (or (= %{arch_sixtyfour} true) (<> %{architecture} arm))))\n   ;; disabled temporarily on arm32 due to failure: ocaml/ocaml#12267\n\n\n(test\n (name spectralnorm2)\n (modules spectralnorm2))\n\n(test\n (name sum_par)\n (libraries domainslib)\n (modules sum_par))\n\n(test\n (name task_throughput)\n (libraries domainslib mirage-clock-unix)\n (modules task_throughput))\n\n(test\n (name spectralnorm2_multicore)\n (libraries domainslib)\n (modules spectralnorm2_multicore))\n\n(test\n (name summed_area_table)\n (libraries domainslib)\n (modules summed_area_table))\n\n(test\n (name prefix_sum)\n (libraries domainslib unix)\n (modules prefix_sum))\n\n(test\n (name test_task)\n (libraries domainslib)\n (modules test_task))\n\n(test\n (name test_parallel_find)\n (libraries domainslib)\n (modules test_parallel_find))\n\n(test\n (name test_parallel_scan)\n (libraries domainslib)\n (modules test_parallel_scan))\n\n(test\n (name test_deadlock)\n (libraries domainslib)\n (modules test_deadlock))\n\n(test\n (name test_task_crash)\n (libraries domainslib)\n (modules test_task_crash))\n\n(test\n (name test_task_empty)\n (libraries domainslib)\n (modules test_task_empty))\n\n(test\n (name backtrace)\n (libraries domainslib)\n (modules backtrace)\n (enabled_if (<> %{system} mingw64)) ;; triggers a known issue on mingw https://github.com/ocaml/ocaml/pull/12231\n (modes byte native))\n ;; byte_complete .exes don't include debug+trace info https://github.com/ocaml/dune/issues/7845\n ;; so on a bytecode switch/platform we build a plain bytecode version w/trace info\n ;; and rename it to .exe\n(rule\n (target backtrace.exe)\n (action (copy backtrace.bc backtrace.exe))\n (enabled_if (and (= %{bin-available:ocamlopt} false) (<> %{system} mingw64))))\n\n(test\n (name off_by_one)\n (libraries domainslib)\n (modules off_by_one))\n\n;; Custom property-based tests using QCheck\n\n(test\n (name task_one_dep)\n (modules task_one_dep)\n (libraries qcheck-multicoretests-util qcheck-core qcheck-core.runner domainslib)\n (enabled_if %{bin-available:ocamlopt}) ;; takes forever on bytecode\n (action (run %{test} --verbose)))\n\n(test\n (name task_more_deps)\n (modules task_more_deps)\n (libraries qcheck-multicoretests-util qcheck-core qcheck-core.runner domainslib)\n (enabled_if %{bin-available:ocamlopt}) ;; takes forever on bytecode\n (action (run %{test} --verbose)))\n\n(test\n (name task_parallel)\n (modules task_parallel)\n (libraries qcheck-multicoretests-util qcheck-core qcheck-core.runner domainslib)\n (action (run %{test} --verbose)))\n\n;; STM_sequential and STM_domain test of Domainslib.Chan\n\n(test\n (name chan_stm_tests)\n (modules chan_stm_tests)\n (libraries qcheck-stm.sequential qcheck-stm.domain domainslib)\n (action (run %{test} --verbose)))\n"
  },
  {
    "path": "test/enumerate_par.ml",
    "content": "let num_domains = try int_of_string Sys.argv.(1) with _ -> 1\nlet n = try int_of_string Sys.argv.(2) with _ -> 100\n\nmodule T = Domainslib.Task\n\nlet _ =\n  let p = T.setup_pool ~num_domains:(num_domains - 1) () in\n  T.run p (fun _ ->\n    T.parallel_for p ~start:0 ~finish:(n-1) ~chunk_size:16 ~body:(fun i ->\n      print_string @@ Printf.sprintf \"[%d] %d\\n%!\" (Domain.self () :> int) i));\n  T.teardown_pool p\n"
  },
  {
    "path": "test/fib.ml",
    "content": "let n = try int_of_string Sys.argv.(1) with _ -> 43\n\nlet rec fib n =\n  if n < 2 then 1\n  else fib (n-1) + fib (n-2)\n\nlet _ = Printf.printf \"fib(%d) = %d\\n\" n (fib n)\n"
  },
  {
    "path": "test/fib_par.ml",
    "content": "let num_domains = try int_of_string Sys.argv.(1) with _ -> 1\nlet n = try int_of_string Sys.argv.(2) with _ -> 43\n\nmodule T = Domainslib.Task\n\nlet rec fib n =\n  if n < 2 then 1\n  else fib (n-1) + fib (n-2)\n\nlet rec fib_par pool n =\n  if n <= 40 then fib n\n  else\n    let a = T.async pool (fun _ -> fib_par pool (n-1)) in\n    let b = T.async pool (fun _ -> fib_par pool (n-2)) in\n    T.await pool a + T.await pool b\n\nlet main =\n  let pool = T.setup_pool ~num_domains:(num_domains - 1) () in\n  let res = T.run pool (fun _ -> fib_par pool n) in\n  T.teardown_pool pool;\n  Printf.printf \"fib(%d) = %d\\n\" n res\n\nlet () = main\n"
  },
  {
    "path": "test/game_of_life.ml",
    "content": "let n_times = try int_of_string Sys.argv.(1) with _ -> 20\nlet board_size = try int_of_string Sys.argv.(2) with _ -> 16\n\nlet rg =\n  ref (Array.init board_size (fun _ -> Array.init board_size (fun _ -> Random.int 2)))\nlet rg' =\n  ref (Array.init board_size (fun _ -> Array.init board_size (fun _ -> Random.int 2)))\nlet buf = Bytes.create board_size\n\nlet get g x y =\n  try g.(x).(y)\n  with _ -> 0\n\nlet neighbourhood g x y =\n  (get g (x-1) (y-1)) +\n  (get g (x-1) (y  )) +\n  (get g (x-1) (y+1)) +\n  (get g (x  ) (y-1)) +\n  (get g (x  ) (y+1)) +\n  (get g (x+1) (y-1)) +\n  (get g (x+1) (y  )) +\n  (get g (x+1) (y+1))\n\nlet next_cell g x y =\n  let n = neighbourhood g x y in\n  match g.(x).(y), n with\n  | 1, 0 | 1, 1                      -> 0  (* lonely *)\n  | 1, 4 | 1, 5 | 1, 6 | 1, 7 | 1, 8 -> 0  (* overcrowded *)\n  | 1, 2 | 1, 3                      -> 1  (* lives *)\n  | 0, 3                             -> 1  (* get birth *)\n  | _ (* 0, (0|1|2|4|5|6|7|8) *)     -> 0  (* barren *)\n\nlet print g =\n  for x = 0 to board_size - 1 do\n    for y = 0 to board_size - 1 do\n      if g.(x).(y) = 0\n      then Bytes.set buf y '.'\n      else Bytes.set buf y 'o'\n    done;\n    print_endline (Bytes.unsafe_to_string buf)\n  done;\n  print_endline \"\"\n\nlet next () =\n  let g = !rg in\n  let new_g = !rg' in\n  for x = 0 to board_size - 1 do\n    for y = 0 to board_size - 1 do\n      new_g.(x).(y) <- next_cell g x y\n    done\n  done;\n  rg := new_g;\n  rg' := g\n\nlet rec repeat n =\n  match n with\n  | 0 -> ()\n  | _ -> next (); repeat (n-1)\n\nlet ()=\n  print !rg;\n  repeat n_times;\n  print !rg\n"
  },
  {
    "path": "test/game_of_life_multicore.ml",
    "content": "let num_domains = try int_of_string Sys.argv.(1) with _ -> 1\nlet n_times = try int_of_string Sys.argv.(2) with _ -> 20\nlet board_size = try int_of_string Sys.argv.(3) with _ -> 16\n\nmodule T = Domainslib.Task\n\nlet rg =\n  ref (Array.init board_size (fun _ -> Array.init board_size (fun _ -> Random.int 2)))\nlet rg' =\n  ref (Array.init board_size (fun _ -> Array.init board_size (fun _ -> Random.int 2)))\nlet buf = Bytes.create board_size\n\nlet get g x y =\n  try g.(x).(y)\n  with _ -> 0\n\nlet neighbourhood g x y =\n  (get g (x-1) (y-1)) +\n  (get g (x-1) (y  )) +\n  (get g (x-1) (y+1)) +\n  (get g (x  ) (y-1)) +\n  (get g (x  ) (y+1)) +\n  (get g (x+1) (y-1)) +\n  (get g (x+1) (y  )) +\n  (get g (x+1) (y+1))\n\nlet next_cell g x y =\n  let n = neighbourhood g x y in\n  match g.(x).(y), n with\n  | 1, 0 | 1, 1                      -> 0  (* lonely *)\n  | 1, 4 | 1, 5 | 1, 6 | 1, 7 | 1, 8 -> 0  (* overcrowded *)\n  | 1, 2 | 1, 3                      -> 1  (* lives *)\n  | 0, 3                             -> 1  (* get birth *)\n  | _ (* 0, (0|1|2|4|5|6|7|8) *)     -> 0  (* barren *)\n\nlet print g =\n  for x = 0 to board_size - 1 do\n    for y = 0 to board_size - 1 do\n      if g.(x).(y) = 0\n      then Bytes.set buf y '.'\n      else Bytes.set buf y 'o'\n    done;\n    print_endline (Bytes.unsafe_to_string buf)\n  done;\n  print_endline \"\"\n\nlet next pool =\n  let g = !rg in\n  let new_g = !rg' in\n  T.parallel_for pool ~start:0\n    ~finish:(board_size - 1) ~body:(fun x ->\n      for y = 0 to board_size - 1 do\n        new_g.(x).(y) <- next_cell g x y\n      done);\n  rg := new_g;\n  rg' := g\n\n\nlet rec repeat pool n =\n  match n with\n  | 0-> ()\n  | _-> next pool; repeat pool (n-1)\n\nlet ()=\n  let pool = T.setup_pool ~num_domains:(num_domains - 1) () in\n  print !rg;\n  T.run pool (fun _ -> repeat pool n_times);\n  print !rg;\n  T.teardown_pool pool\n"
  },
  {
    "path": "test/kcas_integration.ml",
    "content": "open Kcas\nmodule T = Domainslib.Task\n\nlet var = Loc.make None\n\nlet () =\n  let n = 100 in\n  let pool_domain =\n    Domain.spawn @@ fun () ->\n    let pool =\n      T.setup_pool ~num_domains:(Domain.recommended_domain_count () - 2) ()\n    in\n    T.run pool (fun () ->\n        T.parallel_for ~start:1 ~finish:n\n          ~body:(fun i ->\n            ignore @@ Loc.update var\n            @@ function None -> Some i | _ -> Retry.later ())\n          pool);\n    T.teardown_pool pool;\n    Printf.printf \"Done\\n%!\"\n  in\n  for _ = 1 to n do\n    match\n      Loc.update var @@ function None -> Retry.later () | Some _ -> None\n    with\n    | None -> failwith \"impossible\"\n    | Some i -> Printf.printf \"Got %d\\n%!\" i\n  done;\n  Domain.join pool_domain\n"
  },
  {
    "path": "test/off_by_one.ml",
    "content": "open Domainslib\n\nlet print_array a =\n  let b = Buffer.create 25 in\n  Buffer.add_string b \"[|\";\n  Array.iter (fun elem -> Buffer.add_string b (string_of_int elem ^ \"; \")) a;\n  Buffer.add_string b \"|]\";\n  Buffer.contents b\n\nlet r = Array.init 20 (fun i -> i + 1)\n\nlet scan_task num_doms =\n  try\n    let pool = Task.setup_pool ~num_domains:num_doms () in\n    let a = Task.run pool (fun () -> Task.parallel_scan pool (+) (Array.make 20 1)) in\n    Task.teardown_pool pool;\n    Printf.printf \"%i:  %s\\n%!\" num_doms (print_array a);\n    assert (a = r)\n  with Failure msg ->\n    begin\n      assert (msg = \"failed to allocate domain\");\n      Printf.printf \"Failed to allocate %i domains, recommended_domain_count: %i\\n%!\"\n        num_doms (Domain.recommended_domain_count ());\n    end\n;;\nfor num_dom=0 to 21 do\n  scan_task num_dom;\ndone\n"
  },
  {
    "path": "test/prefix_sum.ml",
    "content": "module T = Domainslib.Task\nlet num_domains = try int_of_string Sys.argv.(1) with _ -> 4\nlet n = try int_of_string Sys.argv.(2) with _ -> 100000\n\nlet gen n = Array.make n 1 (*(fun _ -> Random.int n)*)\n\nlet prefix_sum pool = T.parallel_scan pool (+)\n\nlet _ =\n  let pool = T.setup_pool ~num_domains:(num_domains - 1) () in\n  let arr = gen n in\n  let t = Unix.gettimeofday() in\n  ignore (T.run pool (fun _ -> prefix_sum pool arr));\n  Printf.printf \"Execution time: %fs\\n\" (Unix.gettimeofday() -. t);\n  T.teardown_pool pool\n"
  },
  {
    "path": "test/spectralnorm2.ml",
    "content": "(* The Computer Language Benchmarks Game\n * https://salsa.debian.org/benchmarksgame-team/benchmarksgame/\n *\n * Contributed by Sebastien Loisel\n * Cleanup by Troestler Christophe\n * Modified by Mauricio Fernandez\n *)\n\nlet n = try int_of_string Sys.argv.(1) with _ ->  2000\n\nlet eval_A i j = 1. /. float((i+j)*(i+j+1)/2+i+1)\n\nlet eval_A_times_u u v =\n  let n = Array.length v - 1 in\n  for i = 0 to  n do\n    let vi = ref 0. in\n      for j = 0 to n do vi := !vi +. eval_A i j *. u.(j) done;\n      v.(i) <- !vi\n  done\n\nlet eval_At_times_u u v =\n  let n = Array.length v -1 in\n  for i = 0 to n do\n    let vi = ref 0. in\n      for j = 0 to n do vi := !vi +. eval_A j i *. u.(j) done;\n      v.(i) <- !vi\n  done\n\nlet eval_AtA_times_u u v =\n  let w = Array.make (Array.length u) 0.0 in\n  eval_A_times_u u w; eval_At_times_u w v\n\n\nlet () =\n  let u = Array.make n 1.0  and  v = Array.make n 0.0 in\n  for _i = 0 to 9 do\n    eval_AtA_times_u u v; eval_AtA_times_u v u\n  done;\n\n  let vv = ref 0.0  and  vBv = ref 0.0 in\n  for i=0 to n-1 do\n    vv := !vv +. v.(i) *. v.(i);\n    vBv := !vBv +. u.(i) *. v.(i)\n  done;\n  Printf.printf \"%0.9f\\n\" (sqrt(!vBv /. !vv))\n"
  },
  {
    "path": "test/spectralnorm2_multicore.ml",
    "content": "(* The Computer Language Benchmarks Game\n * https://salsa.debian.org/benchmarksgame-team/benchmarksgame/\n *\n * Contributed by Sebastien Loisel\n * Cleanup by Troestler Christophe\n * Modified by Mauricio Fernandez\n *)\n\nlet num_domains = try int_of_string Sys.argv.(1) with _ -> 1\nlet n = try int_of_string Sys.argv.(2) with _ ->  2000\n\nmodule T = Domainslib.Task\n\nlet eval_A i j = 1. /. float((i+j)*(i+j+1)/2+i+1)\n\nlet eval_A_times_u pool u v =\n  let n = Array.length v - 1 in\n  T.parallel_for pool ~start:0 ~finish:n ~chunk_size:(n/num_domains)\n    ~body:(fun i ->\n      let vi = ref 0. in\n      for j = 0 to n do vi := !vi +. eval_A i j *. u.(j) done;\n      v.(i) <- !vi)\n\nlet eval_At_times_u pool u v =\n  let n = Array.length v -1 in\n  T.parallel_for pool ~start:0 ~finish:n ~chunk_size:(n/num_domains)\n    ~body:(fun i ->\n    let vi = ref 0. in\n    for j = 0 to n do vi := !vi +. eval_A j i *. u.(j) done;\n    v.(i) <- !vi)\n\nlet eval_AtA_times_u pool u v =\n  let w = Array.make (Array.length u) 0.0 in\n  eval_A_times_u pool u w; eval_At_times_u pool w v\n\nlet () =\n  let pool = T.setup_pool ~num_domains:(num_domains - 1) () in\n  let u = Array.make n 1.0  and  v = Array.make n 0.0 in\n  T.run pool (fun _ ->\n    for _i = 0 to 9 do\n      eval_AtA_times_u pool u v; eval_AtA_times_u pool v u\n    done);\n  T.teardown_pool pool;\n\n  let vv = ref 0.0  and  vBv = ref 0.0 in\n  for i=0 to n-1 do\n    vv := !vv +. v.(i) *. v.(i);\n    vBv := !vBv +. u.(i) *. v.(i)\n  done;\n  Printf.printf \"%0.9f\\n\" (sqrt(!vBv /. !vv))\n"
  },
  {
    "path": "test/sum_par.ml",
    "content": "let num_domains = try int_of_string Sys.argv.(1) with _ -> 2\nlet n = try int_of_string Sys.argv.(2) with _ -> 100\n\nmodule T = Domainslib.Task\n\nlet _ =\n  (* use parallel_for_reduce *)\n  let p = T.setup_pool ~num_domains:(num_domains - 1) () in\n  let sum = T.run p (fun _ ->\n    T.parallel_for_reduce p (+) 0 ~chunk_size:(n/(4*num_domains)) ~start:0\n      ~finish:(n-1) ~body:(fun _i -> 1))\n  in\n  T.teardown_pool p;\n  Printf.printf \"Sum is %d\\n\" sum;\n  assert (sum = n)\n\nlet _ =\n  (* explictly use empty pool and default chunk_size *)\n  let p = T.setup_pool ~num_domains:0 () in\n  let sum = Atomic.make 0 in\n  T.run p (fun _ ->\n    T.parallel_for p ~start:0 ~finish:(n-1)\n        ~body:(fun _i -> ignore (Atomic.fetch_and_add sum 1)));\n  let sum = Atomic.get sum in\n  T.teardown_pool p;\n  Printf.printf \"Sum is %d\\n\" sum;\n  assert (sum = n)\n\nlet _ =\n  (* configured num_domains and default chunk_size *)\n  let p = T.setup_pool ~num_domains:(num_domains - 1) () in\n  let sum = Atomic.make 0 in\n  T.run p (fun _ ->\n    T.parallel_for p ~start:0 ~finish:(n-1)\n        ~body:(fun _i -> ignore (Atomic.fetch_and_add sum 1)));\n  let sum = Atomic.get sum in\n  T.teardown_pool p;\n  Printf.printf \"Sum is %d\\n\" sum;\n  assert (sum = n)\n\n"
  },
  {
    "path": "test/summed_area_table.ml",
    "content": "module T = Domainslib.Task\nlet num_domains = try int_of_string Sys.argv.(1) with _ -> 4\nlet size = try int_of_string Sys.argv.(2) with _ -> 100\n\nlet transpose a =\n  let r = Array.length a in\n  let c = Array.length a.(0) in\n  let b = Array.copy a in\n  for i = 0 to (pred r) do\n    for j = 0 to (pred c) do\n      b.(j).(i) <- a.(i).(j)\n    done\n  done;\n  b\n\nlet calc_table pool mat =\n  let l = Array.length mat in\n  let res = Array.copy mat in\n  for i = 0 to (l - 1) do\n    res.(i) <- T.parallel_scan pool (fun x y -> x + y) mat.(i)\n  done;\n  let k = transpose res in\n\n  for i = 0 to (l - 1) do\n    res.(i) <- T.parallel_scan pool (fun x y -> x + y) k.(i)\n  done;\n  (transpose res)\n\nlet _ =\n  let m = Array.make_matrix size size 1 (*Array.init size (fun _ -> Array.init size (fun _ -> Random.int size))*)\n  in\n  let pool = T.setup_pool ~num_domains:(num_domains - 1) () in\n  let _ = T.run pool (fun _ -> calc_table pool m) in\n\n  (* for i = 0 to size-1 do\n    for j = 0 to size-1 do\n      print_int a.(i).(j); print_string \"  \"\n    done;\n    print_newline()\n  done; *)\n  T.teardown_pool pool\n"
  },
  {
    "path": "test/task_more_deps.ml",
    "content": "(**\n  Generate tests of async+await from Domainslib.Task.\n  It does so by generating a random, acyclic dependency graph of [async] tasks,\n  each [await]ing on its dependency.\n *)\n\nopen QCheck\nopen Domainslib\n\n(* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *)\nlet rec tak x y z =\n  if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)\n           else z\n\nlet work () =\n  for _ = 1 to 200 do\n    assert (7 = tak 18 12 6);\n  done\n\n(* Generates a DAG of dependencies                          *)\n(* Each task is represented by an array index w/a deps.list *)\n(* This example DAG\n\n     A/0 <--- B/1 <\n      ^.           \\\n        \\           \\\n         `- C/2 <--- D/3\n\n   is represented as: [| []; [0]; [0]; [1;2] |] *)\nlet gen_dag n st =\n  Array.init n (fun i ->\n      let deps = ref [] in\n      for dep = 0 to i-1 do\n        if Gen.bool st then deps := dep :: !deps\n      done;\n      List.rev !deps)\n\ntype test_input =\n  {\n    num_domains  : int;\n    length       : int;\n    dependencies : int list array\n  }\n\nlet show_test_input t =\n  Printf.sprintf\n    \"{ num_domains : %i\\n  length : %i\\n  dependencies : %s }\"\n    t.num_domains t.length Print.(array (list int) t.dependencies)\n\nlet shrink_deps test_input =\n  let ls = Array.to_list test_input.dependencies in\n  let is = Shrink.list ~shrink:Shrink.list ls in\n  Iter.map\n    (fun deps ->\n       let len = List.length deps in\n       let arr = Array.of_list deps in\n       let deps = Array.mapi (fun i i_deps -> match i,i_deps with\n           | 0, _\n           | _,[] -> []\n           | _,[0] -> [0]\n           | _, _ ->\n             List.map (fun j ->\n                 if j<0 || j>=len || j>=i (* ensure reduced dep is valid *)\n                 then ((j + i) mod i)\n                 else j) i_deps) arr in\n       { test_input with length=len; dependencies=deps }) is\n\nlet arb_deps domain_bound promise_bound =\n  let gen_deps =\n    Gen.(pair (int_bound (domain_bound-1)) (int_bound promise_bound) >>= fun (num_domains,length) ->\n         let num_domains = succ num_domains in\n         let length = succ length in\n         gen_dag length >>= fun dependencies -> return { num_domains; length; dependencies }) in\n  make ~print:show_test_input ~shrink:(shrink_deps) gen_deps\n\nlet build_dep_graph pool test_input =\n  let len = test_input.length in\n  let deps = test_input.dependencies in\n  let rec build i promise_acc =\n    if i=len\n    then promise_acc\n    else\n      let p = (match deps.(i) with\n          | [] ->\n            Task.async pool work\n          | deps ->\n            Task.async pool (fun () ->\n                work ();\n                List.iter (fun dep -> Task.await pool (List.nth promise_acc (i-1-dep))) deps)) in\n      build (i+1) (p::promise_acc)\n  in\n  build 0 []\n\nlet test_one_pool ~domain_bound ~promise_bound =\n  Test.make ~name:\"Domainslib.Task.async/await, more deps, 1 work pool\" ~count:100\n    (arb_deps domain_bound promise_bound)\n    (Util.repeat 10\n       (fun test_input ->\n          let pool = Task.setup_pool ~num_domains:test_input.num_domains () in\n          Task.run pool (fun () ->\n              let ps = build_dep_graph pool test_input in\n              List.iter (fun p -> Task.await pool p) ps);\n          Task.teardown_pool pool;\n          true))\n\nlet () =\n  QCheck_base_runner.run_tests_main [test_one_pool ~domain_bound:8 ~promise_bound:10]\n"
  },
  {
    "path": "test/task_one_dep.ml",
    "content": "(**\n  Generate tests of async+await from Domainslib.Task.\n  It does so by generating a random, acyclic dependency graph of [async] tasks,\n  each [await]ing on its dependency.\n *)\n\nopen QCheck\nopen Domainslib\n\n(* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *)\nlet rec tak x y z =\n  if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)\n           else z\n\nlet work () =\n  for _ = 1 to 200 do\n    assert (7 = tak 18 12 6);\n  done\n\n(* Generates a sparse DAG of dependencies                           *)\n(* Each task is represented by an array index w/at most 1 dep. each *)\n(* This example DAG\n\n     A/0 <--- B/1\n      ^.\n        \\\n         `- C/2 <--- D/3\n\n   is represented as: [| None; Some 0; Some 0; Some 2 |] *)\nlet gen_deps n st =\n  let a = Array.make n None in\n  for i=1 to n-1 do\n    if Gen.bool st then a.(i) <- Some (Gen.int_bound (i-1) st)\n  done;\n  a\n\ntype test_input =\n  {\n    num_domains  : int;\n    length       : int;\n    dependencies : int option array\n  }\n\nlet show_test_input t =\n  Printf.sprintf\n    \"{ num_domains : %i\\n  length : %i\\n  dependencies : %s }\"\n    t.num_domains t.length Print.(array (option int) t.dependencies)\n\nlet shrink_deps test_input =\n  let ls = Array.to_list test_input.dependencies in\n  let is = Shrink.list ~shrink:Shrink.(option nil) ls in\n  Iter.map\n    (fun deps ->\n       let len = List.length deps in\n       let arr = Array.of_list deps in\n       let deps = Array.mapi (fun i j_opt -> match i,j_opt with\n            | 0, _\n            | _,None -> None\n            | _,Some 0 -> Some 0\n            | _, Some j ->\n              if j<0 || j>=len || j>=i (* ensure reduced dep is valid *)\n              then Some ((j + i) mod i)\n              else Some j) arr in\n       { test_input with length=len; dependencies=deps }) is\n\nlet arb_deps domain_bound promise_bound =\n  let gen_deps =\n    Gen.(pair (int_bound (domain_bound-1)) (int_bound promise_bound) >>= fun (num_domains,length) ->\n         let num_domains = succ num_domains in\n         let length = succ length in\n         gen_deps length >>= fun dependencies -> return { num_domains; length; dependencies }) in\n  let shrink_input input =\n    Iter.append\n      (Iter.map (fun doms' -> { input with num_domains = doms' }) (Shrink.int input.num_domains))\n      (shrink_deps input) in\n  make ~print:show_test_input ~shrink:shrink_input gen_deps\n\nlet build_dep_graph pool test_input =\n  let len = test_input.length in\n  let deps = test_input.dependencies in\n  let rec build i promise_acc =\n    if i=len\n    then promise_acc\n    else\n      let p = (match deps.(i) with\n          | None ->\n            Task.async pool work\n          | Some dep ->\n            Task.async pool (fun () ->\n                work();\n                Task.await pool (List.nth promise_acc (i-1-dep)))) in\n      build (i+1) (p::promise_acc)\n  in\n  build 0 []\n\nlet test_one_pool ~domain_bound ~promise_bound =\n  Test.make ~name:\"Domainslib.Task.async/await, one dep, 1 work pool\" ~count:100\n    (arb_deps domain_bound promise_bound)\n    (Util.repeat 10 @@\n     fun input ->\n     let pool = Task.setup_pool ~num_domains:input.num_domains () in\n     Task.run pool (fun () ->\n         let ps = build_dep_graph pool input in\n         List.iter (fun p -> Task.await pool p) ps);\n     Task.teardown_pool pool;\n     true)\n\nlet test_two_pools_sync_last ~domain_bound ~promise_bound =\n  let gen = arb_deps domain_bound promise_bound in\n  Test.make ~name:\"Domainslib.Task.async/await, one dep, w.2 pools, syncing at the end\" ~count:100\n    (pair gen gen)\n    (Util.repeat 10 @@\n     fun (input1,input2) ->\n     try\n       let pool1 = Task.setup_pool ~num_domains:input1.num_domains () in\n       let pool2 = Task.setup_pool ~num_domains:input2.num_domains () in\n       let ps1 = build_dep_graph pool1 input1 in\n       let ps2 = build_dep_graph pool2 input2 in\n       Task.run pool1 (fun () -> List.iter (fun p -> Task.await pool1 p) ps1);\n       Task.run pool2 (fun () -> List.iter (fun p -> Task.await pool2 p) ps2);\n       Task.teardown_pool pool1;\n       Task.teardown_pool pool2;\n       true\n     with\n       Failure err -> err = \"failed to allocate domain\")\n\nlet test_two_nested_pools ~domain_bound ~promise_bound =\n  let gen = arb_deps domain_bound promise_bound in\n  Test.make ~name:\"Domainslib.Task.async/await, one dep, w.2 nested pools\" ~count:100\n    (pair gen gen)\n    (Util.repeat 10 @@\n     fun (input1,input2) ->\n     try\n       let pool1 = Task.setup_pool ~num_domains:input1.num_domains () in\n       let pool2 = Task.setup_pool ~num_domains:input2.num_domains () in\n       Task.run pool1 (fun () ->\n           Task.run pool2 (fun () ->\n               let ps1 = build_dep_graph pool1 input1 in\n               let ps2 = build_dep_graph pool2 input2 in\n               List.iter (fun p -> Task.await pool1 p) ps1;\n               List.iter (fun p -> Task.await pool2 p) ps2));\n       Task.teardown_pool pool1;\n       Task.teardown_pool pool2;\n       true\n     with\n       Failure err -> err = \"failed to allocate domain\")\n\nlet () =\n  let domain_bound = max 1 (Domain.recommended_domain_count () / 2) in\n  let promise_bound = max 2 domain_bound in\n  QCheck_base_runner.run_tests_main [\n    test_one_pool            ~domain_bound ~promise_bound;\n    test_two_pools_sync_last ~domain_bound ~promise_bound;\n    test_two_nested_pools    ~domain_bound ~promise_bound;\n  ]\n"
  },
  {
    "path": "test/task_parallel.ml",
    "content": "open QCheck\nopen Domainslib\n\n(** Property-based QCheck tests of Task.parallel_* *)\n\nlet count = 250\n\nlet test_parallel_for =\n  Test.make ~name:\"Domainslib.Task.parallel_for test\" ~count\n    (triple (int_bound 10) small_nat small_nat)\n    (fun (num_domains,array_size,chunk_size) ->\n       let pool = Task.setup_pool ~num_domains () in\n       let res = Task.run pool (fun () ->\n           let a = Atomic.make 0 in\n           Task.parallel_for ~chunk_size ~start:0 ~finish:(array_size-1) ~body:(fun _ -> Atomic.incr a) pool;\n           Atomic.get a) in\n       Task.teardown_pool pool;\n       res = array_size)\n\nlet test_parallel_for_reduce =\n  Test.make ~name:\"Domainslib.Task.parallel_for_reduce test\" ~count\n    (triple (int_bound 10) small_nat small_nat)\n    (fun (num_domains,array_size,chunk_size) ->\n       let pool = Task.setup_pool ~num_domains () in\n       let res = Task.run pool (fun () ->\n           Task.parallel_for_reduce ~chunk_size ~start:0 ~finish:(array_size-1) ~body:(fun _ -> 1) pool (+) 0) in\n       Task.teardown_pool pool;\n       res = array_size)\n\nlet test_parallel_scan =\n  Test.make ~name:\"Domainslib.Task.parallel_scan test\" ~count\n    (pair (int_bound 10) small_nat)\n    (fun (num_domains,array_size) ->\n       let pool = Task.setup_pool ~num_domains () in\n       let a = Task.run pool (fun () -> Task.parallel_scan pool (+) (Array.make array_size 1)) in\n       Task.teardown_pool pool;\n       a = Array.init array_size (fun i -> i + 1))\n\nlet () =\n  QCheck_base_runner.run_tests_main [\n    test_parallel_for;\n    test_parallel_for_reduce;\n    test_parallel_scan;\n  ]\n"
  },
  {
    "path": "test/task_throughput.ml",
    "content": "\nlet n_domains = try int_of_string Sys.argv.(1) with _ -> 1\nlet n_iterations = try int_of_string Sys.argv.(2) with _ -> 1024\nlet n_tasks = try int_of_string Sys.argv.(3) with _ -> 1024\n\nmodule T = Domainslib.Task\n\nmodule TimingHist = struct\n  type t = {\n    data: int array;\n    min_n: int;\n    max_n: int;\n    mutable count: int;\n    mutable sum  : float;\n    }\n\n  let make min_n max_n =\n    { data=Array.make (max_n - min_n) 0; min_n; max_n; count=0; sum=0. }\n\n  let rec log2 n =\n    if n <= 1 then 0 else 1 + log2(n asr 1)\n\n  let add_point a x =\n    let i = (log2 x) in\n    let i = max (i-a.min_n+1) 0 in\n    let i = min i ((Array.length a.data)-1) in\n    a.data.(i) <- a.data.(i) + 1;\n    a.sum <- a.sum +. (float_of_int x);\n    a.count <- a.count + 1\n\n  let mean a =\n    a.sum /. (float_of_int a.count)\n\n  let print_hist a =\n    Printf.printf \"Timings (ns): n=%d  mean=%.1f\\n\" a.count (mean a);\n    let fn n = (Int.shift_left 1 (a.min_n+n)) in\n    let len = Array.length a.data in\n    for i = 0 to (len - 1) do\n      match i with\n      | i when i=0 ->\n        Printf.printf \" (%8d, %8d): %6d\\n\" 0 (fn i) a.data.(i);\n      | i when i=(len-1) ->\n        Printf.printf \" [%8d,      Inf): %6d\\n\" (fn (i-1)) a.data.(i);\n      | i ->\n        Printf.printf \" [%8d, %8d): %6d\\n\" (fn (i-1)) (fn i) a.data.(i);\n    done\n\nend\n\nlet _ =\n  Printf.printf \"n_iterations: %d   n_units: %d  n_domains: %d\\n\"\n    n_iterations n_tasks n_domains;\n  let pool = T.setup_pool ~num_domains:(n_domains - 1) () in\n\n  let hist = TimingHist.make 5 25 in\n  for _ = 1 to n_iterations do\n    let t0 = Mclock.elapsed_ns() in\n    T.run pool (fun _ ->\n      T.parallel_for pool ~start:1 ~finish:n_tasks ~body:(fun _ -> ()));\n    let t = Int64.sub (Mclock.elapsed_ns ()) t0 in\n    TimingHist.add_point hist (Int64.to_int t);\n  done;\n\n  TimingHist.print_hist hist;\n\n  T.teardown_pool pool\n"
  },
  {
    "path": "test/test_chan.ml",
    "content": "let buffer_size = try int_of_string Sys.argv.(1) with _ -> 1\nlet num_items = try int_of_string Sys.argv.(2) with _ -> 100\nlet num_senders = try int_of_string Sys.argv.(3) with _ -> 1\nlet num_receivers = try int_of_string Sys.argv.(4) with _ -> 1\n\nmodule C = Domainslib.Chan\n\nlet c = C.make_bounded buffer_size\n\nlet rec receiver i n =\n  if i = n then\n    print_endline @@ Printf.sprintf \"Receiver on domain %d done\" (Domain.self () :> int)\n  else (\n    ignore @@ C.recv c;\n    receiver (i+1) n )\n\nlet rec sender i n =\n  if i = n then\n    print_endline @@ Printf.sprintf \"Sender on domain %d done\" (Domain.self () :> int)\n  else (\n    C.send c i;\n    sender (i+1) n )\n\nlet _ =\n  assert (num_items mod num_senders == 0);\n  assert (num_items mod num_receivers == 0);\n  let senders =\n    Array.init num_senders (fun _ ->\n      Domain.spawn (fun _ -> sender 0 (num_items / num_senders)))\n  in\n  let receivers =\n    Array.init num_receivers (fun _ ->\n      Domain.spawn (fun _ -> receiver 0 (num_items / num_receivers)))\n  in\n  Array.iter Domain.join senders;\n  Array.iter Domain.join receivers;\n  begin match C.recv_poll c with\n  | None -> ()\n  | Some _ -> assert false\n  end;\n  for _i=1 to buffer_size do\n    C.send c 0\n  done;\n  for _i=1 to buffer_size do\n    ignore (C.recv c)\n  done;\n  begin match C.recv_poll c with\n  | None -> ()\n  | Some _ -> assert false\n  end\n"
  },
  {
    "path": "test/test_deadlock.ml",
    "content": "(* Despite what the name says, this test will not deadlock. A similar test will\n * deadlock in the version not using effect handlers. See\n * https://github.com/ocaml-multicore/ocaml-multicore/issues/670 *)\n\nmodule T = Domainslib.Task\n\nlet n = try int_of_string Sys.argv.(1) with _ -> 1_000_000\n\nlet rec loop n =\n  if n = 0 then\n    Printf.printf \"Looping finished on domain %d\\n%!\" (Domain.self () :> int)\n  else (Domain.cpu_relax (); loop (n-1))\n\nlet () =\n  let pool = T.setup_pool ~num_domains:2 () in\n  T.run pool (fun _ ->\n    let a = T.async pool (fun _ ->\n      Printf.printf \"Task A running on domain %d\\n%!\" (Domain.self () :> int);\n      loop n)\n    in\n    let b = T.async pool (fun _ ->\n      Printf.printf \"Task B running on domain %d\\n%!\" (Domain.self () :> int);\n      T.await pool a)\n    in\n    let c = T.async pool (fun _ ->\n      Printf.printf \"Task C running on domain %d\\n%!\" (Domain.self () :> int);\n      T.await pool b)\n    in\n    loop n;\n    T.await pool c);\n  T.teardown_pool pool\n"
  },
  {
    "path": "test/test_parallel_find.ml",
    "content": "let len = 1_000_000\nlet nb_needles = 4\n\nlet () = Random.init 42\n\nlet needles =\n  Array.init nb_needles (fun _ -> Random.int len)\n\nlet input =\n  let t = Array.make len false in\n  needles |> Array.iter (fun needle ->\n    t.(needle) <- true\n  );\n  t\n\nopen Domainslib\n\nlet search_needle pool ~chunk_size =\n  Task.parallel_find pool ~chunk_size ~start:0 ~finish:(len - 1) ~body:(fun i ->\n    if input.(i) then Some i\n    else None\n  )\n\nlet test_search pool ~chunk_size =\n  match search_needle pool ~chunk_size with\n  | None -> assert false\n  | Some needle ->\n    assert (Array.exists ((=) needle) needles)\n\nlet () =\n  (* [num_domains] is the number of *new* domains spawned by the pool\n     performing computations in addition to the current domain. *)\n  let num_domains = Domain.recommended_domain_count () - 1 in\n  Printf.eprintf \"test_parallel_find on %d domains.\\n\" (num_domains + 1);\n  let pool = Task.setup_pool ~num_domains ~name:\"pool\" () in\n  Task.run pool begin fun () ->\n    [0; 16; 32; 1000] |> List.iter (fun chunk_size ->\n      test_search pool ~chunk_size)\n  end;\n  Task.teardown_pool pool;\n  prerr_endline \"Success.\";\n"
  },
  {
    "path": "test/test_parallel_scan.ml",
    "content": "let len = 1_000_000\n\nlet singleton_interval i = (i, i + 1)\n\nlet combine_intervals interval1 interval2  =\n  let b1, e1 = interval1\n  and b2, e2 = interval2 in\n  if e1 <> b2 then begin\n    Printf.eprintf \"Invalid intervals: (%d, %d), (%d, %d)\\n\" b1 e1 b2 e2;\n    assert false\n  end\n  else (b1, e2)\n\nopen Domainslib\n\nlet test_scan_ordering pool =\n  let check_interval i interval =\n    let (b, e) = interval in\n    assert (b = 0 && e = i + 1)\n  in\n  Array.init len singleton_interval\n  |> Task.parallel_scan pool combine_intervals\n  |> Array.iteri check_interval\n\nlet () =\n  (* [num_domains] is the number of *new* domains spawned by the pool\n     performing computations in addition to the current domain. *)\n  let num_domains = Domain.recommended_domain_count () - 1 in\n  Printf.eprintf \"test_parallel_scan on %d domains.\\n\" (num_domains + 1);\n  let pool = Task.setup_pool ~num_domains ~name:\"pool\" () in\n  Task.run pool begin fun () ->\n    test_scan_ordering pool\n  end;\n  Task.teardown_pool pool;\n  prerr_endline \"Success.\";"
  },
  {
    "path": "test/test_task.ml",
    "content": "(* Generic tests for the task module *)\n\n(* Parallel for *)\n\nopen Domainslib\nlet modify_arr pool chunk_size = fun () ->\n  let arr1 = Array.init 100 (fun i -> i + 1) in\n  Task.parallel_for ~chunk_size ~start:0 ~finish:99\n    ~body:(fun i -> arr1.(i) <- arr1.(i) * 2) pool;\n  let arr_res = Array.init 100 (fun i -> (i + 1) * 2) in\n  assert (arr1 = arr_res)\n\nlet inc_ctr pool chunk_size = fun () ->\n  let ctr = Atomic.make 0 in\n  Task.parallel_for ~chunk_size ~start:1 ~finish:1000\n    ~body:(fun _ -> Atomic.incr ctr) pool;\n  assert (Atomic.get ctr = 1000)\n\n(* Parallel for reduce *)\n\nlet sum_sequence pool chunk_size init = fun () ->\n  let v = Task.parallel_for_reduce ~chunk_size ~start:1\n    ~finish:100 ~body:(fun i -> i) pool (+) init in\n  assert (v = 5050 + init)\n\n(* Parallel scan *)\n\nlet prefix_sum pool = fun () ->\n  let prefix_s l = List.rev (List.fold_left (fun a y -> match a with\n    | [] -> [y]\n    | x::_ -> (x+y)::a) [] l) in\n  let arr = Array.make 1000 1 in\n  let v1 = Task.parallel_scan pool (+) arr in\n  let ls = Array.to_list arr in\n  let v2 = prefix_s ls in\n  assert (v1 = Array.of_list v2)\n\n\nlet () =\n  let pool1 = Task.setup_pool ~num_domains:2 ~name:\"pool1\" () in\n  let pool2 = Task.setup_pool ~num_domains:2 ~name:\"pool2\" () in\n  Task.run pool1 (fun _ ->\n    let p1 = Option.get @@ Task.lookup_pool \"pool1\" in\n    modify_arr pool1 0 ();\n    modify_arr pool1 25 ();\n    modify_arr pool1 100 ();\n    inc_ctr p1 0 ();\n    inc_ctr p1 16 ();\n    inc_ctr p1 32 ();\n    inc_ctr p1 1000 ());\n  Task.run pool2 (fun _ ->\n    let p2 = Option.get @@ Task.lookup_pool \"pool2\" in\n    sum_sequence pool2 0 0 ();\n    sum_sequence pool2 10 10 ();\n    sum_sequence pool2 1 0 ();\n    sum_sequence p2 1 10 ();\n    sum_sequence p2 100 10 ();\n    sum_sequence p2 100 100 ();\n    prefix_sum p2 ());\n  Task.teardown_pool pool1;\n  Task.teardown_pool pool2;\n\n  try\n    sum_sequence pool2 0 0 ();\n    assert false\n  with Invalid_argument _ -> ();\n\n  assert (Task.lookup_pool \"pool1\" = None);\n\n  try\n    let _ = Task.setup_pool ~num_domains:(-1) () in ()\n  with Invalid_argument _ -> ();\n  print_endline \"ok\"\n"
  },
  {
    "path": "test/test_task_crash.ml",
    "content": "open Domainslib\n\n(* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *)\nlet rec tak x y z =\n  if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)\n           else z\n\nlet work () =\n  for _ = 1 to 200 do\n    assert (7 = tak 18 12 6);\n  done\n;;\nbegin\n  let pool1 = Task.setup_pool ~num_domains:2 () in\n  let pool2 = Task.setup_pool ~num_domains:1 () in\n\n  let pool1_prom0 = Task.async pool1 work in\n\n  let pool2_prom0 = Task.async pool2 work in\n  let pool2_prom1 = Task.async pool2 work in\n\n  Task.run pool1 (fun () -> List.iter (fun p -> Task.await pool1 p) [pool1_prom0]);\n  Task.run pool2 (fun () -> List.iter (fun p -> Task.await pool2 p) [pool2_prom0; pool2_prom1]);\n\n  Task.teardown_pool pool1;\n  Task.teardown_pool pool2;\nend\n"
  },
  {
    "path": "test/test_task_empty.ml",
    "content": "open Domainslib\n\nlet array_size = 0\n\nlet pool = Task.setup_pool ~num_domains:0 ()\nlet res = Task.run pool (fun () ->\n    Task.parallel_for_reduce ~chunk_size:0 ~start:0 ~finish:(array_size-1) ~body:(fun _ -> 1) pool (+) 0);;\nTask.teardown_pool pool;;\nassert(res = array_size)\n"
  }
]