more signal handling

close #35

.github/workflows/gh-pages.yml

@@ -13,16 +13,16 @@ jobs:
       - uses: actions/checkout@main
 
       - name: Use OCaml
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
-          ocaml-compiler: '5.0'
+          ocaml-compiler: '5.3'
           dune-cache: true
           allow-prerelease-opam: true
 
       # temporary until it's in a release
-      - run: opam pin https://github.com/ocaml-multicore/picos.git -y -n
+      - run: opam pin picos 0.6.0 -y -n
 
-      - run: opam install odig moonpool moonpool-lwt moonpool-io
+      - run: opam install odig moonpool moonpool-lwt -t
 
       - run: opam exec -- odig odoc --cache-dir=_doc/ moonpool moonpool-lwt
 

.github/workflows/main.yml

@@ -16,32 +16,26 @@ jobs:
         os:
             - ubuntu-latest
         ocaml-compiler:
-            - '4.14'
-            - '5.2'
+            - '5.0'
+            - '5.3'
 
     runs-on: ${{ matrix.os }}
     steps:
       - uses: actions/checkout@main
       - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
           dune-cache: true
           allow-prerelease-opam: true
 
-      # temporary until it's in a release
-      - run: opam pin https://github.com/ocaml-multicore/picos.git -y -n
+      - run: opam pin picos 0.6.0 -y -n
 
-      - run: opam install -t moonpool moonpool-lwt moonpool-io --deps-only
-        if: matrix.ocaml-compiler == '5.2'
-      - run: opam install -t moonpool --deps-only
-        if: matrix.ocaml-compiler != '5.2'
+      - run: opam install -t moonpool moonpool-lwt --deps-only
       - run: opam exec -- dune build @install
 
       # install some depopts
       - run: opam install thread-local-storage trace hmap
-        if: matrix.ocaml-compiler == '5.2'
-
       - run: opam exec -- dune build --profile=release --force @install @runtest
 
   compat:
@@ -59,7 +53,7 @@ jobs:
     steps:
       - uses: actions/checkout@main
       - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
           dune-cache: true
@@ -68,7 +62,7 @@ jobs:
       # temporary until it's in a release
       - run: opam pin https://github.com/ocaml-multicore/picos.git -y -n
 
-      - run: opam install -t moonpool moonpool-lwt moonpool-io --deps-only
+      - run: opam install -t moonpool moonpool-lwt --deps-only
       - run: opam exec -- dune build @install
       # install some depopts
       - run: opam install thread-local-storage trace domain-local-await
@@ -79,17 +73,17 @@ jobs:
     strategy:
       matrix:
         ocaml-compiler:
-            - '5.2'
+            - '5.3'
     runs-on: 'ubuntu-latest'
     steps:
       - uses: actions/checkout@main
       - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
           dune-cache: true
           allow-prerelease-opam: true
 
-      - run: opam install ocamlformat.0.26.2
+      - run: opam install ocamlformat.0.27.0
       - run: opam exec -- make format-check
 

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.26.2
+version = 0.27.0
 profile=conventional
 margin=80
 if-then-else=k-r

CHANGES.md

@@ -1,4 +1,34 @@
 
+# 0.9
+
+- breaking: require OCaml 5
+  * no further need for a preprocessor
+  * forkjoin not longer optional
+
+- moonpool-lwt: large changes, including a Runner that runs
+    inside `Lwt_unix`'s event loop and can thus use any `_ Lwt.t` function
+- remove bounded_queue
+- fix core: better repropagating of errors
+- add `Fut.{cancel,try_cancel}`
+- perf: `await` on immediately ready timer queues its task
+- feat: add `Moonpool.yield`
+
+- deprecate moonpool.sync
+- deprecate moonpool_io
+
+# 0.8
+
+- api(fut): make alias `'a Fut.t = 'a Picos.Computation.t` public
+- feat: add `Fut.make_promise`, have `'a promise = private 'a fut`
+- feat(exn_bt): in show/pp, do print the backtrace when present
+- feat: block signals in workers if asked to
+- relax bound on picos to 0.5-0.6
+- feat fib: `spawn_ignore` now has `?on` optional param
+- change Moonpool.Chan so it's bounded (stil experimental)
+
+- fix task local storage: type was too specific
+- fix fiber: use a single fut/computation in fibers
+
 # 0.7
 
 - add `Moonpool_fiber.spawn_top_ignore`

Makefile

@@ -67,6 +67,14 @@ bench-pi:
 		'./_build/default/benchs/pi.exe -n $(PI_NSTEPS) -j 16 -mode forkjoin -kind=pool' \
 		'./_build/default/benchs/pi.exe -n $(PI_NSTEPS) -j 20 -mode forkjoin -kind=pool'
 
+bench-repro-41:
+	dune build $(DUNE_OPTS_BENCH) examples/repro_41/run.exe
+	hyperfine --warmup=1 \
+		"./_build/default/examples/repro_41/run.exe 4 domainslib" \
+		"./_build/default/examples/repro_41/run.exe 4 moonpool" \
+		"./_build/default/examples/repro_41/run.exe 5 moonpool" \
+		"./_build/default/examples/repro_41/run.exe 5 seq"
+
 .PHONY: test clean bench-fib bench-pi
 
 VERSION=$(shell awk '/^version:/ {print $$2}' moonpool.opam)

README.md

@@ -173,49 +173,9 @@ val expected_sum : int = 5050
 We have a `Exn_bt.t` type that comes in handy in many places. It bundles together
 an exception and the backtrace associated with the place the exception was caught.
 
-### Fibers
+### Local storage
 
-On OCaml 5, Moonpool comes with a library `moonpool.fib` (module `Moonpool_fib`)
-which provides _lightweight fibers_
-that can run on any Moonpool runner.
-These fibers are a sort of lightweight thread, dispatched on the runner's
-background thread(s).
-Fibers rely on effects to implement `Fiber.await`, suspending themselves until the `await`-ed fiber
-is done.
-
-```ocaml
-# #require "moonpool.fib";;
-...
-
-# (* convenient alias *)
-  module F = Moonpool_fib;;
-module F = Moonpool_fib
-# F.main (fun _runner ->
-    let f1 = F.spawn (fun () -> fib 10) in
-    let f2 = F.spawn (fun () -> fib 15) in
-    F.await f1 + F.await f2);;
-- : int = 1076
-```
-
-Fibers form a _tree_, where a fiber calling `Fiber.spawn` to start a sub-fiber is
-the sub-fiber's _parent_.
-When a parent fails, all its children are cancelled (forced to fail).
-This is a simple form of [Structured Concurrency](https://en.wikipedia.org/wiki/Structured_concurrency).
-
-Like a future, a fiber eventually _resolves_ into a value (or an `Exn_bt.t`) that it's possible
-to `await`. With `Fiber.res : 'a Fiber.t -> 'a Fut.t` it's possible to access that result
-as a regular future, too.
-However, this resolution is only done after all the children of the fiber have
-resolved — the lifetime of fibers forms a well-nested tree in that sense.
-
-When a fiber is suspended because it `await`s another fiber (or future), the scheduler's
-thread on which it was running becomes available again and can go on process another task.
-When the fiber resumes, it will automatically be re-scheduled on the same runner it started on.
-This means fibers on pool P1 can await fibers from pool P2 and still be resumed on P1.
-
-In addition to all that, fibers provide _fiber local storage_ (like thread-local storage, but per fiber).
-This storage is inherited in `spawn` (as a shallow copy only — it's advisable to only
-put persistent data in storage to avoid confusing aliasing).
+Moonpool, via picos, provides _task local storage_ (like thread-local storage, but per task).
 The storage is convenient for carrying around context for cross-cutting concerns such
 as logging or tracing (e.g. a log tag for the current user or request ID, or a tracing
 scope).

benchs/dune

@@ -1,6 +1,3 @@
 (executables
  (names fib_rec pi primes)
- (preprocess
-  (action
-   (run %{project_root}/src/cpp/cpp.exe %{input-file})))
  (libraries moonpool moonpool.forkjoin unix trace trace-tef domainslib))

benchs/pi.ml

@@ -66,8 +66,6 @@ let run_par1 ~kind (num_steps : int) : float =
   let pi = step *. Lock.get global_sum in
   pi
 
-[@@@ifge 5.0]
-
 let run_fork_join ~kind num_steps : float =
   let@ pool = with_pool ~kind () in
 
@@ -92,13 +90,6 @@ let run_fork_join ~kind num_steps : float =
   let pi = step *. Lock.get global_sum in
   pi
 
-[@@@else_]
-
-let run_fork_join _ =
-  failwith "fork join not available on this version of OCaml"
-
-[@@@endif]
-
 type mode =
   | Sequential
   | Par1

dune

@@ -3,7 +3,7 @@
   (flags :standard -strict-sequence -warn-error -a+8 -w +a-4-40-42-70)))
 
 (mdx
- (libraries moonpool moonpool.forkjoin moonpool.fib threads)
+ (libraries moonpool moonpool.forkjoin threads)
  (package moonpool)
  (enabled_if
   (>= %{ocaml_version} 5.0)))

dune-project

@@ -2,7 +2,7 @@
 (using mdx 0.2)
 
 (name moonpool)
-(version 0.7)
+(version 0.9)
 (generate_opam_files true)
 (source
  (github c-cube/moonpool))
@@ -16,7 +16,7 @@
  (name moonpool)
  (synopsis "Pools of threads supported by a pool of domains")
  (depends
-  (ocaml (>= 4.14))
+  (ocaml (>= 5.0))
   dune
   (either (>= 1.0))
   (trace :with-test)
@@ -25,8 +25,8 @@
   (thread-local-storage (and (>= 0.2) (< 0.3)))
   (odoc :with-doc)
   (hmap :with-test)
-  (picos (and (>= 0.5) (< 0.6)))
-  (picos_std (and (>= 0.5) (< 0.6)))
+  (picos (and (>= 0.5) (< 0.7)))
+  (picos_std (and (>= 0.5) (< 0.7)))
   (mdx
    (and
     (>= 1.9.0)
@@ -44,23 +44,13 @@
   (depends
     (moonpool (= :version))
     (ocaml (>= 5.0))
+    (qcheck-core (and :with-test (>= 0.19)))
+    (hmap :with-test)
     lwt
     base-unix
     (trace :with-test)
     (trace-tef :with-test)
     (odoc :with-doc)))
 
-(package
-  (name moonpool-io)
-  (synopsis "Async IO for moonpool, relying on picos (experimental)")
-  (allow_empty)  ; on < 5.0
-  (depends
-    (moonpool (= :version))
-    (picos_io (and (>= 0.5) (< 0.6)))
-    (ocaml (>= 5.0))
-    (trace :with-test)
-    (trace-tef :with-test)
-    (odoc :with-doc)))
-
 
 ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project

examples/discuss1.ml

@@ -1,10 +1,12 @@
-(** Example from https://discuss.ocaml.org/t/confused-about-moonpool-cancellation/15381 *)
+(** NOTE: this was an example from
+    https://discuss.ocaml.org/t/confused-about-moonpool-cancellation/15381 but
+    there is no cancelation anymore :) *)
 
 let ( let@ ) = ( @@ )
 
 let () =
   let@ () = Trace_tef.with_setup () in
-  let@ _ = Moonpool_fib.main in
+  let@ _ = Moonpool.main in
 
   (* let@ runner = Moonpool.Ws_pool.with_ () in *)
   let@ runner = Moonpool.Background_thread.with_ () in
@@ -12,15 +14,13 @@ let () =
   (* Pretend this is some long-running read loop *)
   for i = 1 to 10 do
     Printf.printf "MAIN LOOP %d\n%!" i;
-    Moonpool_fib.check_if_cancelled ();
-    let _ : _ Moonpool_fib.t =
-      Moonpool_fib.spawn ~on:runner ~protect:false (fun () ->
+    let _ : _ Moonpool.Fut.t =
+      Moonpool.Fut.spawn ~on:runner (fun () ->
           Printf.printf "RUN FIBER %d\n%!" i;
-          Moonpool_fib.check_if_cancelled ();
           Format.printf "FIBER %d NOT CANCELLED YET@." i;
           failwith "BOOM")
     in
-    Moonpool_fib.yield ();
+    Moonpool.Fut.yield ();
     (* Thread.delay 0.2; *)
     (* Thread.delay 0.0001; *)
     ()

examples/dune

@@ -5,7 +5,6 @@
  ;(package moonpool)
  (libraries
   moonpool
-  moonpool.fib
   trace
   trace-tef
   ;tracy-client.trace

examples/repro_41/dune

@@ -0,0 +1,5 @@
+(executables
+ (names run)
+ (enabled_if
+  (>= %{ocaml_version} 5.0))
+ (libraries moonpool trace trace-tef domainslib))

examples/repro_41/run.ml

@@ -0,0 +1,54 @@
+(* fibo.ml *)
+let cutoff = 25
+let input = 40
+
+let rec fibo_seq n =
+  if n <= 1 then
+    n
+  else
+    fibo_seq (n - 1) + fibo_seq (n - 2)
+
+let rec fibo_domainslib ctx n =
+  if n <= cutoff then
+    fibo_seq n
+  else
+    let open Domainslib in
+    let fut1 = Task.async ctx (fun () -> fibo_domainslib ctx (n - 1)) in
+    let fut2 = Task.async ctx (fun () -> fibo_domainslib ctx (n - 2)) in
+    Task.await ctx fut1 + Task.await ctx fut2
+
+let rec fibo_moonpool ctx n =
+  if n <= cutoff then
+    fibo_seq n
+  else
+    let open Moonpool in
+    let fut1 = Fut.spawn ~on:ctx (fun () -> fibo_moonpool ctx (n - 1)) in
+    let fut2 = Fut.spawn ~on:ctx (fun () -> fibo_moonpool ctx (n - 2)) in
+    Fut.await fut1 + Fut.await fut2
+
+let usage =
+  "fibo.exe <num_domains> [ domainslib | moonpool | moonpool_fifo | seq ]"
+
+let num_domains = try int_of_string Sys.argv.(1) with _ -> failwith usage
+let implem = try Sys.argv.(2) with _ -> failwith usage
+
+let () =
+  let output =
+    match implem with
+    | "moonpool" ->
+      let open Moonpool in
+      let ctx = Ws_pool.create ~num_threads:num_domains () in
+      Ws_pool.run_wait_block ctx (fun () -> fibo_moonpool ctx input)
+    | "moonpool_fifo" ->
+      let open Moonpool in
+      let ctx = Fifo_pool.create ~num_threads:num_domains () in
+      Ws_pool.run_wait_block ctx (fun () -> fibo_moonpool ctx input)
+    | "domainslib" ->
+      let open Domainslib in
+      let pool = Task.setup_pool ~num_domains () in
+      Task.run pool (fun () -> fibo_domainslib pool input)
+    | "seq" -> fibo_seq input
+    | _ -> failwith usage
+  in
+  print_int output;
+  print_newline ()

moonpool-io.opam

@@ -1,33 +0,0 @@
-# This file is generated by dune, edit dune-project instead
-opam-version: "2.0"
-version: "0.7"
-synopsis: "Async IO for moonpool, relying on picos (experimental)"
-maintainer: ["Simon Cruanes"]
-authors: ["Simon Cruanes"]
-license: "MIT"
-homepage: "https://github.com/c-cube/moonpool"
-bug-reports: "https://github.com/c-cube/moonpool/issues"
-depends: [
-  "dune" {>= "3.0"}
-  "moonpool" {= version}
-  "picos_io" {>= "0.5" & < "0.6"}
-  "ocaml" {>= "5.0"}
-  "trace" {with-test}
-  "trace-tef" {with-test}
-  "odoc" {with-doc}
-]
-build: [
-  ["dune" "subst"] {dev}
-  [
-    "dune"
-    "build"
-    "-p"
-    name
-    "-j"
-    jobs
-    "@install"
-    "@runtest" {with-test}
-    "@doc" {with-doc}
-  ]
-]
-dev-repo: "git+https://github.com/c-cube/moonpool.git"

moonpool-lwt.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.7"
+version: "0.9"
 synopsis: "Event loop for moonpool based on Lwt-engine (experimental)"
 maintainer: ["Simon Cruanes"]
 authors: ["Simon Cruanes"]
@@ -11,6 +11,8 @@ depends: [
   "dune" {>= "3.0"}
   "moonpool" {= version}
   "ocaml" {>= "5.0"}
+  "qcheck-core" {with-test & >= "0.19"}
+  "hmap" {with-test}
   "lwt"
   "base-unix"
   "trace" {with-test}

moonpool.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.7"
+version: "0.9"
 synopsis: "Pools of threads supported by a pool of domains"
 maintainer: ["Simon Cruanes"]
 authors: ["Simon Cruanes"]
@@ -9,7 +9,7 @@ tags: ["thread" "pool" "domain" "futures" "fork-join"]
 homepage: "https://github.com/c-cube/moonpool"
 bug-reports: "https://github.com/c-cube/moonpool/issues"
 depends: [
-  "ocaml" {>= "4.14"}
+  "ocaml" {>= "5.0"}
   "dune" {>= "3.0"}
   "either" {>= "1.0"}
   "trace" {with-test}
@@ -18,8 +18,8 @@ depends: [
   "thread-local-storage" {>= "0.2" & < "0.3"}
   "odoc" {with-doc}
   "hmap" {with-test}
-  "picos" {>= "0.5" & < "0.6"}
-  "picos_std" {>= "0.5" & < "0.6"}
+  "picos" {>= "0.5" & < "0.7"}
+  "picos_std" {>= "0.5" & < "0.7"}
   "mdx" {>= "1.9.0" & with-test}
 ]
 depopts: [

src/core/background_thread.ml

@@ -6,18 +6,15 @@ type ('a, 'b) create_args =
   ?on_init_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exit_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exn:(exn -> Printexc.raw_backtrace -> unit) ->
-  ?around_task:(t -> 'b) * (t -> 'b -> unit) ->
   ?name:string ->
   'a
 (** Arguments used in {!create}. See {!create} for explanations. *)
 
-let create ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?name () : t =
-  Fifo_pool.create ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?name
-    ~num_threads:1 ()
+let create ?on_init_thread ?on_exit_thread ?on_exn ?name () : t =
+  Fifo_pool.create ?on_init_thread ?on_exit_thread ?on_exn ?name ~num_threads:1
+    ()
 
-let with_ ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?name () f =
-  let pool =
-    create ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?name ()
-  in
+let with_ ?on_init_thread ?on_exit_thread ?on_exn ?name () f =
+  let pool = create ?on_init_thread ?on_exit_thread ?on_exn ?name () in
   let@ () = Fun.protect ~finally:(fun () -> shutdown pool) in
   f pool

src/core/background_thread.mli

@@ -1,13 +1,11 @@
 (** A simple runner with a single background thread.
 
-    Because this is guaranteed to have a single worker thread,
-    tasks scheduled in this runner always run asynchronously but
-    in a sequential fashion.
+    Because this is guaranteed to have a single worker thread, tasks scheduled
+    in this runner always run asynchronously but in a sequential fashion.
 
     This is similar to {!Fifo_pool} with exactly one thread.
 
-    @since 0.6
-*)
+    @since 0.6 *)
 
 include module type of Runner
 
@@ -15,7 +13,6 @@ type ('a, 'b) create_args =
   ?on_init_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exit_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exn:(exn -> Printexc.raw_backtrace -> unit) ->
-  ?around_task:(t -> 'b) * (t -> 'b -> unit) ->
   ?name:string ->
   'a
 (** Arguments used in {!create}. See {!create} for explanations. *)

src/core/bb_queue.mli

@@ -16,48 +16,45 @@ val size : _ t -> int
 
 val pop : 'a t -> 'a
 (** [pop q] pops the next element in [q]. It might block until an element comes.
-   @raise Closed if the queue was closed before a new element was available. *)
+    @raise Closed if the queue was closed before a new element was available. *)
 
 val try_pop : force_lock:bool -> 'a t -> 'a option
-(** [try_pop q] immediately pops the first element of [q], if any,
-    or returns [None] without blocking.
-    @param force_lock if true, use {!Mutex.lock} (which can block under contention);
-      if false, use {!Mutex.try_lock}, which might return [None] even in
-      presence of an element if there's contention *)
+(** [try_pop q] immediately pops the first element of [q], if any, or returns
+    [None] without blocking.
+    @param force_lock
+      if true, use {!Mutex.lock} (which can block under contention); if false,
+      use {!Mutex.try_lock}, which might return [None] even in presence of an
+      element if there's contention *)
 
 val try_push : 'a t -> 'a -> bool
-(** [try_push q x] tries to push into [q], in which case
-    it returns [true]; or it fails to push and returns [false]
-    without blocking.
-    @raise Closed if the locking succeeded but the queue is closed.
-*)
+(** [try_push q x] tries to push into [q], in which case it returns [true]; or
+    it fails to push and returns [false] without blocking.
+    @raise Closed if the locking succeeded but the queue is closed. *)
 
 val transfer : 'a t -> 'a Queue.t -> unit
-(** [transfer bq q2] transfers all items presently
-    in [bq] into [q2] in one atomic section, and clears [bq].
-    It blocks if no element is in [bq].
-
-    This is useful to consume elements from the queue in batch.
-    Create a [Queue.t] locally:
+(** [transfer bq q2] transfers all items presently in [bq] into [q2] in one
+    atomic section, and clears [bq]. It blocks if no element is in [bq].
 
+    This is useful to consume elements from the queue in batch. Create a
+    [Queue.t] locally:
 
     {[
-    let dowork (work_queue: job Bb_queue.t) =
-      (* local queue, not thread safe *)
-      let local_q = Queue.create() in
-      try
-        while true do
-          (* work on local events, already on this thread *)
-          while not (Queue.is_empty local_q) do
-            let job = Queue.pop local_q in
-            process_job job
-          done;
+      let dowork (work_queue : job Bb_queue.t) =
+        (* local queue, not thread safe *)
+        let local_q = Queue.create () in
+        try
+          while true do
+            (* work on local events, already on this thread *)
+            while not (Queue.is_empty local_q) do
+              let job = Queue.pop local_q in
+              process_job job
+            done;
 
-          (* get all the events in the incoming blocking queue, in
-             one single critical section. *)
-          Bb_queue.transfer work_queue local_q
-        done
-      with Bb_queue.Closed -> ()
+            (* get all the events in the incoming blocking queue, in
+               one single critical section. *)
+            Bb_queue.transfer work_queue local_q
+          done
+        with Bb_queue.Closed -> ()
     ]}
 
     @since 0.4 *)
@@ -69,8 +66,8 @@ type 'a gen = unit -> 'a option
 type 'a iter = ('a -> unit) -> unit
 
 val to_iter : 'a t -> 'a iter
-(** [to_iter q] returns an iterator over all items in the queue.
-    This might not terminate if [q] is never closed.
+(** [to_iter q] returns an iterator over all items in the queue. This might not
+    terminate if [q] is never closed.
     @since 0.4 *)
 
 val to_gen : 'a t -> 'a gen

src/core/bounded_queue.ml

@@ -1,182 +0,0 @@
-type 'a t = {
-  max_size: int;
-  q: 'a Queue.t;
-  mutex: Mutex.t;
-  cond_push: Condition.t;
-  cond_pop: Condition.t;
-  mutable closed: bool;
-}
-
-exception Closed
-
-let create ~max_size () : _ t =
-  if max_size < 1 then invalid_arg "Bounded_queue.create";
-  {
-    max_size;
-    mutex = Mutex.create ();
-    cond_push = Condition.create ();
-    cond_pop = Condition.create ();
-    q = Queue.create ();
-    closed = false;
-  }
-
-let close (self : _ t) =
-  Mutex.lock self.mutex;
-  if not self.closed then (
-    self.closed <- true;
-    (* awake waiters so they fail *)
-    Condition.broadcast self.cond_push;
-    Condition.broadcast self.cond_pop
-  );
-  Mutex.unlock self.mutex
-
-(** Check if the queue is full. Precondition: [self.mutex] is acquired. *)
-let[@inline] is_full_ (self : _ t) : bool = Queue.length self.q >= self.max_size
-
-let push (self : _ t) x : unit =
-  let continue = ref true in
-  Mutex.lock self.mutex;
-  while !continue do
-    if self.closed then (
-      (* push always fails on a closed queue *)
-      Mutex.unlock self.mutex;
-      raise Closed
-    ) else if is_full_ self then
-      Condition.wait self.cond_push self.mutex
-    else (
-      let was_empty = Queue.is_empty self.q in
-      Queue.push x self.q;
-      if was_empty then Condition.broadcast self.cond_pop;
-
-      (* exit loop *)
-      continue := false;
-      Mutex.unlock self.mutex
-    )
-  done
-
-let pop (self : 'a t) : 'a =
-  Mutex.lock self.mutex;
-  let rec loop () =
-    if Queue.is_empty self.q then (
-      if self.closed then (
-        (* pop fails on a closed queue if it's also empty,
-           otherwise it still returns the remaining elements *)
-        Mutex.unlock self.mutex;
-        raise Closed
-      );
-
-      Condition.wait self.cond_pop self.mutex;
-      (loop [@tailcall]) ()
-    ) else (
-      let was_full = is_full_ self in
-      let x = Queue.pop self.q in
-      (* wakeup pushers that were blocked *)
-      if was_full then Condition.broadcast self.cond_push;
-      Mutex.unlock self.mutex;
-      x
-    )
-  in
-  loop ()
-
-let try_pop ~force_lock (self : _ t) : _ option =
-  let has_lock =
-    if force_lock then (
-      Mutex.lock self.mutex;
-      true
-    ) else
-      Mutex.try_lock self.mutex
-  in
-  if has_lock then (
-    if self.closed then (
-      Mutex.unlock self.mutex;
-      raise Closed
-    );
-    let was_full_before_pop = is_full_ self in
-    match Queue.pop self.q with
-    | x ->
-      (* wakeup pushers that are blocked *)
-      if was_full_before_pop then Condition.broadcast self.cond_push;
-      Mutex.unlock self.mutex;
-      Some x
-    | exception Queue.Empty ->
-      Mutex.unlock self.mutex;
-      None
-  ) else
-    None
-
-let try_push ~force_lock (self : _ t) x : bool =
-  let has_lock =
-    if force_lock then (
-      Mutex.lock self.mutex;
-      true
-    ) else
-      Mutex.try_lock self.mutex
-  in
-  if has_lock then (
-    if self.closed then (
-      Mutex.unlock self.mutex;
-      raise Closed
-    );
-
-    if is_full_ self then (
-      Mutex.unlock self.mutex;
-      false
-    ) else (
-      let was_empty = Queue.is_empty self.q in
-      Queue.push x self.q;
-      if was_empty then Condition.broadcast self.cond_pop;
-      Mutex.unlock self.mutex;
-      true
-    )
-  ) else
-    false
-
-let[@inline] max_size self = self.max_size
-
-let size (self : _ t) : int =
-  Mutex.lock self.mutex;
-  let n = Queue.length self.q in
-  Mutex.unlock self.mutex;
-  n
-
-let transfer (self : 'a t) q2 : unit =
-  Mutex.lock self.mutex;
-  let continue = ref true in
-  while !continue do
-    if Queue.is_empty self.q then (
-      if self.closed then (
-        Mutex.unlock self.mutex;
-        raise Closed
-      );
-      Condition.wait self.cond_pop self.mutex
-    ) else (
-      let was_full = is_full_ self in
-      Queue.transfer self.q q2;
-      if was_full then Condition.broadcast self.cond_push;
-      continue := false;
-      Mutex.unlock self.mutex
-    )
-  done
-
-type 'a gen = unit -> 'a option
-type 'a iter = ('a -> unit) -> unit
-
-let to_iter self k =
-  try
-    while true do
-      let x = pop self in
-      k x
-    done
-  with Closed -> ()
-
-let to_gen self : _ gen =
- fun () ->
-  match pop self with
-  | exception Closed -> None
-  | x -> Some x
-
-let rec to_seq self : _ Seq.t =
- fun () ->
-  match pop self with
-  | exception Closed -> Seq.Nil
-  | x -> Seq.Cons (x, to_seq self)

src/core/bounded_queue.mli

@@ -1,86 +0,0 @@
-(** A blocking queue of finite size.
-
-    This queue, while still using locks underneath
-    (like the regular blocking queue) should be enough for
-    usage under reasonable contention.
-
-    The bounded size is helpful whenever some form of backpressure is
-    desirable: if the queue is used to communicate between producer(s)
-    and consumer(s), the consumer(s) can limit the rate at which
-    producer(s) send new work down their way.
-    Whenever the queue is full, means that producer(s) will have to
-    wait before pushing new work.
-
-    @since 0.4 *)
-
-type 'a t
-(** A bounded queue. *)
-
-val create : max_size:int -> unit -> 'a t
-
-val close : _ t -> unit
-(** [close q] closes [q]. No new elements can be pushed into [q],
-    and after all the elements still in [q] currently are [pop]'d,
-    {!pop} will also raise {!Closed}. *)
-
-exception Closed
-
-val push : 'a t -> 'a -> unit
-(** [push q x] pushes [x] at the end of the queue.
-    If [q] is full, this will block until there is
-    room for [x].
-    @raise Closed if [q] is closed. *)
-
-val try_push : force_lock:bool -> 'a t -> 'a -> bool
-(** [try_push q x] attempts to push [x] into [q], but abandons
-    if it cannot acquire [q] or if [q] is full.
-
-    @param force_lock if true, use {!Mutex.lock} (which can block
-      under contention);
-      if false, use {!Mutex.try_lock}, which might return [false] even
-      if there's room in the queue.
-
-    @raise Closed if [q] is closed. *)
-
-val pop : 'a t -> 'a
-(** [pop q] pops the first element off [q]. It blocks if [q]
-    is empty, until some element becomes available.
-    @raise Closed if [q] is empty and closed. *)
-
-val try_pop : force_lock:bool -> 'a t -> 'a option
-(** [try_pop ~force_lock q] tries to pop the first element, or returns [None]
-    if no element is available or if it failed to acquire [q].
-
-    @param force_lock if true, use {!Mutex.lock} (which can block
-      under contention);
-      if false, use {!Mutex.try_lock}, which might return [None] even in
-      presence of an element if there's contention.
-
-    @raise Closed if [q] is empty and closed. *)
-
-val size : _ t -> int
-(** Number of elements currently in [q] *)
-
-val max_size : _ t -> int
-(** Maximum size of the queue. See {!create}. *)
-
-val transfer : 'a t -> 'a Queue.t -> unit
-(** [transfer bq q2] transfers all elements currently available
-    in [bq] into local queue [q2], and clears [bq], atomically.
-    It blocks if [bq] is empty.
-
-    See {!Bb_queue.transfer} for more details.
-    @raise Closed if [bq] is empty and closed. *)
-
-type 'a gen = unit -> 'a option
-type 'a iter = ('a -> unit) -> unit
-
-val to_iter : 'a t -> 'a iter
-(** [to_iter q] returns an iterator over all items in the queue.
-    This might not terminate if [q] is never closed. *)
-
-val to_gen : 'a t -> 'a gen
-(** [to_gen q] returns a generator from the queue. *)
-
-val to_seq : 'a t -> 'a Seq.t
-(** [to_gen q] returns a (transient) sequence from the queue. *)

src/core/chan.ml

@@ -21,7 +21,6 @@ let create ~max_size () : _ t =
   }
 
 let try_push (self : _ t) x : bool =
-  let res = ref false in
   if Mutex.try_lock self.mutex then (
     if self.closed then (
       Mutex.unlock self.mutex;
@@ -33,44 +32,46 @@ let try_push (self : _ t) x : bool =
       let to_awake = Queue.create () in
       Queue.push x self.q;
       Queue.transfer self.pop_waiters to_awake;
-      res := true;
       Mutex.unlock self.mutex;
       (* wake up pop triggers if needed. Be careful to do that
          outside the critical section*)
-      Queue.iter Trigger.signal to_awake
+      Queue.iter Trigger.signal to_awake;
+      true
     | n when n < self.max_size ->
       Queue.push x self.q;
-      Mutex.unlock self.mutex
-    | _ -> Mutex.unlock self.mutex
-  );
-  !res
+      Mutex.unlock self.mutex;
+      true
+    | _ ->
+      Mutex.unlock self.mutex;
+      false
+  ) else
+    false
 
 let try_pop (type elt) self : elt option =
-  let res = ref None in
   if Mutex.try_lock self.mutex then (
-    (match Queue.pop self.q with
+    match Queue.pop self.q with
     | exception Queue.Empty ->
-      if self.closed then (
-        Mutex.unlock self.mutex;
+      Mutex.unlock self.mutex;
+      if self.closed then
         raise Closed
-      )
-    | x -> res := Some x);
-    Mutex.unlock self.mutex
-  );
-  !res
+      else
+        None
+    | x ->
+      Mutex.unlock self.mutex;
+      Some x
+  ) else
+    None
 
 let close (self : _ t) : unit =
-  let q = Queue.create () in
+  let triggers_to_signal = Queue.create () in
   Mutex.lock self.mutex;
   if not self.closed then (
     self.closed <- true;
-    Queue.transfer self.pop_waiters q;
-    Queue.transfer self.push_waiters q
+    Queue.transfer self.pop_waiters triggers_to_signal;
+    Queue.transfer self.push_waiters triggers_to_signal
   );
   Mutex.unlock self.mutex;
-  Queue.iter Trigger.signal q
-
-[@@@ifge 5.0]
+  Queue.iter Trigger.signal triggers_to_signal
 
 let rec push (self : _ t) x : unit =
   Mutex.lock self.mutex;
@@ -120,5 +121,3 @@ let rec pop (self : 'a t) : 'a =
     Mutex.unlock self.mutex;
     Trigger.await_exn tr;
     pop self
-
-[@@@endif]

src/core/chan.mli

@@ -1,9 +1,10 @@
 (** Channels.
 
-    The channels have bounded size. Push/pop return futures or can use effects
-    to provide an [await]-friendly version.
+    The channels have bounded size. They use effects/await to provide
+    a direct style implementation. Pushing into a full channel,
+    or popping from an empty one, will suspend the current task.
 
-    The channels became bounded since @NEXT_RELEASE .
+    The channels became bounded since @0.7 .
 *)
 
 type 'a t
@@ -15,33 +16,30 @@ val create : max_size:int -> unit -> 'a t
 exception Closed
 
 val try_push : 'a t -> 'a -> bool
-(** [try_push chan x] pushes [x] into [chan]. This does not block.
-    Returns [true] if it succeeded in pushing.
+(** [try_push chan x] pushes [x] into [chan]. This does not block. Returns
+    [true] if it succeeded in pushing.
     @raise Closed if the channel is closed. *)
 
 val try_pop : 'a t -> 'a option
-(** [try_pop chan] pops and return an element if one is available
-    immediately. Otherwise it returns [None].
-    @raise Closed if the channel is closed and empty.
-    *)
+(** [try_pop chan] pops and return an element if one is available immediately.
+    Otherwise it returns [None].
+    @raise Closed if the channel is closed and empty. *)
 
 val close : _ t -> unit
-(** Close the channel. Further push and pop calls will fail.
-    This is idempotent. *)
-
-[@@@ifge 5.0]
+(** Close the channel. Further push and pop calls will fail. This is idempotent.
+*)
 
 val push : 'a t -> 'a -> unit
-(** Push the value into the channel, suspending the current task
-    if the channel is currently full.
+(** Push the value into the channel, suspending the current task if the channel
+    is currently full.
     @raise Closed if the channel is closed
-    @since NEXT_RELEASE *)
+    @since 0.7 *)
 
 val pop : 'a t -> 'a
-(** Pop an element. This might suspend the current task if the
-    channel is currently empty.
+(** Pop an element. This might suspend the current task if the channel is
+    currently empty.
     @raise Closed if the channel is empty and closed.
-    @since NEXT_RELEASE *)
+    @since 0.7 *)
 
 (*
 val pop_block_exn : 'a t -> 'a
@@ -49,5 +47,3 @@ val pop_block_exn : 'a t -> 'a
     The precautions around blocking from inside a thread pool
     are the same as explained in {!Fut.wait_block}. *)
 *)
-
-[@@@endif]

src/core/dune

@@ -12,7 +12,4 @@
   moonpool.dpool
   (re_export picos))
  (flags :standard -open Moonpool_private)
- (private_modules util_pool_)
- (preprocess
-  (action
-   (run %{project_root}/src/cpp/cpp.exe %{input-file}))))
+ (private_modules util_pool_))

src/core/exn_bt.ml

@@ -3,7 +3,15 @@ type t = exn * Printexc.raw_backtrace
 let[@inline] make exn bt : t = exn, bt
 let[@inline] exn (e, _) = e
 let[@inline] bt (_, bt) = bt
-let show self = Printexc.to_string (exn self)
+
+let show self =
+  let bt = Printexc.raw_backtrace_to_string (bt self) in
+  let exn = Printexc.to_string (exn self) in
+  if bt = "" then
+    exn
+  else
+    Printf.sprintf "%s\n%s" exn bt
+
 let pp out self = Format.pp_print_string out (show self)
 let[@inline] raise (e, bt) = Printexc.raise_with_backtrace e bt
 

src/core/fifo_pool.ml

@@ -10,7 +10,6 @@ let ( let@ ) = ( @@ )
 type state = {
   threads: Thread.t array;
   q: task_full Bb_queue.t;  (** Queue for tasks. *)
-  around_task: WL.around_task;
   mutable as_runner: t;
   (* init options *)
   name: string option;
@@ -28,7 +27,6 @@ type worker_state = {
 
 let[@inline] size_ (self : state) = Array.length self.threads
 let[@inline] num_tasks_ (self : state) : int = Bb_queue.size self.q
-let k_worker_state : worker_state TLS.t = TLS.create ()
 
 (*
 get_thread_state = TLS.get_opt k_worker_state
@@ -44,13 +42,10 @@ type ('a, 'b) create_args =
   ?on_init_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exit_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exn:(exn -> Printexc.raw_backtrace -> unit) ->
-  ?around_task:(t -> 'b) * (t -> 'b -> unit) ->
   ?num_threads:int ->
   ?name:string ->
   'a
 
-let default_around_task_ : WL.around_task = AT_pair (ignore, fun _ _ -> ())
-
 (** Run [task] as is, on the pool. *)
 let schedule_ (self : state) (task : task_full) : unit =
   try Bb_queue.push self.q task with Bb_queue.Closed -> raise Shutdown
@@ -71,12 +66,6 @@ let schedule_w (self : worker_state) (task : task_full) : unit =
 let get_next_task (self : worker_state) =
   try Bb_queue.pop self.st.q with Bb_queue.Closed -> raise WL.No_more_tasks
 
-let get_thread_state () =
-  match TLS.get_exn k_worker_state with
-  | st -> st
-  | exception TLS.Not_set ->
-    failwith "Moonpool: get_thread_state called from outside a runner."
-
 let before_start (self : worker_state) =
   let t_id = Thread.id @@ Thread.self () in
   self.st.on_init_thread ~dom_id:self.dom_idx ~t_id ();
@@ -95,7 +84,6 @@ let cleanup (self : worker_state) : unit =
 
 let worker_ops : worker_state WL.ops =
   let runner (st : worker_state) = st.st.as_runner in
-  let around_task st = st.st.around_task in
   let on_exn (st : worker_state) (ebt : Exn_bt.t) =
     st.st.on_exn (Exn_bt.exn ebt) (Exn_bt.bt ebt)
   in
@@ -103,8 +91,6 @@ let worker_ops : worker_state WL.ops =
     WL.schedule = schedule_w;
     runner;
     get_next_task;
-    get_thread_state;
-    around_task;
     on_exn;
     before_start;
     cleanup;
@@ -112,19 +98,11 @@ let worker_ops : worker_state WL.ops =
 
 let create_ ?(on_init_thread = default_thread_init_exit_)
     ?(on_exit_thread = default_thread_init_exit_) ?(on_exn = fun _ _ -> ())
-    ?around_task ~threads ?name () : state =
-  (* wrapper *)
-  let around_task =
-    match around_task with
-    | Some (f, g) -> WL.AT_pair (f, g)
-    | None -> default_around_task_
-  in
-
+    ~threads ?name () : state =
   let self =
     {
       threads;
       q = Bb_queue.create ();
-      around_task;
       as_runner = Runner.dummy;
       name;
       on_init_thread;
@@ -135,8 +113,7 @@ let create_ ?(on_init_thread = default_thread_init_exit_)
   self.as_runner <- runner_of_state self;
   self
 
-let create ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?num_threads
-    ?name () : t =
+let create ?on_init_thread ?on_exit_thread ?on_exn ?num_threads ?name () : t =
   let num_domains = Domain_pool_.max_number_of_domains () in
 
   (* number of threads to run *)
@@ -148,8 +125,7 @@ let create ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?num_threads
   let pool =
     let dummy_thread = Thread.self () in
     let threads = Array.make num_threads dummy_thread in
-    create_ ?on_init_thread ?on_exit_thread ?on_exn ?around_task ~threads ?name
-      ()
+    create_ ?on_init_thread ?on_exit_thread ?on_exn ~threads ?name ()
   in
   let runner = runner_of_state pool in
 
@@ -165,7 +141,9 @@ let create ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?num_threads
        create the thread and push it into [receive_threads] *)
     let create_thread_in_domain () =
       let st = { idx = i; dom_idx; st = pool } in
-      let thread = Thread.create (WL.worker_loop ~ops:worker_ops) st in
+      let thread =
+        Thread.create (WL.worker_loop ~block_signals:true ~ops:worker_ops) st
+      in
       (* send the thread from the domain back to us *)
       Bb_queue.push receive_threads (i, thread)
     in
@@ -187,11 +165,9 @@ let create ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?num_threads
 
   runner
 
-let with_ ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?num_threads
-    ?name () f =
+let with_ ?on_init_thread ?on_exit_thread ?on_exn ?num_threads ?name () f =
   let pool =
-    create ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?num_threads
-      ?name ()
+    create ?on_init_thread ?on_exit_thread ?on_exn ?num_threads ?name ()
   in
   let@ () = Fun.protect ~finally:(fun () -> shutdown pool) in
   f pool

src/core/fifo_pool.mli

@@ -1,16 +1,16 @@
 (** A simple thread pool in FIFO order.
 
-    FIFO: first-in, first-out. Basically tasks are put into a queue,
-    and worker threads pull them out of the queue at the other end.
+    FIFO: first-in, first-out. Basically tasks are put into a queue, and worker
+    threads pull them out of the queue at the other end.
 
-    Since this uses a single blocking queue to manage tasks, it's very
-    simple and reliable. The number of worker threads is fixed, but
-    they are spread over several domains to enable parallelism.
+    Since this uses a single blocking queue to manage tasks, it's very simple
+    and reliable. The number of worker threads is fixed, but they are spread
+    over several domains to enable parallelism.
 
-    This can be useful for latency-sensitive applications (e.g. as a
-    pool of workers for network servers). Work-stealing pools might
-    have higher throughput but they're very unfair to some tasks; by
-    contrast, here, older tasks have priority over younger tasks.
+    This can be useful for latency-sensitive applications (e.g. as a pool of
+    workers for network servers). Work-stealing pools might have higher
+    throughput but they're very unfair to some tasks; by contrast, here, older
+    tasks have priority over younger tasks.
 
     @since 0.5 *)
 
@@ -20,7 +20,6 @@ type ('a, 'b) create_args =
   ?on_init_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exit_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exn:(exn -> Printexc.raw_backtrace -> unit) ->
-  ?around_task:(t -> 'b) * (t -> 'b -> unit) ->
   ?num_threads:int ->
   ?name:string ->
   'a
@@ -28,22 +27,19 @@ type ('a, 'b) create_args =
 
 val create : (unit -> t, _) create_args
 (** [create ()] makes a new thread pool.
-     @param on_init_thread called at the beginning of each new thread in the pool.
-     @param min minimum size of the pool. See {!Pool.create_args}.
-      The default is [Domain.recommended_domain_count()], ie one worker per
-      CPU core.
-      On OCaml 4 the default is [4] (since there is only one domain).
-     @param on_exit_thread called at the end of each worker thread in the pool.
-     @param around_task a pair of [before, after] functions
-     ran around each task. See {!Pool.create_args}.
-     @param name name for the pool, used in tracing (since 0.6)
-  *)
+    @param on_init_thread
+      called at the beginning of each new thread in the pool.
+    @param min
+      minimum size of the pool. See {!Pool.create_args}. The default is
+      [Domain.recommended_domain_count()], ie one worker per CPU core. On OCaml
+      4 the default is [4] (since there is only one domain).
+    @param on_exit_thread called at the end of each worker thread in the pool.
+    @param name name for the pool, used in tracing (since 0.6) *)
 
 val with_ : (unit -> (t -> 'a) -> 'a, _) create_args
-(** [with_ () f] calls [f pool], where [pool] is obtained via {!create}.
-    When [f pool] returns or fails, [pool] is shutdown and its resources
-    are released.
-    Most parameters are the same as in {!create}. *)
+(** [with_ () f] calls [f pool], where [pool] is obtained via {!create}. When
+    [f pool] returns or fails, [pool] is shutdown and its resources are
+    released. Most parameters are the same as in {!create}. *)
 
 (**/**)
 

src/core/fut.ml

@@ -1,25 +1,27 @@
-module A = Atomic_
+module A = Atomic
 module C = Picos.Computation
 
 type 'a or_error = ('a, Exn_bt.t) result
 type 'a waiter = 'a or_error -> unit
-type 'a t = { st: 'a C.t } [@@unboxed]
+type 'a t = 'a C.t
 type 'a promise = 'a t
 
-let[@inline] make_ () : _ t =
-  let fut = { st = C.create ~mode:`LIFO () } in
+let[@inline] make_promise () : _ t =
+  let fut = C.create ~mode:`LIFO () in
   fut
 
 let make () =
-  let fut = make_ () in
+  let fut = make_promise () in
   fut, fut
 
-let[@inline] return x : _ t = { st = C.returned x }
+let[@inline] return x : _ t = C.returned x
+let[@inline] cancel x ebt = C.cancel x (fst ebt) (snd ebt)
+let[@inline] try_cancel x ebt = C.try_cancel x (fst ebt) (snd ebt)
 
 let[@inline] fail exn bt : _ t =
-  let st = C.create () in
-  C.cancel st exn bt;
-  { st }
+  let fut = C.create () in
+  C.cancel fut exn bt;
+  fut
 
 let[@inline] fail_exn_bt ebt = fail (Exn_bt.exn ebt) (Exn_bt.bt ebt)
 
@@ -27,32 +29,32 @@ let[@inline] of_result = function
   | Ok x -> return x
   | Error ebt -> fail_exn_bt ebt
 
-let[@inline] is_resolved self : bool = not (C.is_running self.st)
+let[@inline] is_resolved self : bool = not (C.is_running self)
 let is_done = is_resolved
-let[@inline] peek self : _ option = C.peek self.st
-let[@inline] raise_if_failed self : unit = C.check self.st
+let peek : 'a t -> _ option = C.peek
+let raise_if_failed : _ t -> unit = C.check
 
 let[@inline] is_success self =
-  match C.peek_exn self.st with
+  match C.peek_exn self with
   | _ -> true
   | exception _ -> false
 
-let[@inline] is_failed self = C.is_canceled self.st
+let is_failed : _ t -> bool = C.is_canceled
 
 exception Not_ready
 
 let[@inline] get_or_fail self =
-  match C.peek self.st with
+  match C.peek self with
   | Some x -> x
   | None -> raise Not_ready
 
 let[@inline] get_or_fail_exn self =
-  match C.peek_exn self.st with
+  match C.peek_exn self with
   | x -> x
   | exception C.Running -> raise Not_ready
 
 let[@inline] peek_or_assert_ (self : 'a t) : 'a =
-  match C.peek_exn self.st with
+  match C.peek_exn self with
   | x -> x
   | exception C.Running -> assert false
 
@@ -67,47 +69,47 @@ let on_result (self : _ t) (f : _ waiter) : unit =
   let trigger =
     (Trigger.from_action f self on_result_cb_ [@alert "-handler"])
   in
-  if not (C.try_attach self.st trigger) then on_result_cb_ () f self
+  if not (C.try_attach self trigger) then on_result_cb_ () f self
 
 let on_result_ignore_cb_ _tr f (self : _ t) =
-  f (Picos.Computation.canceled self.st)
+  f (Picos.Computation.canceled self)
 
 let on_result_ignore (self : _ t) f : unit =
-  if Picos.Computation.is_running self.st then (
+  if Picos.Computation.is_running self then (
     let trigger =
       (Trigger.from_action f self on_result_ignore_cb_ [@alert "-handler"])
     in
-    if not (C.try_attach self.st trigger) then on_result_ignore_cb_ () f self
+    if not (C.try_attach self trigger) then on_result_ignore_cb_ () f self
   ) else
     on_result_ignore_cb_ () f self
 
 let[@inline] fulfill_idempotent self r =
   match r with
-  | Ok x -> C.return self.st x
-  | Error ebt -> C.cancel self.st (Exn_bt.exn ebt) (Exn_bt.bt ebt)
+  | Ok x -> C.return self x
+  | Error ebt -> C.cancel self (Exn_bt.exn ebt) (Exn_bt.bt ebt)
 
 exception Already_fulfilled
 
 let fulfill (self : _ t) (r : _ result) : unit =
   let ok =
     match r with
-    | Ok x -> C.try_return self.st x
-    | Error ebt -> C.try_cancel self.st (Exn_bt.exn ebt) (Exn_bt.bt ebt)
+    | Ok x -> C.try_return self x
+    | Error ebt -> C.try_cancel self (Exn_bt.exn ebt) (Exn_bt.bt ebt)
   in
   if not ok then raise Already_fulfilled
 
 (* ### combinators ### *)
 
 let spawn ~on f : _ t =
-  let fut = make_ () in
+  let fut = make_promise () in
 
   let task () =
     try
       let res = f () in
-      C.return fut.st res
+      C.return fut res
     with exn ->
       let bt = Printexc.get_raw_backtrace () in
-      C.cancel fut.st exn bt
+      C.cancel fut exn bt
   in
 
   Runner.run_async on task;
@@ -122,7 +124,7 @@ let reify_error (f : 'a t) : 'a or_error t =
   match peek f with
   | Some res -> return res
   | None ->
-    let fut = make_ () in
+    let fut = make_promise () in
     on_result f (fun r -> fulfill fut (Ok r));
     fut
 
@@ -380,7 +382,7 @@ let for_list ~on l f : unit t =
 let push_queue_ _tr q () = Bb_queue.push q ()
 
 let wait_block_exn (self : 'a t) : 'a =
-  match C.peek_exn self.st with
+  match C.peek_exn self with
   | x -> x (* fast path *)
   | exception C.Running ->
     let real_block () =
@@ -394,7 +396,7 @@ let wait_block_exn (self : 'a t) : 'a =
       assert attached;
 
       (* blockingly wait for trigger if computation didn't complete in the mean time *)
-      if C.try_attach self.st trigger then Bb_queue.pop q;
+      if C.try_attach self trigger then Bb_queue.pop q;
 
       (* trigger was signaled! computation must be done*)
       peek_or_assert_ self
@@ -406,7 +408,7 @@ let wait_block_exn (self : 'a t) : 'a =
       if i = 0 then
         real_block ()
       else (
-        match C.peek_exn self.st with
+        match C.peek_exn self with
         | x -> x
         | exception C.Running ->
           Domain_.relax ();
@@ -422,22 +424,19 @@ let wait_block self =
     let bt = Printexc.get_raw_backtrace () in
     Error (Exn_bt.make exn bt)
 
-[@@@ifge 5.0]
-
 let await (self : 'a t) : 'a =
   (* fast path: peek *)
-  match C.peek_exn self.st with
+  match C.peek_exn self with
   | res -> res
   | exception C.Running ->
     let trigger = Trigger.create () in
     (* suspend until the future is resolved *)
-    if C.try_attach self.st trigger then
-      Option.iter Exn_bt.raise @@ Trigger.await trigger;
+    if C.try_attach self trigger then Trigger.await_exn trigger;
 
     (* un-suspended: we should have a result! *)
     get_or_fail_exn self
 
-[@@@endif]
+let yield = Picos.Fiber.yield
 
 module Infix = struct
   let[@inline] ( >|= ) x f = map ~f x
@@ -453,5 +452,5 @@ module Infix_local = Infix [@@deprecated "use Infix"]
 
 module Private_ = struct
   let[@inline] unsafe_promise_of_fut x = x
-  let[@inline] as_computation self = self.st
+  let[@inline] as_computation self = self
 end

src/core/fut.mli

@@ -1,55 +1,81 @@
 (** Futures.
 
-    A future of type ['a t] represents the result of a computation
-    that will yield a value of type ['a].
+    A future of type ['a t] represents the result of a computation that will
+    yield a value of type ['a].
 
-    Typically, the computation is running on a thread pool {!Runner.t}
-    and will proceed on some worker. Once set, a future cannot change.
-    It either succeeds (storing a [Ok x] with [x: 'a]), or fail
-    (storing a [Error (exn, bt)] with an exception and the corresponding
-    backtrace).
+    Typically, the computation is running on a thread pool {!Runner.t} and will
+    proceed on some worker. Once set, a future cannot change. It either succeeds
+    (storing a [Ok x] with [x: 'a]), or fail (storing a [Error (exn, bt)] with
+    an exception and the corresponding backtrace).
 
-    Combinators such as {!map} and {!join_array} can be used to produce
-    futures from other futures (in a monadic way). Some combinators take
-    a [on] argument to specify a runner on which the intermediate computation takes
-    place; for example [map ~on:pool ~f fut] maps the value in [fut]
-    using function [f], applicatively; the call to [f] happens on
-    the runner [pool] (once [fut] resolves successfully with a value).
-*)
+    Using {!spawn}, it's possible to start a bunch of tasks, obtaining futures,
+    and then use {!await} to get their result in the desired order.
+
+    Combinators such as {!map} and {!join_array} can be used to produce futures
+    from other futures (in a monadic way). Some combinators take a [on] argument
+    to specify a runner on which the intermediate computation takes place; for
+    example [map ~on:pool ~f fut] maps the value in [fut] using function [f],
+    applicatively; the call to [f] happens on the runner [pool] (once [fut]
+    resolves successfully with a value). Be aware that these combinators do not
+    preserve local storage. *)
 
 type 'a or_error = ('a, Exn_bt.t) result
 
-type 'a t
+type 'a t = 'a Picos.Computation.t
 (** A future with a result of type ['a]. *)
 
-type 'a promise
-(** A promise, which can be fulfilled exactly once to set
-      the corresponding future *)
+type 'a promise = private 'a t
+(** A promise, which can be fulfilled exactly once to set the corresponding
+    future. This is a private alias of ['a t] since 0.7, previously it was
+    opaque. *)
 
 val make : unit -> 'a t * 'a promise
 (** Make a new future with the associated promise. *)
 
+val make_promise : unit -> 'a promise
+(** Same as {!make} but returns a single promise (which can be upcast to a
+    future). This is useful mostly to preserve memory, you probably don't need
+    it.
+
+    How to upcast to a future in the worst case:
+    {[
+      let prom = Fut.make_promise ()
+      let fut = (prom : _ Fut.promise :> _ Fut.t)
+    ]}
+    @since 0.7 *)
+
 val on_result : 'a t -> ('a or_error -> unit) -> unit
-(** [on_result fut f] registers [f] to be called in the future
-      when [fut] is set ;
-      or calls [f] immediately if [fut] is already set. *)
+(** [on_result fut f] registers [f] to be called in the future when [fut] is
+    set; or calls [f] immediately if [fut] is already set.
+
+    {b NOTE:} it's ill advised to do meaningful work inside the callback [f].
+    Instead, try to spawn another task on the runner, or use {!await}. *)
 
 val on_result_ignore : _ t -> (Exn_bt.t option -> unit) -> unit
-(** [on_result_ignore fut f] registers [f] to be called in the future
-    when [fut] is set;
-    or calls [f] immediately if [fut] is already set.
-    It does not pass the result, only a success/error signal.
+(** [on_result_ignore fut f] registers [f] to be called in the future when [fut]
+    is set; or calls [f] immediately if [fut] is already set. It does not pass
+    the result, only a success/error signal.
     @since 0.7 *)
 
 exception Already_fulfilled
 
+val try_cancel : _ promise -> Exn_bt.t -> bool
+(** [try_cancel promise ebt] tries to cancel the promise using the given
+    exception, returning [true]. It returns [false] if the promise is already
+    resolved.
+    @since 0.9 *)
+
+val cancel : _ promise -> Exn_bt.t -> unit
+(** Silent version of {!try_cancel}, ignoring the result.
+    @since 0.9 *)
+
 val fulfill : 'a promise -> 'a or_error -> unit
 (** Fullfill the promise, setting the future at the same time.
-      @raise Already_fulfilled if the promise is already fulfilled. *)
+    @raise Already_fulfilled if the promise is already fulfilled. *)
 
 val fulfill_idempotent : 'a promise -> 'a or_error -> unit
-(** Fullfill the promise, setting the future at the same time.
-      Does nothing if the promise is already fulfilled. *)
+(** Fullfill the promise, setting the future at the same time. Does nothing if
+    the promise is already fulfilled. *)
 
 val return : 'a -> 'a t
 (** Already settled future, with a result *)
@@ -62,27 +88,28 @@ val fail_exn_bt : Exn_bt.t -> _ t
     @since 0.6 *)
 
 val of_result : 'a or_error -> 'a t
+(** Already resolved future from a result. *)
 
 val is_resolved : _ t -> bool
 (** [is_resolved fut] is [true] iff [fut] is resolved. *)
 
 val peek : 'a t -> 'a or_error option
-(** [peek fut] returns [Some r] if [fut] is currently resolved with [r],
-      and [None] if [fut] is not resolved yet. *)
+(** [peek fut] returns [Some r] if [fut] is currently resolved with [r], and
+    [None] if [fut] is not resolved yet. *)
 
 exception Not_ready
 (** @since 0.2 *)
 
 val get_or_fail : 'a t -> 'a or_error
-(** [get_or_fail fut] obtains the result from [fut] if it's fulfilled
-    (i.e. if [peek fut] returns [Some res], [get_or_fail fut] returns [res]).
+(** [get_or_fail fut] obtains the result from [fut] if it's fulfilled (i.e. if
+    [peek fut] returns [Some res], [get_or_fail fut] returns [res]).
     @raise Not_ready if the future is not ready.
     @since 0.2 *)
 
 val get_or_fail_exn : 'a t -> 'a
-(** [get_or_fail_exn fut] obtains the result from [fut] if it's fulfilled,
-    like {!get_or_fail}. If the result is an [Error _], the exception inside
-    is re-raised.
+(** [get_or_fail_exn fut] obtains the result from [fut] if it's fulfilled, like
+    {!get_or_fail}. If the result is an [Error _], the exception inside is
+    re-raised.
     @raise Not_ready if the future is not ready.
     @since 0.2 *)
 
@@ -105,12 +132,12 @@ val raise_if_failed : _ t -> unit
 (** {2 Combinators} *)
 
 val spawn : on:Runner.t -> (unit -> 'a) -> 'a t
-(** [spaw ~on f] runs [f()] on the given runner [on], and return a future that will
-      hold its result. *)
+(** [spaw ~on f] runs [f()] on the given runner [on], and return a future that
+    will hold its result. *)
 
 val spawn_on_current_runner : (unit -> 'a) -> 'a t
-(** This must be run from inside a runner, and schedules
-    the new task on it as well.
+(** This must be run from inside a runner, and schedules the new task on it as
+    well.
 
     See {!Runner.get_current_runner} to see how the runner is found.
 
@@ -118,28 +145,32 @@ val spawn_on_current_runner : (unit -> 'a) -> 'a t
     @raise Failure if run from outside a runner. *)
 
 val reify_error : 'a t -> 'a or_error t
-(** [reify_error fut] turns a failing future into a non-failing
-    one  that contain [Error (exn, bt)]. A non-failing future
-    returning [x] is turned into [Ok x]
+(** [reify_error fut] turns a failing future into a non-failing one that contain
+    [Error (exn, bt)]. A non-failing future returning [x] is turned into [Ok x].
     @since 0.4 *)
 
 val map : ?on:Runner.t -> f:('a -> 'b) -> 'a t -> 'b t
-(** [map ?on ~f fut] returns a new future [fut2] that resolves
-      with [f x] if [fut] resolved with [x];
-      and fails with [e] if [fut] fails with [e] or [f x] raises [e].
-      @param on if provided, [f] runs on the given runner *)
+(** [map ?on ~f fut] returns a new future [fut2] that resolves with [f x] if
+    [fut] resolved with [x]; and fails with [e] if [fut] fails with [e] or [f x]
+    raises [e].
+    @param on if provided, [f] runs on the given runner *)
 
 val bind : ?on:Runner.t -> f:('a -> 'b t) -> 'a t -> 'b t
-(** [bind ?on ~f fut] returns a new future [fut2] that resolves
-      like the future [f x] if [fut] resolved with [x];
-    and fails with [e] if [fut] fails with [e] or [f x] raises [e].
-      @param on if provided, [f] runs on the given runner *)
+(** [bind ?on ~f fut] returns a new future [fut2] that resolves like the future
+    [f x] if [fut] resolved with [x]; and fails with [e] if [fut] fails with [e]
+    or [f x] raises [e].
+
+    This does not preserve local storage of [fut] inside [f].
+
+    @param on if provided, [f] runs on the given runner *)
 
 val bind_reify_error : ?on:Runner.t -> f:('a or_error -> 'b t) -> 'a t -> 'b t
-(** [bind_reify_error ?on ~f fut] returns a new future [fut2] that resolves
-      like the future [f (Ok x)] if [fut] resolved with [x];
-      and resolves like the future [f (Error (exn, bt))]
-      if [fut] fails with [exn] and backtrace [bt].
+(** [bind_reify_error ?on ~f fut] returns a new future [fut2] that resolves like
+    the future [f (Ok x)] if [fut] resolved with [x]; and resolves like the
+    future [f (Error (exn, bt))] if [fut] fails with [exn] and backtrace [bt].
+
+    This does not preserve local storage of [fut] inside [f].
+
     @param on if provided, [f] runs on the given runner
     @since 0.4 *)
 
@@ -148,18 +179,18 @@ val join : 'a t t -> 'a t
     @since 0.2 *)
 
 val both : 'a t -> 'b t -> ('a * 'b) t
-(** [both a b] succeeds with [x, y] if [a] succeeds with [x] and
-      [b] succeeds with [y], or fails if any of them fails. *)
+(** [both a b] succeeds with [x, y] if [a] succeeds with [x] and [b] succeeds
+    with [y], or fails if any of them fails. *)
 
 val choose : 'a t -> 'b t -> ('a, 'b) Either.t t
-(** [choose a b] succeeds [Left x] or [Right y] if [a] succeeds with [x] or
-      [b] succeeds with [y], or fails if both of them fails.
-      If they both succeed, it is not specified which result is used. *)
+(** [choose a b] succeeds [Left x] or [Right y] if [a] succeeds with [x] or [b]
+    succeeds with [y], or fails if both of them fails. If they both succeed, it
+    is not specified which result is used. *)
 
 val choose_same : 'a t -> 'a t -> 'a t
-(** [choose_same a b] succeeds with the value of one of [a] or [b] if
-      they succeed, or fails if both fail.
-      If they both succeed, it is not specified which result is used. *)
+(** [choose_same a b] succeeds with the value of one of [a] or [b] if they
+    succeed, or fails if both fail. If they both succeed, it is not specified
+    which result is used. *)
 
 val join_array : 'a t array -> 'a array t
 (** Wait for all the futures in the array. Fails if any future fails. *)
@@ -167,6 +198,7 @@ val join_array : 'a t array -> 'a array t
 val join_list : 'a t list -> 'a list t
 (** Wait for all the futures in the list. Fails if any future fails. *)
 
+(** Advanced primitives for synchronization *)
 module Advanced : sig
   val barrier_on_abstract_container_of_futures :
     iter:(('a t -> unit) -> 'cont -> unit) ->
@@ -174,20 +206,20 @@ module Advanced : sig
     aggregate_results:(('a t -> 'a) -> 'cont -> 'res) ->
     'cont ->
     'res t
-  (** [barrier_on_abstract_container_of_futures ~iter ~aggregate_results ~len cont] takes a
-    container of futures ([cont]), with [len] elements,
-    and returns a future result of type [res]
-    (possibly another type of container).
+  (** [barrier_on_abstract_container_of_futures ~iter ~aggregate_results ~len
+       cont] takes a container of futures ([cont]), with [len] elements, and
+      returns a future result of type [res] (possibly another type of
+      container).
 
-    This waits for all futures in [cont: 'cont] to be done
-    (futures obtained via [iter <some function> cont]). If they
-    all succeed, their results are aggregated into a new
-    result of type ['res] via [aggregate_results <some function> cont].
+      This waits for all futures in [cont: 'cont] to be done (futures obtained
+      via [iter <some function> cont]). If they all succeed, their results are
+      aggregated into a new result of type ['res] via
+      [aggregate_results <some function> cont].
 
-    {b NOTE}: the behavior is not specified if [iter f cont] (for a function f)
-    doesn't call [f] on exactly [len cont] elements.
+      {b NOTE}: the behavior is not specified if [iter f cont] (for a function
+      f) doesn't call [f] on exactly [len cont] elements.
 
-    @since 0.5.1 *)
+      @since 0.5.1 *)
 end
 
 val map_list : f:('a -> 'b t) -> 'a list -> 'b list t
@@ -195,23 +227,22 @@ val map_list : f:('a -> 'b t) -> 'a list -> 'b list t
     @since 0.5.1 *)
 
 val wait_array : _ t array -> unit t
-(** [wait_array arr] waits for all futures in [arr] to resolve. It discards
-    the individual results of futures in [arr]. It fails if any future fails. *)
+(** [wait_array arr] waits for all futures in [arr] to resolve. It discards the
+    individual results of futures in [arr]. It fails if any future fails. *)
 
 val wait_list : _ t list -> unit t
-(** [wait_list l] waits for all futures in [l] to resolve. It discards
-      the individual results of futures in [l]. It fails if any future fails. *)
+(** [wait_list l] waits for all futures in [l] to resolve. It discards the
+    individual results of futures in [l]. It fails if any future fails. *)
 
 val for_ : on:Runner.t -> int -> (int -> unit) -> unit t
-(** [for_ ~on n f] runs [f 0], [f 1], …, [f (n-1)] on the runner, and returns
-      a future that resolves when all the tasks have resolved, or fails
-      as soon as one task has failed. *)
+(** [for_ ~on n f] runs [f 0], [f 1], …, [f (n-1)] on the runner, and returns a
+    future that resolves when all the tasks have resolved, or fails as soon as
+    one task has failed. *)
 
 val for_array : on:Runner.t -> 'a array -> (int -> 'a -> unit) -> unit t
-(** [for_array ~on arr f] runs [f 0 arr.(0)], …, [f (n-1) arr.(n-1)] in
-    the runner (where [n = Array.length arr]), and returns a future
-    that resolves when all the tasks are done,
-    or fails if any of them fails.
+(** [for_array ~on arr f] runs [f 0 arr.(0)], …, [f (n-1) arr.(n-1)] in the
+    runner (where [n = Array.length arr]), and returns a future that resolves
+    when all the tasks are done, or fails if any of them fails.
     @since 0.2 *)
 
 val for_list : on:Runner.t -> 'a list -> ('a -> unit) -> unit t
@@ -220,9 +251,9 @@ val for_list : on:Runner.t -> 'a list -> ('a -> unit) -> unit t
 
 (** {2 Await}
 
-    {b NOTE} This is only available on OCaml 5. *)
-
-[@@@ifge 5.0]
+    This suspends the current task using an OCaml 5 algebraic effect, and makes
+    preparations for the task to be resumed once the future has been resolved.
+*)
 
 val await : 'a t -> 'a
 (** [await fut] suspends the current tasks until [fut] is fulfilled, then
@@ -231,43 +262,44 @@ val await : 'a t -> 'a
 
     @since 0.3
 
-    This must only be run from inside the runner itself. The runner must
-    support {!Suspend_}.
-    {b NOTE}: only on OCaml 5.x
-*)
+    This must only be run from inside the runner itself. The runner must support
+    {!Suspend_}. *)
 
-[@@@endif]
+val yield : unit -> unit
+(** Like {!Moonpool.yield}.
+    @since NEXT_RELEASE *)
 
 (** {2 Blocking} *)
 
 val wait_block : 'a t -> 'a or_error
-(** [wait_block fut] blocks the current thread until [fut] is resolved,
-      and returns its value.
+(** [wait_block fut] blocks the current thread until [fut] is resolved, and
+    returns its value.
 
-      {b NOTE}: A word of warning: this will monopolize the calling thread until the future
-      resolves. This can also easily cause deadlocks, if enough threads in a pool
-      call [wait_block] on futures running on the same pool or a pool depending on it.
+    {b NOTE:} A word of warning: this will monopolize the calling thread until
+    the future resolves. This can also easily cause deadlocks, if enough threads
+    in a pool call [wait_block] on futures running on the same pool or a pool
+    depending on it.
 
-      A good rule to avoid deadlocks is to run this from outside of any pool,
-      or to have an acyclic order between pools where [wait_block]
-      is only called from a pool on futures evaluated in a pool that comes lower
-      in the hierarchy.
-      If this rule is broken, it is possible for all threads in a pool to wait
-      for futures that can only make progress on these same threads,
-      hence the deadlock.
-  *)
+    A good rule to avoid deadlocks is to run this from outside of any pool, or
+    to have an acyclic order between pools where [wait_block] is only called
+    from a pool on futures evaluated in a pool that comes lower in the
+    hierarchy. If this rule is broken, it is possible for all threads in a pool
+    to wait for futures that can only make progress on these same threads, hence
+    the deadlock. *)
 
 val wait_block_exn : 'a t -> 'a
-(** Same as {!wait_block} but re-raises the exception if the future failed. *)
+(** Same as {!wait_block} but re-raises the exception if the future failed.
+
+    {b NOTE:} do check the cautionary note in {!wait_block} concerning
+    deadlocks. *)
 
 (** {2 Infix operators}
 
-    These combinators run on either the current pool (if present),
-    or on the same thread that just fulfilled the previous future
-    if not.
+    These combinators run on either the current pool (if present), or on the
+    same thread that just fulfilled the previous future if not.
 
-    They were previously present as [module Infix_local] and [val infix],
-    but are now simplified.
+    They were previously present as [module Infix_local] and [val infix], but
+    are now simplified.
 
     @since 0.5 *)
 
@@ -291,9 +323,10 @@ module Infix_local = Infix
 
 module Private_ : sig
   val unsafe_promise_of_fut : 'a t -> 'a promise
-  (** please do not use *)
+  (** Do not use unless you know exactly what you are doing. *)
 
   val as_computation : 'a t -> 'a Picos.Computation.t
+  (** Picos compat *)
 end
 
 (**/**)

src/core/hmap_ls_.real.ml

@@ -9,18 +9,22 @@ let k_local_hmap : Hmap.t FLS.t = FLS.create ()
 
 (** Access the local [hmap], or an empty one if not set *)
 let[@inline] get_local_hmap () : Hmap.t =
-  let fiber = get_current_fiber_exn () in
-  FLS.get fiber ~default:Hmap.empty k_local_hmap
+  match TLS.get_exn k_cur_fiber with
+  | exception TLS.Not_set -> Hmap.empty
+  | fiber -> FLS.get fiber ~default:Hmap.empty k_local_hmap
 
 let[@inline] set_local_hmap (h : Hmap.t) : unit =
-  let fiber = get_current_fiber_exn () in
-  FLS.set fiber k_local_hmap h
+  match TLS.get_exn k_cur_fiber with
+  | exception TLS.Not_set -> ()
+  | fiber -> FLS.set fiber k_local_hmap h
 
 let[@inline] update_local_hmap (f : Hmap.t -> Hmap.t) : unit =
-  let fiber = get_current_fiber_exn () in
-  let h = FLS.get fiber ~default:Hmap.empty k_local_hmap in
-  let h = f h in
-  FLS.set fiber k_local_hmap h
+  match TLS.get_exn k_cur_fiber with
+  | exception TLS.Not_set -> ()
+  | fiber ->
+    let h = FLS.get fiber ~default:Hmap.empty k_local_hmap in
+    let h = f h in
+    FLS.set fiber k_local_hmap h
 
 (** @raise Invalid_argument if not present *)
 let get_in_local_hmap_exn (k : 'a Hmap.key) : 'a =
@@ -38,10 +42,9 @@ let[@inline] remove_in_local_hmap (k : _ Hmap.key) : unit =
 let[@inline] set_in_local_hmap (k : 'a Hmap.key) (v : 'a) : unit =
   update_local_hmap (Hmap.add k v)
 
-(** [with_in_local_hmap k v f] calls [f()] in a context
-    where [k] is bound to [v] in the local hmap. Then it restores the
-    previous binding for [k]. *)
-let with_in_local_hmap (k : 'a Hmap.key) (v : 'a) f : unit =
+(** [with_in_local_hmap k v f] calls [f()] in a context where [k] is bound to
+    [v] in the local hmap. Then it restores the previous binding for [k]. *)
+let with_in_local_hmap (k : 'a Hmap.key) (v : 'a) f =
   let h = get_local_hmap () in
   match Hmap.find k h with
   | None ->

src/core/lock.mli

@@ -1,8 +1,8 @@
 (** Mutex-protected resource.
 
-    This lock is a synchronous concurrency primitive, as a thin wrapper
-    around {!Mutex} that encourages proper management of the critical
-    section in RAII style:
+    This lock is a synchronous concurrency primitive, as a thin wrapper around
+    {!Mutex} that encourages proper management of the critical section in RAII
+    style:
 
     {[
       let (let@) = (@@)
@@ -19,8 +19,8 @@
       …
     ]}
 
-    This lock does not work well with {!Fut.await}. A critical section
-    that contains a call to [await] might cause deadlocks, or lock starvation,
+    This lock does not work well with {!Fut.await}. A critical section that
+    contains a call to [await] might cause deadlocks, or lock starvation,
     because it will hold onto the lock while it goes to sleep.
 
     @since 0.3 *)
@@ -32,27 +32,27 @@ val create : 'a -> 'a t
 (** Create a new protected value. *)
 
 val with_ : 'a t -> ('a -> 'b) -> 'b
-(** [with_ l f] runs [f x] where [x] is the value protected with
-    the lock [l], in a critical section. If [f x] fails, [with_lock l f]
-    fails too but the lock is released. *)
+(** [with_ l f] runs [f x] where [x] is the value protected with the lock [l],
+    in a critical section. If [f x] fails, [with_lock l f] fails too but the
+    lock is released. *)
 
 val update : 'a t -> ('a -> 'a) -> unit
-(** [update l f] replaces the content [x] of [l] with [f x], while protected
-    by the mutex. *)
+(** [update l f] replaces the content [x] of [l] with [f x], while protected by
+    the mutex. *)
 
 val update_map : 'a t -> ('a -> 'a * 'b) -> 'b
-(** [update_map l f] computes [x', y = f (get l)], then puts [x'] in [l]
-    and returns [y], while protected by the mutex. *)
+(** [update_map l f] computes [x', y = f (get l)], then puts [x'] in [l] and
+    returns [y], while protected by the mutex. *)
 
 val mutex : _ t -> Mutex.t
 (** Underlying mutex. *)
 
 val get : 'a t -> 'a
-(** Atomically get the value in the lock. The value that is returned
-    isn't protected! *)
+(** Atomically get the value in the lock. The value that is returned isn't
+    protected! *)
 
 val set : 'a t -> 'a -> unit
 (** Atomically set the value.
 
-    {b NOTE} caution: using {!get} and {!set} as if this were a {!ref}
-    is an anti pattern and will not protect data against some race conditions. *)
+    {b NOTE} caution: using {!get} and {!set} as if this were a {!ref} is an
+    anti pattern and will not protect data against some race conditions. *)

src/core/main.ml

@@ -1,6 +1,6 @@
 exception Oh_no of Exn_bt.t
 
-let main (f : Runner.t -> 'a) : 'a =
+let main' ?(block_signals = false) () (f : Runner.t -> 'a) : 'a =
   let worker_st =
     Fifo_pool.Private_.create_single_threaded_state ~thread:(Thread.self ())
       ~on_exn:(fun e bt -> raise (Oh_no (Exn_bt.make e bt)))
@@ -8,15 +8,19 @@ let main (f : Runner.t -> 'a) : 'a =
   in
   let runner = Fifo_pool.Private_.runner_of_state worker_st in
   try
-    let fiber = Fiber.spawn_top ~on:runner (fun () -> f runner) in
-    Fiber.on_result fiber (fun _ -> Runner.shutdown_without_waiting runner);
+    let fut = Fut.spawn ~on:runner (fun () -> f runner) in
+    Fut.on_result fut (fun _ -> Runner.shutdown_without_waiting runner);
 
     (* run the main thread *)
-    Moonpool.Private.Worker_loop_.worker_loop worker_st
+    Worker_loop_.worker_loop worker_st
+      ~block_signals (* do not disturb existing thread *)
       ~ops:Fifo_pool.Private_.worker_ops;
 
-    match Fiber.peek fiber with
+    match Fut.peek fut with
     | Some (Ok x) -> x
     | Some (Error ebt) -> Exn_bt.raise ebt
     | None -> assert false
   with Oh_no ebt -> Exn_bt.raise ebt
+
+let main f =
+  main' () f ~block_signals:false (* do not disturb existing thread *)

src/core/main.mli

@@ -0,0 +1,30 @@
+(** Main thread.
+
+    This is evolved from [Moonpool.Immediate_runner], but unlike it, this API
+    assumes you run it in a thread (possibly the main thread) which will block
+    until the initial computation is done.
+
+    This means it's reasonable to use [Main.main (fun () -> do_everything)] at
+    the beginning of the program. Other Moonpool pools can be created for
+    background tasks, etc. to do the heavy lifting, and the main thread (inside
+    this immediate runner) can coordinate tasks via [Fiber.await].
+
+    Aside from the fact that this blocks the caller thread, it is fairly similar
+    to {!Background_thread} in that there's a single worker to process
+    tasks/fibers.
+
+    This handles the concurency effects used in moonpool, including [await] and
+    [yield].
+
+    This module was migrated from the late [Moonpool_fib].
+
+    @since NEXT_RELEASE *)
+
+val main : (Runner.t -> 'a) -> 'a
+(** [main f] runs [f()] in a scope that handles effects, including
+    {!Fiber.await}.
+
+    This scope can run background tasks as well, in a cooperative fashion. *)
+
+val main' : ?block_signals:bool -> unit -> (Runner.t -> 'a) -> 'a
+(** Same as {!main} but with room for optional arguments. *)

src/core/moonpool.ml

@@ -12,22 +12,18 @@ let get_current_runner = Runner.get_current_runner
 let recommended_thread_count () = Domain_.recommended_number ()
 let spawn = Fut.spawn
 let spawn_on_current_runner = Fut.spawn_on_current_runner
-
-[@@@ifge 5.0]
-
 let await = Fut.await
+let yield = Picos.Fiber.yield
 
-[@@@endif]
-
-module Atomic = Atomic_
+module Atomic = Atomic
 module Blocking_queue = Bb_queue
 module Background_thread = Background_thread
-module Bounded_queue = Bounded_queue
 module Chan = Chan
 module Exn_bt = Exn_bt
 module Fifo_pool = Fifo_pool
 module Fut = Fut
 module Lock = Lock
+module Main = Main
 module Immediate_runner = struct end
 module Runner = Runner
 module Task_local_storage = Task_local_storage
@@ -35,6 +31,9 @@ module Thread_local_storage = Thread_local_storage
 module Trigger = Trigger
 module Ws_pool = Ws_pool
 
+(* re-export main *)
+include Main
+
 module Private = struct
   module Ws_deque_ = Ws_deque_
   module Worker_loop_ = Worker_loop_

src/core/moonpool.mli

@@ -1,19 +1,19 @@
 (** Moonpool
 
-  A pool within a bigger pool (ie the ocean). Here, we're talking about
-  pools of [Thread.t] that are dispatched over several [Domain.t] to
-  enable parallelism.
+    A pool within a bigger pool (ie the ocean). Here, we're talking about pools
+    of [Thread.t] that are dispatched over several [Domain.t] to enable
+    parallelism.
 
-  We provide several implementations of pools
-  with distinct scheduling strategies, alongside some concurrency
-  primitives such as guarding locks ({!Lock.t}) and futures ({!Fut.t}).
-*)
+    We provide several implementations of pools with distinct scheduling
+    strategies, alongside some concurrency primitives such as guarding locks
+    ({!Lock.t}) and futures ({!Fut.t}). *)
 
 module Ws_pool = Ws_pool
 module Fifo_pool = Fifo_pool
 module Background_thread = Background_thread
 module Runner = Runner
 module Trigger = Trigger
+module Main = Main
 
 module Immediate_runner : sig end
 [@@deprecated "use Moonpool_fib.Main"]
@@ -24,45 +24,45 @@ module Immediate_runner : sig end
 module Exn_bt = Exn_bt
 
 exception Shutdown
-(** Exception raised when trying to run tasks on
-    runners that have been shut down.
+(** Exception raised when trying to run tasks on runners that have been shut
+    down.
     @since 0.6 *)
 
 val start_thread_on_some_domain : ('a -> unit) -> 'a -> Thread.t
-(** Similar to {!Thread.create}, but it picks a background domain at random
-    to run the thread. This ensures that we don't always pick the same domain
-    to run all the various threads needed in an application (timers, event loops, etc.) *)
+(** Similar to {!Thread.create}, but it picks a background domain at random to
+    run the thread. This ensures that we don't always pick the same domain to
+    run all the various threads needed in an application (timers, event loops,
+    etc.) *)
 
 val run_async : ?fiber:Picos.Fiber.t -> Runner.t -> (unit -> unit) -> unit
-(** [run_async runner task] schedules the task to run
-  on the given runner. This means [task()] will be executed
-  at some point in the future, possibly in another thread.
-  @param fiber optional initial (picos) fiber state
-  @since 0.5 *)
+(** [run_async runner task] schedules the task to run on the given runner. This
+    means [task()] will be executed at some point in the future, possibly in
+    another thread.
+    @param fiber optional initial (picos) fiber state
+    @since 0.5 *)
 
 val run_wait_block : ?fiber:Picos.Fiber.t -> Runner.t -> (unit -> 'a) -> 'a
-(** [run_wait_block runner f] schedules [f] for later execution
-    on the runner, like {!run_async}.
-    It then blocks the current thread until [f()] is done executing,
-    and returns its result. If [f()] raises an exception, then [run_wait_block pool f]
-    will raise it as well.
+(** [run_wait_block runner f] schedules [f] for later execution on the runner,
+    like {!run_async}. It then blocks the current thread until [f()] is done
+    executing, and returns its result. If [f()] raises an exception, then
+    [run_wait_block pool f] will raise it as well.
 
     See {!run_async} for more details.
 
-    {b NOTE} be careful with deadlocks (see notes in {!Fut.wait_block}
-      about the required discipline to avoid deadlocks).
+    {b NOTE} be careful with deadlocks (see notes in {!Fut.wait_block} about the
+    required discipline to avoid deadlocks).
     @raise Shutdown if the runner was already shut down
     @since 0.6 *)
 
 val recommended_thread_count : unit -> int
-(** Number of threads recommended to saturate the CPU.
-  For IO pools this makes little sense (you might want more threads than
-  this because many of them will be blocked most of the time).
-  @since 0.5 *)
+(** Number of threads recommended to saturate the CPU. For IO pools this makes
+    little sense (you might want more threads than this because many of them
+    will be blocked most of the time).
+    @since 0.5 *)
 
 val spawn : on:Runner.t -> (unit -> 'a) -> 'a Fut.t
-(** [spawn ~on f] runs [f()] on the runner (a thread pool typically)
-    and returns a future result for it. See {!Fut.spawn}.
+(** [spawn ~on f] runs [f()] on the runner (a thread pool typically) and returns
+    a future result for it. See {!Fut.spawn}.
     @since 0.5 *)
 
 val spawn_on_current_runner : (unit -> 'a) -> 'a Fut.t
@@ -71,16 +71,17 @@ val spawn_on_current_runner : (unit -> 'a) -> 'a Fut.t
 
 val get_current_runner : unit -> Runner.t option
 (** See {!Runner.get_current_runner}
-  @since 0.7 *)
-
-[@@@ifge 5.0]
+    @since 0.7 *)
 
 val await : 'a Fut.t -> 'a
-(** Await a future. See {!Fut.await}.
-    Only on OCaml >= 5.0.
+(** Await a future, must be run on a moonpool runner. See {!Fut.await}. Only on
+    OCaml >= 5.0.
     @since 0.5 *)
 
-[@@@endif]
+val yield : unit -> unit
+(** Yield from the current task, must be run on a moonpool runner. Only on OCaml
+    >= 5.0.
+    @since 0.9 *)
 
 module Lock = Lock
 module Fut = Fut
@@ -90,35 +91,33 @@ module Thread_local_storage = Thread_local_storage
 
 (** A simple blocking queue.
 
-    This queue is quite basic and will not behave well under heavy
-    contention. However, it can be sufficient for many practical use cases.
+    This queue is quite basic and will not behave well under heavy contention.
+    However, it can be sufficient for many practical use cases.
 
-    {b NOTE}: this queue will typically block the caller thread
-    in case the operation (push/pop) cannot proceed.
-    Be wary of deadlocks when using the queue {i from} a pool
-    when you expect the other end to also be produced/consumed from
-    the same pool.
+    {b NOTE}: this queue will typically block the caller thread in case the
+    operation (push/pop) cannot proceed. Be wary of deadlocks when using the
+    queue {i from} a pool when you expect the other end to also be
+    produced/consumed from the same pool.
 
-    See discussion on {!Fut.wait_block} for more details on deadlocks
-    and how to mitigate the risk of running into them.
+    See discussion on {!Fut.wait_block} for more details on deadlocks and how to
+    mitigate the risk of running into them.
 
-    More scalable queues can be found in
-    Lockfree (https://github.com/ocaml-multicore/lockfree/)
-*)
+    More scalable queues can be found in Lockfree
+    (https://github.com/ocaml-multicore/lockfree/) *)
 module Blocking_queue : sig
   type 'a t
   (** Unbounded blocking queue.
 
-      This queue is thread-safe and will block when calling {!pop}
-      on it when it's empty. *)
+      This queue is thread-safe and will block when calling {!pop} on it when
+      it's empty. *)
 
   val create : unit -> _ t
   (** Create a new unbounded queue. *)
 
   val size : _ t -> int
-  (** Number of items currently in the queue. Note that [pop]
-      might still block if this returns a non-zero number, since another
-      thread might have consumed the items in the mean time.
+  (** Number of items currently in the queue. Note that [pop] might still block
+      if this returns a non-zero number, since another thread might have
+      consumed the items in the mean time.
       @since 0.2 *)
 
   exception Closed
@@ -126,73 +125,70 @@ module Blocking_queue : sig
   val push : 'a t -> 'a -> unit
   (** [push q x] pushes [x] into [q], and returns [()].
 
-      In the current implementation, [push q] will never block for
-      a long time, it will only block while waiting for a lock
-      so it can push the element.
+      In the current implementation, [push q] will never block for a long time,
+      it will only block while waiting for a lock so it can push the element.
       @raise Closed if the queue is closed (by a previous call to [close q]) *)
 
   val pop : 'a t -> 'a
-  (** [pop q] pops the next element in [q]. It might block until an element comes.
-      @raise Closed if the queue was closed before a new element was available. *)
-
-  val close : _ t -> unit
-  (** Close the queue, meaning there won't be any more [push] allowed,
-      ie [push] will raise {!Closed}.
-
-      [pop] will keep working and will return the elements present in the
-      queue, until it's entirely drained; then [pop] will
-      also raise {!Closed}. *)
-
-  val try_pop : force_lock:bool -> 'a t -> 'a option
-  (** [try_pop q] immediately pops the first element of [q], if any,
-      or returns [None] without blocking.
-      @param force_lock if true, use {!Mutex.lock} (which can block under contention);
-        if false, use {!Mutex.try_lock}, which might return [None] even in
-      presence of an element if there's contention *)
-
-  val try_push : 'a t -> 'a -> bool
-  (** [try_push q x] tries to push into [q], in which case
-      it returns [true]; or it fails to push and returns [false]
-      without blocking.
-      @raise Closed if the locking succeeded but the queue is closed.
+  (** [pop q] pops the next element in [q]. It might block until an element
+      comes.
+      @raise Closed if the queue was closed before a new element was available.
   *)
 
+  val close : _ t -> unit
+  (** Close the queue, meaning there won't be any more [push] allowed, ie [push]
+      will raise {!Closed}.
+
+      [pop] will keep working and will return the elements present in the queue,
+      until it's entirely drained; then [pop] will also raise {!Closed}. *)
+
+  val try_pop : force_lock:bool -> 'a t -> 'a option
+  (** [try_pop q] immediately pops the first element of [q], if any, or returns
+      [None] without blocking.
+      @param force_lock
+        if true, use {!Mutex.lock} (which can block under contention); if false,
+        use {!Mutex.try_lock}, which might return [None] even in presence of an
+        element if there's contention *)
+
+  val try_push : 'a t -> 'a -> bool
+  (** [try_push q x] tries to push into [q], in which case it returns [true]; or
+      it fails to push and returns [false] without blocking.
+      @raise Closed if the locking succeeded but the queue is closed. *)
+
   val transfer : 'a t -> 'a Queue.t -> unit
-  (** [transfer bq q2] transfers all items presently
-    in [bq] into [q2] in one atomic section, and clears [bq].
-    It blocks if no element is in [bq].
+  (** [transfer bq q2] transfers all items presently in [bq] into [q2] in one
+      atomic section, and clears [bq]. It blocks if no element is in [bq].
 
-    This is useful to consume elements from the queue in batch.
-    Create a [Queue.t] locally:
+      This is useful to consume elements from the queue in batch. Create a
+      [Queue.t] locally:
 
+      {[
+        let dowork (work_queue : job Bb_queue.t) =
+          (* local queue, not thread safe *)
+          let local_q = Queue.create () in
+          try
+            while true do
+              (* work on local events, already on this thread *)
+              while not (Queue.is_empty local_q) do
+                let job = Queue.pop local_q in
+                process_job job
+              done;
 
-    {[
-    let dowork (work_queue: job Bb_queue.t) =
-      (* local queue, not thread safe *)
-      let local_q = Queue.create() in
-      try
-        while true do
-          (* work on local events, already on this thread *)
-          while not (Queue.is_empty local_q) do
-            let job = Queue.pop local_q in
-            process_job job
-          done;
+              (* get all the events in the incoming blocking queue, in
+                 one single critical section. *)
+              Bb_queue.transfer work_queue local_q
+            done
+          with Bb_queue.Closed -> ()
+      ]}
 
-          (* get all the events in the incoming blocking queue, in
-             one single critical section. *)
-          Bb_queue.transfer work_queue local_q
-        done
-      with Bb_queue.Closed -> ()
-    ]}
-
-    @since 0.4 *)
+      @since 0.4 *)
 
   type 'a gen = unit -> 'a option
   type 'a iter = ('a -> unit) -> unit
 
   val to_iter : 'a t -> 'a iter
-  (** [to_iter q] returns an iterator over all items in the queue.
-      This might not terminate if [q] is never closed.
+  (** [to_iter q] returns an iterator over all items in the queue. This might
+      not terminate if [q] is never closed.
       @since 0.4 *)
 
   val to_gen : 'a t -> 'a gen
@@ -204,13 +200,15 @@ module Blocking_queue : sig
       @since 0.4 *)
 end
 
-module Bounded_queue = Bounded_queue
-
-module Atomic = Atomic_
+module Atomic = Atomic
 (** Atomic values.
 
-    This is either a shim using [ref], on pre-OCaml 5, or the
-    standard [Atomic] module on OCaml 5. *)
+    This is either a shim using [ref], on pre-OCaml 5, or the standard [Atomic]
+    module on OCaml 5. *)
+
+include module type of struct
+  include Main
+end
 
 (**/**)
 
@@ -220,9 +218,9 @@ module Private : sig
   (** A deque for work stealing, fixed size. *)
 
   module Worker_loop_ = Worker_loop_
-  (** Worker loop. This is useful to implement custom runners, it
-        should run on each thread of the runner.
-        @since 0.7 *)
+  (** Worker loop. This is useful to implement custom runners, it should run on
+      each thread of the runner.
+      @since 0.7 *)
 
   module Domain_ = Domain_
   (** Utils for domains *)

src/core/runner.mli

@@ -1,9 +1,8 @@
 (** Interface for runners.
 
-    This provides an abstraction for running tasks in the background,
-    which is implemented by various thread pools.
-    @since 0.3
-*)
+    This provides an abstraction for running tasks in the background, which is
+    implemented by various thread pools.
+    @since 0.3 *)
 
 type fiber = Picos.Fiber.t
 type task = unit -> unit
@@ -12,19 +11,19 @@ type t
 (** A runner.
 
     If a runner is no longer needed, {!shutdown} can be used to signal all
-    worker threads
-    in it to stop (after they finish their work), and wait for them to stop.
+    worker threads in it to stop (after they finish their work), and wait for
+    them to stop.
 
-    The threads are distributed across a fixed domain pool
-    (whose size is determined by {!Domain.recommended_domain_count} on OCaml 5, and
-    simple the single runtime on OCaml 4). *)
+    The threads are distributed across a fixed domain pool (whose size is
+    determined by {!Domain.recommended_domain_count} on OCaml 5, and simple the
+    single runtime on OCaml 4). *)
 
 val size : t -> int
 (** Number of threads/workers. *)
 
 val num_tasks : t -> int
-(** Current number of tasks. This is at best a snapshot, useful for metrics
-    and debugging. *)
+(** Current number of tasks. This is at best a snapshot, useful for metrics and
+    debugging. *)
 
 val shutdown : t -> unit
 (** Shutdown the runner and wait for it to terminate. Idempotent. *)
@@ -35,32 +34,31 @@ val shutdown_without_waiting : t -> unit
 exception Shutdown
 
 val run_async : ?fiber:fiber -> t -> task -> unit
-(** [run_async pool f] schedules [f] for later execution on the runner
-    in one of the threads. [f()] will run on one of the runner's
-    worker threads/domains.
+(** [run_async pool f] schedules [f] for later execution on the runner in one of
+    the threads. [f()] will run on one of the runner's worker threads/domains.
     @param fiber if provided, run the task with this initial fiber data
-    @raise Shutdown if the runner was shut down before [run_async] was called. *)
+    @raise Shutdown if the runner was shut down before [run_async] was called.
+*)
 
 val run_wait_block : ?fiber:fiber -> t -> (unit -> 'a) -> 'a
-(** [run_wait_block pool f] schedules [f] for later execution
-    on the pool, like {!run_async}.
-    It then blocks the current thread until [f()] is done executing,
-    and returns its result. If [f()] raises an exception, then [run_wait_block pool f]
-    will raise it as well.
+(** [run_wait_block pool f] schedules [f] for later execution on the pool, like
+    {!run_async}. It then blocks the current thread until [f()] is done
+    executing, and returns its result. If [f()] raises an exception, then
+    [run_wait_block pool f] will raise it as well.
 
-    {b NOTE} be careful with deadlocks (see notes in {!Fut.wait_block}
-      about the required discipline to avoid deadlocks).
+    {b NOTE} be careful with deadlocks (see notes in {!Fut.wait_block} about the
+    required discipline to avoid deadlocks).
     @raise Shutdown if the runner was already shut down *)
 
 val dummy : t
-(** Runner that fails when scheduling tasks on it.
-    Calling {!run_async} on it will raise Failure.
+(** Runner that fails when scheduling tasks on it. Calling {!run_async} on it
+    will raise Failure.
     @since 0.6 *)
 
 (** {2 Implementing runners} *)
 
-(** This module is specifically intended for users who implement their
-    own runners. Regular users of Moonpool should not need to look at it. *)
+(** This module is specifically intended for users who implement their own
+    runners. Regular users of Moonpool should not need to look at it. *)
 module For_runner_implementors : sig
   val create :
     size:(unit -> int) ->
@@ -71,21 +69,20 @@ module For_runner_implementors : sig
     t
   (** Create a new runner.
 
-      {b NOTE}: the runner should support DLA and {!Suspend_} on OCaml 5.x,
-      so that {!Fork_join} and other 5.x features work properly. *)
+      {b NOTE}: the runner should support DLA and {!Suspend_} on OCaml 5.x, so
+      that {!Fork_join} and other 5.x features work properly. *)
 
   val k_cur_runner : t Thread_local_storage.t
-  (** Key that should be used by each runner to store itself in TLS
-      on every thread it controls, so that tasks running on these threads
-      can access the runner. This is necessary for {!get_current_runner}
-      to work. *)
+  (** Key that should be used by each runner to store itself in TLS on every
+      thread it controls, so that tasks running on these threads can access the
+      runner. This is necessary for {!get_current_runner} to work. *)
 end
 
 val get_current_runner : unit -> t option
-(** Access the current runner. This returns [Some r] if the call
-    happens on a thread that belongs in a runner.
+(** Access the current runner. This returns [Some r] if the call happens on a
+    thread that belongs in a runner.
     @since 0.5 *)
 
 val get_current_fiber : unit -> fiber option
-(** [get_current_storage runner] gets the local storage
-    for the currently running task. *)
+(** [get_current_storage runner] gets the local storage for the currently
+    running task. *)

src/core/task_local_storage.mli

@@ -1,41 +1,38 @@
 (** Task-local storage.
 
-    This storage is associated to the current task,
-    just like thread-local storage is associated with
-    the current thread. The storage is carried along in case
-    the current task is suspended.
+    This storage is associated to the current task, just like thread-local
+    storage is associated with the current thread. The storage is carried along
+    in case the current task is suspended.
 
-    @since 0.6
-*)
+    @since 0.6 *)
 
 type 'a t = 'a Picos.Fiber.FLS.t
 
 val create : unit -> 'a t
-(** [create ()] makes a new key. Keys are expensive and
-    should never be allocated dynamically or in a loop. *)
+(** [create ()] makes a new key. Keys are expensive and should never be
+    allocated dynamically or in a loop. *)
 
 exception Not_set
 
 val get_exn : 'a t -> 'a
-(** [get k] gets the value for the current task for key [k].
-    Must be run from inside a task running on a runner.
+(** [get k] gets the value for the current task for key [k]. Must be run from
+    inside a task running on a runner.
     @raise Not_set otherwise *)
 
 val get_opt : 'a t -> 'a option
-(** [get_opt k] gets the current task's value for key [k],
-    or [None] if not run from inside the task. *)
+(** [get_opt k] gets the current task's value for key [k], or [None] if not run
+    from inside the task. *)
 
 val get : 'a t -> default:'a -> 'a
 
 val set : 'a t -> 'a -> unit
-(** [set k v] sets the storage for [k] to [v].
-    Must be run from inside a task running on a runner.
+(** [set k v] sets the storage for [k] to [v]. Must be run from inside a task
+    running on a runner.
     @raise Failure otherwise *)
 
 val with_value : 'a t -> 'a -> (unit -> 'b) -> 'b
-(** [with_value k v f] sets [k] to [v] for the duration of the call
-    to [f()]. When [f()] returns (or fails), [k] is restored
-    to its old value. *)
+(** [with_value k v f] sets [k] to [v] for the duration of the call to [f()].
+    When [f()] returns (or fails), [k] is restored to its old value. *)
 
 (** {2 Local [Hmap.t]}
 

src/core/worker_loop_.ml

@@ -13,17 +13,11 @@ type task_full =
     }
       -> task_full
 
-type around_task =
-  | AT_pair : (Runner.t -> 'a) * (Runner.t -> 'a -> unit) -> around_task
-
 exception No_more_tasks
 
 type 'st ops = {
   schedule: 'st -> task_full -> unit;
   get_next_task: 'st -> task_full;  (** @raise No_more_tasks *)
-  get_thread_state: unit -> 'st;
-      (** Access current thread's worker state from any worker *)
-  around_task: 'st -> around_task;
   on_exn: 'st -> Exn_bt.t -> unit;
   runner: 'st -> Runner.t;
   before_start: 'st -> unit;
@@ -33,14 +27,16 @@ type 'st ops = {
 (** A dummy task. *)
 let _dummy_task : task_full = T_start { f = ignore; fiber = _dummy_fiber }
 
-[@@@ifge 5.0]
-
 let[@inline] discontinue k exn =
   let bt = Printexc.get_raw_backtrace () in
   Effect.Deep.discontinue_with_backtrace k exn bt
 
-let with_handler (type st arg) ~(ops : st ops) (self : st) :
-    (unit -> unit) -> unit =
+let[@inline] raise_with_bt exn =
+  let bt = Printexc.get_raw_backtrace () in
+  Printexc.raise_with_backtrace exn bt
+
+let with_handler (type st) ~(ops : st ops) (self : st) : (unit -> unit) -> unit
+    =
   let current =
     Some
       (fun k ->
@@ -83,8 +79,8 @@ let with_handler (type st arg) ~(ops : st ops) (self : st) :
           let fiber = get_current_fiber_exn () in
           (* when triggers is signaled, reschedule task *)
           if not (Picos.Fiber.try_suspend fiber trigger fiber k reschedule) then
-            (* trigger was already signaled, run task now *)
-            Picos.Fiber.resume fiber k)
+            (* trigger was already signaled, reschedule task now *)
+            reschedule trigger fiber k)
     | Picos.Computation.Cancel_after _r ->
       Some
         (fun k ->
@@ -93,21 +89,28 @@ let with_handler (type st arg) ~(ops : st ops) (self : st) :
           discontinue k exn)
     | _ -> None
   in
-  let handler = Effect.Deep.{ retc = Fun.id; exnc = raise; effc } in
+  let handler = Effect.Deep.{ retc = Fun.id; exnc = raise_with_bt; effc } in
   fun f -> Effect.Deep.match_with f () handler
 
-[@@@else_]
+module type FINE_GRAINED_ARGS = sig
+  type st
 
-let with_handler ~ops:_ self f = f ()
+  val ops : st ops
+  val st : st
+end
 
-[@@@endif]
+module Fine_grained (Args : FINE_GRAINED_ARGS) () = struct
+  open Args
 
-let worker_loop (type st) ~(ops : st ops) (self : st) : unit =
-  let cur_fiber : fiber ref = ref _dummy_fiber in
-  let runner = ops.runner self in
-  TLS.set Runner.For_runner_implementors.k_cur_runner runner;
+  let cur_fiber : fiber ref = ref _dummy_fiber
+  let runner = ops.runner st
 
-  let (AT_pair (before_task, after_task)) = ops.around_task self in
+  type state =
+    | New
+    | Ready
+    | Torn_down
+
+  let state = ref New
 
   let run_task (task : task_full) : unit =
     let fiber =
@@ -117,37 +120,73 @@ let worker_loop (type st) ~(ops : st ops) (self : st) : unit =
 
     cur_fiber := fiber;
     TLS.set k_cur_fiber fiber;
-    let _ctx = before_task runner in
+
+    (* let _ctx = before_task runner in *)
 
     (* run the task now, catching errors, handling effects *)
     assert (task != _dummy_task);
     (try
        match task with
-       | T_start { fiber = _; f } -> with_handler ~ops self f
+       | T_start { fiber = _; f } -> with_handler ~ops st f
        | T_resume { fiber = _; k } ->
          (* this is already in an effect handler *)
          k ()
      with e ->
-       let ebt = Exn_bt.get e in
-       ops.on_exn self ebt);
-
-    after_task runner _ctx;
+       let bt = Printexc.get_raw_backtrace () in
+       let ebt = Exn_bt.make e bt in
+       ops.on_exn st ebt);
 
+    (* after_task runner _ctx; *)
     cur_fiber := _dummy_fiber;
     TLS.set k_cur_fiber _dummy_fiber
-  in
 
-  ops.before_start self;
+  let setup ~block_signals () : unit =
+    if !state <> New then invalid_arg "worker_loop.setup: not a new instance";
+    state := Ready;
 
-  let continue = ref true in
-  try
-    while !continue do
-      match ops.get_next_task self with
-      | task -> run_task task
+    if block_signals then Signals_.ignore_signals_ ();
+
+    TLS.set Runner.For_runner_implementors.k_cur_runner runner;
+
+    ops.before_start st
+
+  let run ?(max_tasks = max_int) () : unit =
+    if !state <> Ready then invalid_arg "worker_loop.run: not setup";
+
+    let continue = ref true in
+    let n_tasks = ref 0 in
+    while !continue && !n_tasks < max_tasks do
+      match ops.get_next_task st with
+      | task ->
+        incr n_tasks;
+        run_task task
       | exception No_more_tasks -> continue := false
-    done;
-    ops.cleanup self
+    done
+
+  let teardown () =
+    if !state <> Torn_down then (
+      state := Torn_down;
+      cur_fiber := _dummy_fiber;
+      ops.cleanup st
+    )
+end
+
+let worker_loop (type st) ~block_signals ~(ops : st ops) (self : st) : unit =
+  let module FG =
+    Fine_grained
+      (struct
+        type nonrec st = st
+
+        let ops = ops
+        let st = self
+      end)
+      ()
+  in
+  FG.setup ~block_signals ();
+  try
+    FG.run ();
+    FG.teardown ()
   with exn ->
     let bt = Printexc.get_raw_backtrace () in
-    ops.cleanup self;
+    FG.teardown ();
     Printexc.raise_with_backtrace exn bt

src/core/worker_loop_.mli

@@ -0,0 +1,51 @@
+(** Internal module that is used for workers.
+
+    A thread pool should use this [worker_loop] to run tasks, handle effects,
+    etc. *)
+
+open Types_
+
+type task_full =
+  | T_start of {
+      fiber: fiber;
+      f: unit -> unit;
+    }
+  | T_resume : {
+      fiber: fiber;
+      k: unit -> unit;
+    }
+      -> task_full
+
+val _dummy_task : task_full
+
+exception No_more_tasks
+
+type 'st ops = {
+  schedule: 'st -> task_full -> unit;
+  get_next_task: 'st -> task_full;
+  on_exn: 'st -> Exn_bt.t -> unit;
+  runner: 'st -> Runner.t;
+  before_start: 'st -> unit;
+  cleanup: 'st -> unit;
+}
+
+module type FINE_GRAINED_ARGS = sig
+  type st
+
+  val ops : st ops
+  val st : st
+end
+
+module Fine_grained (_ : FINE_GRAINED_ARGS) () : sig
+  val setup : block_signals:bool -> unit -> unit
+  (** Just initialize the loop *)
+
+  val run : ?max_tasks:int -> unit -> unit
+  (** Run the loop until no task remains or until [max_tasks] tasks have been
+      run *)
+
+  val teardown : unit -> unit
+  (** Tear down the loop *)
+end
+
+val worker_loop : block_signals:bool -> ops:'st ops -> 'st -> unit

src/core/ws_pool.ml

@@ -1,5 +1,5 @@
 open Types_
-module A = Atomic_
+module A = Atomic
 module WSQ = Ws_deque_
 module WL = Worker_loop_
 include Runner
@@ -16,7 +16,8 @@ end
 
 type state = {
   id_: Id.t;
-      (** Unique to this pool. Used to make sure tasks stay within the same pool. *)
+      (** Unique to this pool. Used to make sure tasks stay within the same
+          pool. *)
   active: bool A.t;  (** Becomes [false] when the pool is shutdown. *)
   mutable workers: worker_state array;  (** Fixed set of workers. *)
   main_q: WL.task_full Queue.t;
@@ -27,7 +28,6 @@ type state = {
   cond: Condition.t;
   mutable as_runner: t;
   (* init options *)
-  around_task: WL.around_task;
   name: string option;
   on_init_thread: dom_id:int -> t_id:int -> unit -> unit;
   on_exit_thread: dom_id:int -> t_id:int -> unit -> unit;
@@ -43,9 +43,8 @@ and worker_state = {
   q: WL.task_full WSQ.t;  (** Work stealing queue *)
   rng: Random.State.t;
 }
-(** State for a given worker. Only this worker is
-    allowed to push into the queue, but other workers
-    can come and steal from it if they're idle. *)
+(** State for a given worker. Only this worker is allowed to push into the
+    queue, but other workers can come and steal from it if they're idle. *)
 
 let[@inline] size_ (self : state) = Array.length self.workers
 
@@ -55,20 +54,13 @@ let num_tasks_ (self : state) : int =
   Array.iter (fun w -> n := !n + WSQ.size w.q) self.workers;
   !n
 
-(** TLS, used by worker to store their specific state
-    and be able to retrieve it from tasks when we schedule new
-    sub-tasks. *)
+(** TLS, used by worker to store their specific state and be able to retrieve it
+    from tasks when we schedule new sub-tasks. *)
 let k_worker_state : worker_state TLS.t = TLS.create ()
 
 let[@inline] get_current_worker_ () : worker_state option =
   TLS.get_opt k_worker_state
 
-let[@inline] get_current_worker_exn () : worker_state =
-  match TLS.get_exn k_worker_state with
-  | w -> w
-  | exception TLS.Not_set ->
-    failwith "Moonpool: get_current_runner was called from outside a pool."
-
 (** Try to wake up a waiter, if there's any. *)
 let[@inline] try_wake_someone_ (self : state) : unit =
   if self.n_waiting_nonzero then (
@@ -77,8 +69,8 @@ let[@inline] try_wake_someone_ (self : state) : unit =
     Mutex.unlock self.mutex
   )
 
-(** Push into worker's local queue, open to work stealing.
-    precondition: this runs on the worker thread whose state is [self] *)
+(** Push into worker's local queue, open to work stealing. precondition: this
+    runs on the worker thread whose state is [self] *)
 let schedule_on_current_worker (self : worker_state) task : unit =
   (* we're on this same pool, schedule in the worker's state. Otherwise
      we might also be on pool A but asking to schedule on pool B,
@@ -205,7 +197,6 @@ let cleanup (self : worker_state) : unit =
 
 let worker_ops : worker_state WL.ops =
   let runner (st : worker_state) = st.st.as_runner in
-  let around_task st = st.st.around_task in
   let on_exn (st : worker_state) (ebt : Exn_bt.t) =
     st.st.on_exn (Exn_bt.exn ebt) (Exn_bt.bt ebt)
   in
@@ -213,8 +204,6 @@ let worker_ops : worker_state WL.ops =
     WL.schedule = schedule_from_w;
     runner;
     get_next_task;
-    get_thread_state = get_current_worker_exn;
-    around_task;
     on_exn;
     before_start;
     cleanup;
@@ -243,7 +232,6 @@ type ('a, 'b) create_args =
   ?on_init_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exit_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exn:(exn -> Printexc.raw_backtrace -> unit) ->
-  ?around_task:(t -> 'b) * (t -> 'b -> unit) ->
   ?num_threads:int ->
   ?name:string ->
   'a
@@ -251,15 +239,8 @@ type ('a, 'b) create_args =
 
 let create ?(on_init_thread = default_thread_init_exit_)
     ?(on_exit_thread = default_thread_init_exit_) ?(on_exn = fun _ _ -> ())
-    ?around_task ?num_threads ?name () : t =
+    ?num_threads ?name () : t =
   let pool_id_ = Id.create () in
-  (* wrapper *)
-  let around_task =
-    match around_task with
-    | Some (f, g) -> WL.AT_pair (f, g)
-    | None -> WL.AT_pair (ignore, fun _ _ -> ())
-  in
-
   let num_domains = Domain_pool_.max_number_of_domains () in
   let num_threads = Util_pool_.num_threads ?num_threads () in
 
@@ -276,7 +257,6 @@ let create ?(on_init_thread = default_thread_init_exit_)
       n_waiting_nonzero = true;
       mutex = Mutex.create ();
       cond = Condition.create ();
-      around_task;
       on_exn;
       on_init_thread;
       on_exit_thread;
@@ -310,7 +290,9 @@ let create ?(on_init_thread = default_thread_init_exit_)
     (* function called in domain with index [i], to
        create the thread and push it into [receive_threads] *)
     let create_thread_in_domain () =
-      let thread = Thread.create (WL.worker_loop ~ops:worker_ops) st in
+      let thread =
+        Thread.create (WL.worker_loop ~block_signals:true ~ops:worker_ops) st
+      in
       (* send the thread from the domain back to us *)
       Bb_queue.push receive_threads (idx, thread)
     in
@@ -330,11 +312,9 @@ let create ?(on_init_thread = default_thread_init_exit_)
 
   pool.as_runner
 
-let with_ ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?num_threads
-    ?name () f =
+let with_ ?on_init_thread ?on_exit_thread ?on_exn ?num_threads ?name () f =
   let pool =
-    create ?on_init_thread ?on_exit_thread ?on_exn ?around_task ?num_threads
-      ?name ()
+    create ?on_init_thread ?on_exit_thread ?on_exn ?num_threads ?name ()
   in
   let@ () = Fun.protect ~finally:(fun () -> shutdown pool) in
   f pool

src/core/ws_pool.mli

@@ -1,23 +1,22 @@
 (** Work-stealing thread pool.
 
-    A pool of threads with a worker-stealing scheduler.
-    The pool contains a fixed number of threads that wait for work
-    items to come, process these, and loop.
+    A pool of threads with a worker-stealing scheduler. The pool contains a
+    fixed number of threads that wait for work items to come, process these, and
+    loop.
 
-    This is good for CPU-intensive tasks that feature a lot of small tasks.
-    Note that tasks will not always be processed in the order they are
-    scheduled, so this is not great for workloads where the latency
-    of individual tasks matter (for that see {!Fifo_pool}).
+    This is good for CPU-intensive tasks that feature a lot of small tasks. Note
+    that tasks will not always be processed in the order they are scheduled, so
+    this is not great for workloads where the latency of individual tasks matter
+    (for that see {!Fifo_pool}).
 
     This implements {!Runner.t} since 0.3.
 
     If a pool is no longer needed, {!shutdown} can be used to signal all threads
     in it to stop (after they finish their work), and wait for them to stop.
 
-    The threads are distributed across a fixed domain pool
-    (whose size is determined by {!Domain.recommended_domain_count} on OCaml 5,
-    and simply the single runtime on OCaml 4).
-  *)
+    The threads are distributed across a fixed domain pool (whose size is
+    determined by {!Domain.recommended_domain_count} on OCaml 5, and simply the
+    single runtime on OCaml 4). *)
 
 include module type of Runner
 
@@ -25,7 +24,6 @@ type ('a, 'b) create_args =
   ?on_init_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exit_thread:(dom_id:int -> t_id:int -> unit -> unit) ->
   ?on_exn:(exn -> Printexc.raw_backtrace -> unit) ->
-  ?around_task:(t -> 'b) * (t -> 'b -> unit) ->
   ?num_threads:int ->
   ?name:string ->
   'a
@@ -33,25 +31,21 @@ type ('a, 'b) create_args =
 
 val create : (unit -> t, _) create_args
 (** [create ()] makes a new thread pool.
-     @param on_init_thread called at the beginning of each new thread
-       in the pool.
-     @param num_threads size of the pool, ie. number of worker threads.
-      It will be at least [1] internally, so [0] or negative values make no sense.
-      The default is [Domain.recommended_domain_count()], ie one worker
-      thread per CPU core.
-      On OCaml 4 the default is [4] (since there is only one domain).
-     @param on_exit_thread called at the end of each thread in the pool
-     @param around_task a pair of [before, after], where [before pool] is called
-      before a task is processed,
-      on the worker thread about to run it, and returns [x]; and [after pool x] is called by
-      the same thread after the task is over. (since 0.2)
-     @param name a name for this thread pool, used if tracing is enabled (since 0.6)
-  *)
+    @param on_init_thread
+      called at the beginning of each new thread in the pool.
+    @param num_threads
+      size of the pool, ie. number of worker threads. It will be at least [1]
+      internally, so [0] or negative values make no sense. The default is
+      [Domain.recommended_domain_count()], ie one worker thread per CPU core. On
+      OCaml 4 the default is [4] (since there is only one domain).
+    @param on_exit_thread called at the end of each thread in the pool
+    @param name
+      a name for this thread pool, used if tracing is enabled (since 0.6) *)
 
 val with_ : (unit -> (t -> 'a) -> 'a, _) create_args
-(** [with_ () f] calls [f pool], where [pool] is obtained via {!create}.
-    When [f pool] returns or fails, [pool] is shutdown and its resources
-    are released.
+(** [with_ () f] calls [f pool], where [pool] is obtained via {!create}. When
+    [f pool] returns or fails, [pool] is shutdown and its resources are
+    released.
 
     Most parameters are the same as in {!create}.
     @since 0.3 *)

src/cpp/cpp.ml

@@ -1,124 +0,0 @@
-type op =
-  | Le
-  | Ge
-
-type line =
-  | If of op * int * int
-  | Elseif of op * int * int
-  | Else
-  | Endif
-  | Raw of string
-  | Eof
-
-let prefix ~pre s =
-  let len = String.length pre in
-  if len > String.length s then
-    false
-  else (
-    let rec check i =
-      if i = len then
-        true
-      else if String.unsafe_get s i <> String.unsafe_get pre i then
-        false
-      else
-        check (i + 1)
-    in
-    check 0
-  )
-
-let eval ~major ~minor op i j =
-  match op with
-  | Le -> (major, minor) <= (i, j)
-  | Ge -> (major, minor) >= (i, j)
-
-let preproc_lines ~file ~major ~minor (ic : in_channel) : unit =
-  let pos = ref 0 in
-  let fail msg =
-    failwith (Printf.sprintf "at line %d in '%s': %s" !pos file msg)
-  in
-  let pp_pos () = Printf.printf "#%d %S\n" !pos file in
-
-  let parse_line () : line =
-    match input_line ic with
-    | exception End_of_file -> Eof
-    | line ->
-      let line' = String.trim line in
-      incr pos;
-      if line' <> "" && line'.[0] = '[' then
-        if prefix line' ~pre:"[@@@ifle" then
-          Scanf.sscanf line' "[@@@ifle %d.%d]" (fun x y -> If (Le, x, y))
-        else if prefix line' ~pre:"[@@@ifge" then
-          Scanf.sscanf line' "[@@@ifge %d.%d]" (fun x y -> If (Ge, x, y))
-        else if prefix line' ~pre:"[@@@elifle" then
-          Scanf.sscanf line' "[@@@elifle %d.%d]" (fun x y -> Elseif (Le, x, y))
-        else if prefix line' ~pre:"[@@@elifge" then
-          Scanf.sscanf line' "[@@@elifge %d.%d]" (fun x y -> Elseif (Ge, x, y))
-        else if line' = "[@@@else_]" then
-          Else
-        else if line' = "[@@@endif]" then
-          Endif
-        else
-          Raw line
-      else
-        Raw line
-  in
-
-  (* entry point *)
-  let rec top () =
-    match parse_line () with
-    | Eof -> ()
-    | If (op, i, j) ->
-      if eval ~major ~minor op i j then (
-        pp_pos ();
-        cat_block ()
-      ) else
-        skip_block ~elseok:true ()
-    | Raw s ->
-      print_endline s;
-      top ()
-    | Elseif _ | Else | Endif -> fail "unexpected elseif|else|endif"
-  (* current block is the valid one *)
-  and cat_block () =
-    match parse_line () with
-    | Eof -> fail "unexpected EOF"
-    | If _ -> fail "nested if not supported"
-    | Raw s ->
-      print_endline s;
-      cat_block ()
-    | Endif ->
-      pp_pos ();
-      top ()
-    | Elseif _ | Else -> skip_block ~elseok:false ()
-  (* skip current block.
-     @param elseok if true, we should evaluate "elseif" *)
-  and skip_block ~elseok () =
-    match parse_line () with
-    | Eof -> fail "unexpected EOF"
-    | If _ -> fail "nested if not supported"
-    | Raw _ -> skip_block ~elseok ()
-    | Endif ->
-      pp_pos ();
-      top ()
-    | Elseif (op, i, j) ->
-      if elseok && eval ~major ~minor op i j then (
-        pp_pos ();
-        cat_block ()
-      ) else
-        skip_block ~elseok ()
-    | Else ->
-      if elseok then (
-        pp_pos ();
-        cat_block ()
-      ) else
-        skip_block ~elseok ()
-  in
-  top ()
-
-let () =
-  let file = Sys.argv.(1) in
-  let version = Sys.ocaml_version in
-  let major, minor = Scanf.sscanf version "%u.%u" (fun maj min -> maj, min) in
-  let ic = open_in file in
-  preproc_lines ~file ~major ~minor ic;
-
-  ()

src/cpp/dune

@@ -1,6 +0,0 @@
-; our little preprocessor (ported from containers)
-
-(executable
- (name cpp)
- (modes
-  (best exe)))

src/dpool/dune

@@ -2,8 +2,5 @@
  (name moonpool_dpool)
  (public_name moonpool.dpool)
  (synopsis "Moonpool's domain pool (used to start worker threads)")
- (preprocess
-  (action
-   (run %{project_root}/src/cpp/cpp.exe %{input-file})))
  (flags :standard -open Moonpool_private)
  (libraries moonpool.private))

src/dpool/moonpool_dpool.ml

@@ -15,19 +15,23 @@ module Bb_queue = struct
     if was_empty then Condition.broadcast self.cond;
     Mutex.unlock self.mutex
 
-  let pop (self : 'a t) : 'a =
-    Mutex.lock self.mutex;
-    let rec loop () =
-      if Queue.is_empty self.q then (
-        Condition.wait self.cond self.mutex;
-        (loop [@tailcall]) ()
-      ) else (
-        let x = Queue.pop self.q in
-        Mutex.unlock self.mutex;
-        x
-      )
-    in
-    loop ()
+  let pop (type a) (self : a t) : a =
+    let module M = struct
+      exception Found of a
+    end in
+    try
+      Mutex.lock self.mutex;
+      while true do
+        if Queue.is_empty self.q then
+          Condition.wait self.cond self.mutex
+        else (
+          let x = Queue.pop self.q in
+          Mutex.unlock self.mutex;
+          raise (M.Found x)
+        )
+      done;
+      assert false
+    with M.Found x -> x
 end
 
 module Lock = struct
@@ -38,13 +42,13 @@ module Lock = struct
 
   let create content : _ t = { mutex = Mutex.create (); content }
 
-  let with_ (self : _ t) f =
+  let[@inline never] with_ (self : _ t) f =
     Mutex.lock self.mutex;
-    try
-      let x = f self.content in
+    match f self.content with
+    | x ->
       Mutex.unlock self.mutex;
       x
-    with e ->
+    | exception e ->
       Mutex.unlock self.mutex;
       raise e
 
@@ -71,45 +75,45 @@ type event =
     new threads for pools. *)
 type worker_state = {
   q: event Bb_queue.t;
-  th_count: int Atomic_.t;  (** Number of threads on this *)
+  th_count: int Atomic.t;  (** Number of threads on this *)
 }
 
 (** Array of (optional) workers.
 
-    Workers are started/stop on demand. For each index we have
-    the (currently active) domain's state
-    including a work queue and a thread refcount; and the domain itself,
-    if any, in a separate option because it might outlive its own state. *)
+    Workers are started/stop on demand. For each index we have the (currently
+    active) domain's state including a work queue and a thread refcount; and the
+    domain itself, if any, in a separate option because it might outlive its own
+    state. *)
 let domains_ : (worker_state option * Domain_.t option) Lock.t array =
   let n = max 1 (Domain_.recommended_number ()) in
   Array.init n (fun _ -> Lock.create (None, None))
 
 (** main work loop for a domain worker.
 
-   A domain worker does two things:
-   - run functions it's asked to (mainly, to start new threads inside it)
-   - decrease the refcount when one of these threads stops. The thread
-     will notify the domain that it's exiting, so the domain can know
-     how many threads are still using it. If all threads exit, the domain
-     polls a bit (in case new threads are created really shortly after,
-     which happens with a [Pool.with_] or [Pool.create() … Pool.shutdown()]
-     in a tight loop), and if nothing happens it tries to stop to free resources.
-*)
+    A domain worker does two things:
+    - run functions it's asked to (mainly, to start new threads inside it)
+    - decrease the refcount when one of these threads stops. The thread will
+      notify the domain that it's exiting, so the domain can know how many
+      threads are still using it. If all threads exit, the domain polls a bit
+      (in case new threads are created really shortly after, which happens with
+      a [Pool.with_] or [Pool.create() … Pool.shutdown()] in a tight loop), and
+      if nothing happens it tries to stop to free resources. *)
 let work_ idx (st : worker_state) : unit =
+  Signals_.ignore_signals_ ();
   let main_loop () =
     let continue = ref true in
     while !continue do
       match Bb_queue.pop st.q with
       | Run f -> (try f () with _ -> ())
       | Decr ->
-        if Atomic_.fetch_and_add st.th_count (-1) = 1 then (
+        if Atomic.fetch_and_add st.th_count (-1) = 1 then (
           continue := false;
 
           (* wait a bit, we might be needed again in a short amount of time *)
           try
             for _n_attempt = 1 to 50 do
               Thread.delay 0.001;
-              if Atomic_.get st.th_count > 0 then (
+              if Atomic.get st.th_count > 0 then (
                 (* needed again! *)
                 continue := true;
                 raise Exit
@@ -130,7 +134,7 @@ let work_ idx (st : worker_state) : unit =
         | Some _st', dom ->
           assert (st == _st');
 
-          if Atomic_.get st.th_count > 0 then
+          if Atomic.get st.th_count > 0 then
             (* still alive! *)
             (Some st, dom), true
           else
@@ -146,8 +150,8 @@ let work_ idx (st : worker_state) : unit =
 (* special case for main domain: we start a worker immediately *)
 let () =
   assert (Domain_.is_main_domain ());
-  let w = { th_count = Atomic_.make 1; q = Bb_queue.create () } in
-  (* thread that stays alive *)
+  let w = { th_count = Atomic.make 1; q = Bb_queue.create () } in
+  (* thread that stays alive since [th_count>0] will always hold *)
   ignore (Thread.create (fun () -> work_ 0 w) () : Thread.t);
   domains_.(0) <- Lock.create (Some w, None)
 
@@ -155,15 +159,16 @@ let[@inline] max_number_of_domains () : int = Array.length domains_
 
 let run_on (i : int) (f : unit -> unit) : unit =
   assert (i < Array.length domains_);
-  let w =
+
+  let w : worker_state =
     Lock.update_map domains_.(i) (function
       | (Some w, _) as st ->
-        Atomic_.incr w.th_count;
+        Atomic.incr w.th_count;
         st, w
       | None, dying_dom ->
         (* join previous dying domain, to free its resources, if any *)
         Option.iter Domain_.join dying_dom;
-        let w = { th_count = Atomic_.make 1; q = Bb_queue.create () } in
+        let w = { th_count = Atomic.make 1; q = Bb_queue.create () } in
         let worker : domain = Domain_.spawn (fun () -> work_ i w) in
         (Some w, Some worker), w)
   in

src/dpool/moonpool_dpool.mli

@@ -1,18 +1,17 @@
 (** Static pool of domains.
 
-   These domains are shared between {b all} the pools in moonpool.
-   The rationale is that we should not have more domains than cores, so
-   it's easier to reserve exactly that many domain slots, and run more flexible
-   thread pools on top (each domain being shared by potentially multiple threads
-   from multiple pools).
+    These domains are shared between {b all} the pools in moonpool. The
+    rationale is that we should not have more domains than cores, so it's easier
+    to reserve exactly that many domain slots, and run more flexible thread
+    pools on top (each domain being shared by potentially multiple threads from
+    multiple pools).
 
-   The pool should not contain actual domains if it's not in use, ie if no
-   runner is presently actively using one or more of the domain slots.
+    The pool should not contain actual domains if it's not in use, ie if no
+    runner is presently actively using one or more of the domain slots.
 
-   {b NOTE}: Interface is still experimental.
+    {b NOTE}: Interface is still experimental.
 
-   @since 0.6
-*)
+    @since 0.6 *)
 
 type domain = Domain_.t
 
@@ -24,13 +23,13 @@ val max_number_of_domains : unit -> int
     Be very cautious with this interface, or resource leaks might occur. *)
 
 val run_on : int -> (unit -> unit) -> unit
-(** [run_on i f] runs [f()] on the domain with index [i].
-    Precondition: [0 <= i < n_domains()]. The thread must call {!decr_on}
-    with [i] once it's done. *)
+(** [run_on i f] runs [f()] on the domain with index [i]. Precondition:
+    [0 <= i < n_domains()]. The thread must call {!decr_on} with [i] once it's
+    done. *)
 
 val decr_on : int -> unit
 (** Signal that a thread is stopping on the domain with index [i]. *)
 
 val run_on_and_wait : int -> (unit -> 'a) -> 'a
-(** [run_on_and_wait i f] runs [f()] on the domain with index [i],
-    and blocks until the result of [f()] is returned back. *)
+(** [run_on_and_wait i f] runs [f()] on the domain with index [i], and blocks
+    until the result of [f()] is returned back. *)

src/fib/dune

@@ -1,12 +0,0 @@
-(library
- (name moonpool_fib)
- (public_name moonpool.fib)
- (synopsis "Fibers and structured concurrency for Moonpool")
- (libraries moonpool picos)
- (enabled_if
-  (>= %{ocaml_version} 5.0))
- (flags :standard -open Moonpool_private -open Moonpool)
- (optional)
- (preprocess
-  (action
-   (run %{project_root}/src/cpp/cpp.exe %{input-file}))))

src/fib/fiber.ml

@@ -1,334 +0,0 @@
-open Moonpool.Private.Types_
-module A = Atomic
-module FM = Handle.Map
-module Int_map = Map.Make (Int)
-module PF = Picos.Fiber
-module FLS = Picos.Fiber.FLS
-
-type 'a callback = 'a Exn_bt.result -> unit
-(** Callbacks that are called when a fiber is done. *)
-
-type cancel_callback = Exn_bt.t -> unit
-
-let prom_of_fut : 'a Fut.t -> 'a Fut.promise =
-  Fut.Private_.unsafe_promise_of_fut
-
-(* TODO: replace with picos structured at some point? *)
-module Private_ = struct
-  type pfiber = PF.t
-
-  type 'a t = {
-    id: Handle.t;  (** unique identifier for this fiber *)
-    state: 'a state A.t;  (** Current state in the lifetime of the fiber *)
-    res: 'a Fut.t;
-    runner: Runner.t;
-    pfiber: pfiber;  (** Associated picos fiber *)
-  }
-
-  and 'a state =
-    | Alive of {
-        children: children;
-        on_cancel: cancel_callback Int_map.t;
-        cancel_id: int;
-      }
-    | Terminating_or_done of 'a Exn_bt.result A.t
-
-  and children = any FM.t
-  and any = Any : _ t -> any [@@unboxed]
-
-  (** Key to access the current moonpool.fiber. *)
-  let k_current_fiber : any FLS.t = FLS.create ()
-
-  exception Not_set = FLS.Not_set
-
-  let[@inline] get_cur_from_exn (pfiber : pfiber) : any =
-    FLS.get_exn pfiber k_current_fiber
-
-  let[@inline] get_cur_exn () : any =
-    get_cur_from_exn @@ get_current_fiber_exn ()
-
-  let[@inline] get_cur_opt () = try Some (get_cur_exn ()) with _ -> None
-
-  let[@inline] is_closed (self : _ t) =
-    match A.get self.state with
-    | Alive _ -> false
-    | Terminating_or_done _ -> true
-end
-
-include Private_
-
-let create_ ~pfiber ~runner ~res () : 'a t =
-  let id = Handle.generate_fresh () in
-  {
-    state =
-      A.make
-      @@ Alive { children = FM.empty; on_cancel = Int_map.empty; cancel_id = 0 };
-    id;
-    res;
-    runner;
-    pfiber;
-  }
-
-let create_done_ ~res () : _ t =
-  let id = Handle.generate_fresh () in
-  {
-    state =
-      A.make
-      @@ Alive { children = FM.empty; on_cancel = Int_map.empty; cancel_id = 0 };
-    id;
-    res;
-    runner = Runner.dummy;
-    pfiber = Moonpool.Private.Types_._dummy_fiber;
-  }
-
-let[@inline] return x = create_done_ ~res:(Fut.return x) ()
-let[@inline] fail ebt = create_done_ ~res:(Fut.fail_exn_bt ebt) ()
-let[@inline] res self = self.res
-let[@inline] peek self = Fut.peek self.res
-let[@inline] is_done self = Fut.is_done self.res
-let[@inline] is_success self = Fut.is_success self.res
-let[@inline] is_cancelled self = Fut.is_failed self.res
-let[@inline] on_result (self : _ t) f = Fut.on_result self.res f
-let[@inline] await self = Fut.await self.res
-let[@inline] wait_block self = Fut.wait_block self.res
-let[@inline] wait_block_exn self = Fut.wait_block_exn self.res
-
-(** Resolve [promise] once [children] are all done *)
-let resolve_once_children_are_done_ ~children ~promise
-    (res : 'a Exn_bt.result A.t) : unit =
-  let n_children = FM.cardinal children in
-  if n_children > 0 then (
-    (* wait for all children to be done *)
-    let n_waiting = A.make (FM.cardinal children) in
-    let on_child_finish (r : _ result) =
-      (* make sure the parent fails if any child fails *)
-      (match r with
-      | Ok _ -> ()
-      | Error ebt -> A.set res (Error ebt));
-
-      (* if we're the last to finish, resolve the parent fiber's [res] *)
-      if A.fetch_and_add n_waiting (-1) = 1 then (
-        let res = A.get res in
-        Fut.fulfill promise res
-      )
-    in
-    FM.iter (fun _ (Any f) -> Fut.on_result f.res on_child_finish) children
-  ) else
-    Fut.fulfill promise @@ A.get res
-
-let rec resolve_as_failed_ : type a. a t -> Exn_bt.t -> unit =
- fun self ebt ->
-  let promise = prom_of_fut self.res in
-  while
-    match A.get self.state with
-    | Alive { children; cancel_id = _; on_cancel } as old ->
-      let new_st = Terminating_or_done (A.make @@ Error ebt) in
-      if A.compare_and_set self.state old new_st then (
-        (* here, unlike in {!resolve_fiber}, we immediately cancel children *)
-        cancel_children_ ~children ebt;
-        Int_map.iter (fun _ cb -> cb ebt) on_cancel;
-        resolve_once_children_are_done_ ~children ~promise (A.make @@ Error ebt);
-        false
-      ) else
-        true
-    | Terminating_or_done _ -> false
-  do
-    ()
-  done
-
-(** Cancel eagerly all children *)
-and cancel_children_ ebt ~children : unit =
-  FM.iter (fun _ (Any f) -> resolve_as_failed_ f ebt) children
-
-type cancel_handle = int
-
-let add_on_cancel (self : _ t) cb : cancel_handle =
-  let h = ref 0 in
-  while
-    match A.get self.state with
-    | Alive { children; cancel_id; on_cancel } as old ->
-      let new_st =
-        Alive
-          {
-            children;
-            cancel_id = cancel_id + 1;
-            on_cancel = Int_map.add cancel_id cb on_cancel;
-          }
-      in
-      if A.compare_and_set self.state old new_st then (
-        h := cancel_id;
-        false
-      ) else
-        true
-    | Terminating_or_done r ->
-      (match A.get r with
-      | Error ebt -> cb ebt
-      | Ok _ -> ());
-      false
-  do
-    ()
-  done;
-  !h
-
-let remove_on_cancel (self : _ t) h =
-  while
-    match A.get self.state with
-    | Alive ({ on_cancel; _ } as alive) as old ->
-      let new_st =
-        Alive { alive with on_cancel = Int_map.remove h on_cancel }
-      in
-      not (A.compare_and_set self.state old new_st)
-    | Terminating_or_done _ -> false
-  do
-    ()
-  done
-
-let with_on_cancel (self : _ t) cb (k : unit -> 'a) : 'a =
-  let h = add_on_cancel self cb in
-  Fun.protect k ~finally:(fun () -> remove_on_cancel self h)
-
-(** Successfully resolve the fiber. This might still fail if
-    some children failed. *)
-let resolve_ok_ (self : 'a t) (r : 'a) : unit =
-  let r = A.make @@ Ok r in
-  let promise = prom_of_fut self.res in
-  while
-    match A.get self.state with
-    | Alive { children; _ } as old ->
-      let new_st = Terminating_or_done r in
-      if A.compare_and_set self.state old new_st then (
-        resolve_once_children_are_done_ ~children ~promise r;
-        false
-      ) else
-        true
-    | Terminating_or_done _ -> false
-  do
-    ()
-  done
-
-let remove_child_ (self : _ t) (child : _ t) =
-  while
-    match A.get self.state with
-    | Alive ({ children; _ } as alive) as old ->
-      let new_st =
-        Alive { alive with children = FM.remove child.id children }
-      in
-      not (A.compare_and_set self.state old new_st)
-    | _ -> false
-  do
-    ()
-  done
-
-(** Add a child to [self].
-    @param protected if true, the child's failure will not affect [self]. *)
-let add_child_ ~protect (self : _ t) (child : _ t) =
-  while
-    match A.get self.state with
-    | Alive ({ children; _ } as alive) as old ->
-      let new_st =
-        Alive { alive with children = FM.add child.id (Any child) children }
-      in
-
-      if A.compare_and_set self.state old new_st then (
-        (* make sure to remove [child] from [self.children] once it's done;
-           fail [self] is [child] failed and [protect=false] *)
-        Fut.on_result child.res (function
-          | Ok _ -> remove_child_ self child
-          | Error ebt ->
-            (* child failed, we must fail too *)
-            remove_child_ self child;
-            if not protect then resolve_as_failed_ self ebt);
-        false
-      ) else
-        true
-    | Terminating_or_done r ->
-      (match A.get r with
-      | Error ebt ->
-        (* cancel child immediately *)
-        resolve_as_failed_ child ebt
-      | Ok _ -> ());
-      false
-  do
-    ()
-  done
-
-let spawn_ ~parent ~runner (f : unit -> 'a) : 'a t =
-  let res, _ = Fut.make () in
-  let pfiber = PF.create ~forbid:false (Fut.Private_.as_computation res) in
-
-  (* copy local hmap from parent, if present *)
-  Option.iter
-    (fun (p : _ t) -> Fls.Private_hmap_ls_.copy_fls p.pfiber pfiber)
-    parent;
-
-  (match parent with
-  | Some p when is_closed p -> failwith "spawn: nursery is closed"
-  | _ -> ());
-  let fib = create_ ~pfiber ~runner ~res () in
-
-  let run () =
-    (* make sure the fiber is accessible from inside itself *)
-    FLS.set pfiber k_current_fiber (Any fib);
-    try
-      let res = f () in
-      resolve_ok_ fib res
-    with exn ->
-      let bt = Printexc.get_raw_backtrace () in
-      let ebt = Exn_bt.make exn bt in
-      resolve_as_failed_ fib ebt
-  in
-
-  Runner.run_async ~fiber:pfiber runner run;
-
-  fib
-
-let spawn_top ~on f : _ t = spawn_ ~runner:on ~parent:None f
-
-let spawn ?on ?(protect = true) f : _ t =
-  (* spawn [f()] with a copy of our local storage *)
-  let (Any p) =
-    try get_cur_exn ()
-    with Not_set ->
-      failwith "Fiber.spawn: must be run from within another fiber."
-  in
-
-  let runner =
-    match on with
-    | Some r -> r
-    | None -> p.runner
-  in
-  let child = spawn_ ~parent:(Some p) ~runner f in
-  add_child_ ~protect p child;
-  child
-
-let[@inline] spawn_ignore ?on ?protect f : unit =
-  ignore (spawn ?on ?protect f : _ t)
-
-let[@inline] spawn_top_ignore ~on f : unit = ignore (spawn_top ~on f : _ t)
-
-let[@inline] self () : any =
-  match get_cur_exn () with
-  | exception Not_set -> failwith "Fiber.self: must be run from inside a fiber."
-  | f -> f
-
-let with_on_self_cancel cb (k : unit -> 'a) : 'a =
-  let (Any self) = self () in
-  let h = add_on_cancel self cb in
-  Fun.protect k ~finally:(fun () -> remove_on_cancel self h)
-
-let[@inline] check_if_cancelled_ (self : _ t) = PF.check self.pfiber
-
-let check_if_cancelled () =
-  match get_cur_exn () with
-  | exception Not_set ->
-    failwith "Fiber.check_if_cancelled: must be run from inside a fiber."
-  | Any self -> check_if_cancelled_ self
-
-let yield () : unit =
-  match get_cur_exn () with
-  | exception Not_set ->
-    failwith "Fiber.yield: must be run from inside a fiber."
-  | Any self ->
-    check_if_cancelled_ self;
-    PF.yield ();
-    check_if_cancelled_ self

src/fib/fiber.mli

@@ -1,154 +0,0 @@
-(** Fibers.
-
-    A fiber is a lightweight computation that runs cooperatively
-    alongside other fibers. In the context of moonpool, fibers
-    have additional properties:
-
-    - they run in a moonpool runner
-    - they form a simple supervision tree, enabling a limited form
-      of structured concurrency
-*)
-
-type cancel_callback = Exn_bt.t -> unit
-(** A callback used in case of cancellation *)
-
-(**/**)
-
-(** Do not rely on this, it is internal implementation details. *)
-module Private_ : sig
-  type 'a state
-  type pfiber
-
-  type 'a t = private {
-    id: Handle.t;  (** unique identifier for this fiber *)
-    state: 'a state Atomic.t;  (** Current state in the lifetime of the fiber *)
-    res: 'a Fut.t;
-    runner: Runner.t;
-    pfiber: pfiber;
-  }
-  (** Type definition, exposed so that {!any} can be unboxed.
-      Please do not rely on that. *)
-
-  type any = Any : _ t -> any [@@unboxed]
-
-  exception Not_set
-
-  val get_cur_exn : unit -> any
-  (** [get_cur_exn ()] either returns the current fiber, or
-      @raise Not_set if run outside a fiber. *)
-
-  val get_cur_opt : unit -> any option
-end
-
-(**/**)
-
-type 'a t = 'a Private_.t
-(** A fiber returning a value of type ['a]. *)
-
-val res : 'a t -> 'a Fut.t
-(** Future result of the fiber. *)
-
-type 'a callback = 'a Exn_bt.result -> unit
-(** Callbacks that are called when a fiber is done. *)
-
-(** Type erased fiber *)
-type any = Private_.any = Any : _ t -> any [@@unboxed]
-
-val return : 'a -> 'a t
-val fail : Exn_bt.t -> _ t
-
-val self : unit -> any
-(** [self ()] is the current fiber.
-    Must be run from inside a fiber.
-    @raise Failure if not run from inside a fiber. *)
-
-val peek : 'a t -> 'a Fut.or_error option
-(** Peek inside the future result *)
-
-val is_done : _ t -> bool
-(** Has the fiber completed? *)
-
-val is_cancelled : _ t -> bool
-(** Has the fiber completed with a failure? *)
-
-val is_success : _ t -> bool
-(** Has the fiber completed with a value? *)
-
-val await : 'a t -> 'a
-(** [await fib] is like [Fut.await (res fib)] *)
-
-val wait_block_exn : 'a t -> 'a
-(** [wait_block_exn fib] is [Fut.wait_block_exn (res fib)].
-    {b NOTE}: See {!Fut.wait_block} for warnings about deadlocks. *)
-
-val wait_block : 'a t -> 'a Fut.or_error
-(** [wait_block fib] is [Fut.wait_block (res fib)].
-    {b NOTE}: See {!Fut.wait_block} for warnings about deadlocks. *)
-
-val check_if_cancelled : unit -> unit
-(** Check if the current fiber is cancelled, in which case this raises.
-    Must be run from inside a fiber.
-    @raise e if the current fiber is cancelled with exception [e]
-    @raise Failure if not run from a fiber. *)
-
-val yield : unit -> unit
-(** Yield control to the scheduler from the current fiber.
-    @raise Failure if not run from inside a fiber. *)
-
-type cancel_handle
-(** An opaque handle for a single cancel callback in a fiber *)
-
-val add_on_cancel : _ t -> cancel_callback -> cancel_handle
-(** [add_on_cancel fib cb] adds [cb] to the list of cancel callbacks
-    for [fib]. If [fib] is already cancelled, [cb] is called immediately. *)
-
-val remove_on_cancel : _ t -> cancel_handle -> unit
-(** [remove_on_cancel fib h] removes the cancel callback
-    associated with handle [h]. *)
-
-val with_on_cancel : _ t -> cancel_callback -> (unit -> 'a) -> 'a
-(** [with_on_cancel fib cb (fun () -> <e>)] evaluates [e]
-    in a scope in which, if the fiber [fib] is cancelled,
-    [cb()] is called. If [e] returns without the fiber being cancelled,
-    this callback is removed. *)
-
-val with_on_self_cancel : cancel_callback -> (unit -> 'a) -> 'a
-(** [with_on_self_cancel cb f] calls [f()] in a scope where
-    [cb] is added to the cancel callbacks of the current fiber;
-    and [f()] terminates, [cb] is removed from the list. *)
-
-val on_result : 'a t -> 'a callback -> unit
-(** Wait for fiber to be done and call the callback
-    with the result. If the fiber is done already then the
-    callback is invoked immediately with its result. *)
-
-val spawn_top : on:Runner.t -> (unit -> 'a) -> 'a t
-(** [spawn_top ~on f] spawns a new (toplevel) fiber onto the given runner.
-    This fiber is not the child of any other fiber: its lifetime
-    is only determined by the lifetime of [f()]. *)
-
-val spawn : ?on:Runner.t -> ?protect:bool -> (unit -> 'a) -> 'a t
-(** [spawn ~protect f] spawns a sub-fiber [f_child]
-    from a running fiber [parent].
-    The sub-fiber [f_child] is attached to the current fiber and fails
-    if the current fiber [parent] fails.
-
-    @param on if provided, start the fiber on the given runner. If not
-    provided, use the parent's runner.
-    @param protect if true, when [f_child] fails, it does not
-      affect [parent]. If false, [f_child] failing also
-      causes [parent] to fail (and therefore all other children
-      of [parent]). Default is [true].
-
-    Must be run from inside a fiber.
-    @raise Failure if not run from  inside a fiber. *)
-
-val spawn_ignore : ?on:Runner.t -> ?protect:bool -> (unit -> _) -> unit
-(** [spawn_ignore f] is [ignore (spawn f)].
-  The fiber will still affect termination of the parent, ie. the
-  parent will exit only after this new fiber exits.
-  @param on the optional runner to use, added since NEXT_RELEASE *)
-
-val spawn_top_ignore : on:Runner.t -> (unit -> _) -> unit
-(** Like {!spawn_top} but ignores the result.
-    @since 0.7 *)

src/fib/fls.ml

@@ -1 +0,0 @@
-include Task_local_storage

src/fib/fls.mli

@@ -1,19 +0,0 @@
-(** Fiber-local storage.
-
-    This storage is associated to the current fiber,
-    just like thread-local storage is associated with
-    the current thread.
-
-    See {!Moonpool.Task_local_storage} for more general information, as
-    this is based on it.
-
-    {b NOTE}: it's important to note that, while each fiber
-    has its own storage, spawning a sub-fiber [f2] from a fiber [f1]
-    will only do a shallow copy of the storage.
-    Values inside [f1]'s storage will be physically shared with [f2].
-    It is thus recommended to store only persistent values in the local storage.
-*)
-
-include module type of struct
-  include Task_local_storage
-end

src/fib/handle.ml

@@ -1,14 +0,0 @@
-module A = Atomic
-
-type t = int
-
-let counter_ = A.make 0
-let equal : t -> t -> bool = ( = )
-let compare : t -> t -> int = Stdlib.compare
-let[@inline] generate_fresh () = A.fetch_and_add counter_ 1
-
-(* TODO: better hash *)
-let[@inline] hash x = x land max_int
-
-module Set = Set.Make (Int)
-module Map = Map.Make (Int)

src/fib/handle.mli

@@ -1,17 +0,0 @@
-(** The unique name of a fiber.
-
-    Each fiber has a unique handle that can be used to
-    refer to it in maps or sets. *)
-
-type t = private int
-(** Unique, opaque identifier for a fiber. *)
-
-val equal : t -> t -> bool
-val compare : t -> t -> int
-val hash : t -> int
-
-val generate_fresh : unit -> t
-(** Generate a fresh, unique identifier *)
-
-module Set : Set.S with type elt = t
-module Map : Map.S with type key = t

src/fib/main.mli

@@ -1,25 +0,0 @@
-(** Main thread.
-
-    This is evolved from [Moonpool.Immediate_runner], but unlike it,
-    this API assumes you run it in a thread (possibly
-    the main thread) which will block until the initial computation is done.
-
-    This means it's reasonable to use [Main.main (fun () -> do_everything)]
-    at the beginning of the program.
-    Other Moonpool pools can be created for background tasks, etc. to do the
-    heavy lifting, and the main thread (inside this immediate runner) can coordinate
-    tasks via [Fiber.await].
-
-    Aside from the fact that this blocks the caller thread, it is fairly similar to
-    {!Background_thread} in that there's a single worker to process
-    tasks/fibers.
-
-    This handles effects, including the ones in {!Fiber}.
-
-    @since 0.6
-*)
-
-val main : (Moonpool.Runner.t -> 'a) -> 'a
-(** [main f] runs [f()] in a scope that handles effects, including {!Fiber.await}.
-
-    This scope can run background tasks as well, in a cooperative fashion. *)

src/fib/moonpool_fib.ml

@@ -1,12 +0,0 @@
-(** Fibers for moonpool.
-
-    See {!Fiber} for the most important explanations.
-
-    @since 0.6. *)
-
-module Fiber = Fiber
-module Fls = Fls
-module Handle = Handle
-module Main = Main
-include Fiber
-include Main

src/forkjoin/dune

@@ -4,6 +4,4 @@
  (synopsis "Fork-join parallelism for moonpool")
  (flags :standard -open Moonpool)
  (optional)
- (enabled_if
-  (>= %{ocaml_version} 5.0))
  (libraries moonpool moonpool.private picos))

src/forkjoin/moonpool_forkjoin.ml

@@ -64,7 +64,7 @@ module State_ = struct
       done;
 
       (* wait for the other computation to be done *)
-      if !must_await then Trigger.await trigger |> Option.iter Exn_bt.raise
+      if !must_await then Trigger.await_exn trigger
     | Right_solved _ | Both_solved _ -> assert false
 end
 
@@ -144,7 +144,7 @@ let for_ ?chunk_size n (f : int -> int -> unit) : unit =
       i := !i + len_range
     done;
 
-    Trigger.await trigger |> Option.iter Exn_bt.raise;
+    Trigger.await_exn trigger;
     Option.iter Exn_bt.raise @@ A.get failure;
     ()
   )

src/forkjoin/moonpool_forkjoin.mli

@@ -5,20 +5,22 @@
     @since 0.3 *)
 
 val both : (unit -> 'a) -> (unit -> 'b) -> 'a * 'b
-(** [both f g] runs [f()] and [g()], potentially in parallel,
-    and returns their result when both are done.
-    If any of [f()] and [g()] fails, then the whole computation fails.
+(** [both f g] runs [f()] and [g()], potentially in parallel, and returns their
+    result when both are done. If any of [f()] and [g()] fails, then the whole
+    computation fails.
 
-    This must be run from within the pool: for example, inside {!Pool.run}
-    or inside a {!Fut.spawn} computation.
-    This is because it relies on an effect handler to be installed.
+    This must be run from within the pool: for example, inside {!Pool.run} or
+    inside a {!Fut.spawn} computation. This is because it relies on an effect
+    handler to be installed.
 
     @since 0.3
+
     {b NOTE} this is only available on OCaml 5. *)
 
 val both_ignore : (unit -> _) -> (unit -> _) -> unit
 (** Same as [both f g |> ignore].
     @since 0.3
+
     {b NOTE} this is only available on OCaml 5. *)
 
 val for_ : ?chunk_size:int -> int -> (int -> int -> unit) -> unit
@@ -63,43 +65,49 @@ val for_ : ?chunk_size:int -> int -> (int -> int -> unit) -> unit
     {b NOTE} this is only available on OCaml 5. *)
 
 val all_array : ?chunk_size:int -> (unit -> 'a) array -> 'a array
-(** [all_array fs] runs all functions in [fs] in tasks, and waits for
-    all the results.
+(** [all_array fs] runs all functions in [fs] in tasks, and waits for all the
+    results.
 
-    @param chunk_size if equal to [n], groups items by [n] to be run in
-      a single task. Default is [1].
+    @param chunk_size
+      if equal to [n], groups items by [n] to be run in a single task. Default
+      is [1].
 
     @since 0.3
+
     {b NOTE} this is only available on OCaml 5. *)
 
 val all_list : ?chunk_size:int -> (unit -> 'a) list -> 'a list
-(** [all_list fs] runs all functions in [fs] in tasks, and waits for
-    all the results.
+(** [all_list fs] runs all functions in [fs] in tasks, and waits for all the
+    results.
 
-    @param chunk_size if equal to [n], groups items by [n] to be run in
-      a single task. Default is not specified.
-      This parameter is available since 0.3.
+    @param chunk_size
+      if equal to [n], groups items by [n] to be run in a single task. Default
+      is not specified. This parameter is available since 0.3.
 
     @since 0.3
+
     {b NOTE} this is only available on OCaml 5. *)
 
 val all_init : ?chunk_size:int -> int -> (int -> 'a) -> 'a list
-(** [all_init n f] runs functions [f 0], [f 1], … [f (n-1)] in tasks, and waits for
-    all the results.
+(** [all_init n f] runs functions [f 0], [f 1], … [f (n-1)] in tasks, and waits
+    for all the results.
 
-    @param chunk_size if equal to [n], groups items by [n] to be run in
-      a single task. Default is not specified.
-      This parameter is available since 0.3.
+    @param chunk_size
+      if equal to [n], groups items by [n] to be run in a single task. Default
+      is not specified. This parameter is available since 0.3.
 
     @since 0.3
+
     {b NOTE} this is only available on OCaml 5. *)
 
 val map_array : ?chunk_size:int -> ('a -> 'b) -> 'a array -> 'b array
 (** [map_array f arr] is like [Array.map f arr], but runs in parallel.
     @since 0.3
+
     {b NOTE} this is only available on OCaml 5. *)
 
 val map_list : ?chunk_size:int -> ('a -> 'b) -> 'a list -> 'b list
 (** [map_list f l] is like [List.map f l], but runs in parallel.
     @since 0.3
+
     {b NOTE} this is only available on OCaml 5. *)

src/io/dune

@@ -1,7 +0,0 @@
-(library
- (name moonpool_io)
- (public_name moonpool-io)
- (synopsis "Async IO for moonpool, using Picos")
- (enabled_if
-  (>= %{ocaml_version} 5.0))
- (libraries moonpool moonpool.fib picos_io picos_io.select picos_io.fd))

src/io/moonpool_io.ml

@@ -1,13 +0,0 @@
-module Fd = Picos_io_fd
-module Unix = Picos_io.Unix
-module Select = Picos_io_select
-
-let fd_of_unix_fd : Unix.file_descr -> Fd.t = Fun.id
-
-(** [main f] runs [f()] inside a scheduler. *)
-let main (f : Moonpool.Runner.t -> 'a) : 'a = Moonpool_fib.main f
-
-(** {2 Async read/write} *)
-
-let read = Unix.read
-let write = Unix.write

src/lwt/IO.ml

@@ -1,66 +0,0 @@
-open Base
-
-let await_readable fd : unit =
-  let trigger = Trigger.create () in
-  Perform_action_in_lwt.schedule
-  @@ Action.Wait_readable
-       ( fd,
-         fun cancel ->
-           Trigger.signal trigger;
-           Lwt_engine.stop_event cancel );
-  Trigger.await_exn trigger
-
-let rec read fd buf i len : int =
-  if len = 0 then
-    0
-  else (
-    match Unix.read fd buf i len with
-    | exception Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
-      await_readable fd;
-      read fd buf i len
-    | n -> n
-  )
-
-let await_writable fd =
-  let trigger = Trigger.create () in
-  Perform_action_in_lwt.schedule
-  @@ Action.Wait_writable
-       ( fd,
-         fun cancel ->
-           Trigger.signal trigger;
-           Lwt_engine.stop_event cancel );
-  Trigger.await_exn trigger
-
-let rec write_once fd buf i len : int =
-  if len = 0 then
-    0
-  else (
-    match Unix.write fd buf i len with
-    | exception Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
-      await_writable fd;
-      write_once fd buf i len
-    | n -> n
-  )
-
-let write fd buf i len : unit =
-  let i = ref i in
-  let len = ref len in
-  while !len > 0 do
-    let n = write_once fd buf !i !len in
-    i := !i + n;
-    len := !len - n
-  done
-
-(** Sleep for the given amount of seconds *)
-let sleep_s (f : float) : unit =
-  if f > 0. then (
-    let trigger = Trigger.create () in
-    Perform_action_in_lwt.schedule
-    @@ Action.Sleep
-         ( f,
-           false,
-           fun cancel ->
-             Trigger.signal trigger;
-             Lwt_engine.stop_event cancel );
-    Trigger.await_exn trigger
-  )

src/lwt/IO_in.ml

@@ -1,153 +0,0 @@
-open Common_
-
-class type t = object
-  method input : bytes -> int -> int -> int
-  (** Read into the slice. Returns [0] only if the
-        stream is closed. *)
-
-  method close : unit -> unit
-  (** Close the input. Must be idempotent. *)
-end
-
-let create ?(close = ignore) ~input () : t =
-  object
-    method close = close
-    method input = input
-  end
-
-let empty : t =
-  object
-    method close () = ()
-    method input _ _ _ = 0
-  end
-
-let of_bytes ?(off = 0) ?len (b : bytes) : t =
-  (* i: current position in [b] *)
-  let i = ref off in
-
-  let len =
-    match len with
-    | Some n ->
-      if n > Bytes.length b - off then invalid_arg "Iostream.In.of_bytes";
-      n
-    | None -> Bytes.length b - off
-  in
-  let end_ = off + len in
-
-  object
-    method input b_out i_out len_out =
-      let n = min (end_ - !i) len_out in
-      Bytes.blit b !i b_out i_out n;
-      i := !i + n;
-      n
-
-    method close () = i := end_
-  end
-
-let of_string ?off ?len s : t = of_bytes ?off ?len (Bytes.unsafe_of_string s)
-
-(** Read into the given slice.
-      @return the number of bytes read, [0] means end of input. *)
-let[@inline] input (self : #t) buf i len = self#input buf i len
-
-(** Close the channel. *)
-let[@inline] close self : unit = self#close ()
-
-let rec really_input (self : #t) buf i len =
-  if len > 0 then (
-    let n = input self buf i len in
-    if n = 0 then raise End_of_file;
-    (really_input [@tailrec]) self buf (i + n) (len - n)
-  )
-
-let really_input_string self n : string =
-  let buf = Bytes.create n in
-  really_input self buf 0 n;
-  Bytes.unsafe_to_string buf
-
-let copy_into ?(buf = Bytes.create _default_buf_size) (ic : #t) (oc : IO_out.t)
-    : unit =
-  let continue = ref true in
-  while !continue do
-    let len = input ic buf 0 (Bytes.length buf) in
-    if len = 0 then
-      continue := false
-    else
-      IO_out.output oc buf 0 len
-  done
-
-let concat (l0 : t list) : t =
-  let l = ref l0 in
-  let rec input b i len : int =
-    match !l with
-    | [] -> 0
-    | ic :: tl ->
-      let n = ic#input b i len in
-      if n > 0 then
-        n
-      else (
-        l := tl;
-        input b i len
-      )
-  in
-  let close () = List.iter close l0 in
-  create ~close ~input ()
-
-let input_all ?(buf = Bytes.create 128) (self : #t) : string =
-  let buf = ref buf in
-  let i = ref 0 in
-
-  let[@inline] full_ () = !i = Bytes.length !buf in
-
-  let grow_ () =
-    let old_size = Bytes.length !buf in
-    let new_size = min Sys.max_string_length (old_size + (old_size / 4) + 10) in
-    if old_size = new_size then
-      failwith "input_all: maximum input size exceeded";
-    let new_buf = Bytes.extend !buf 0 (new_size - old_size) in
-    buf := new_buf
-  in
-
-  let rec loop () =
-    if full_ () then grow_ ();
-    let available = Bytes.length !buf - !i in
-    let n = input self !buf !i available in
-    if n > 0 then (
-      i := !i + n;
-      (loop [@tailrec]) ()
-    )
-  in
-  loop ();
-
-  if full_ () then
-    Bytes.unsafe_to_string !buf
-  else
-    Bytes.sub_string !buf 0 !i
-
-let of_unix_fd ?(close_noerr = false) ?(buf = Bytes.create _default_buf_size)
-    (fd : Unix.file_descr) : t =
-  let buf_len = ref 0 in
-  let buf_off = ref 0 in
-
-  let refill () =
-    buf_off := 0;
-    buf_len := IO.read fd buf 0 (Bytes.length buf)
-  in
-
-  object
-    method input b i len : int =
-      if !buf_len = 0 then refill ();
-      let n = min len !buf_len in
-      if n > 0 then (
-        Bytes.blit buf !buf_off b i n;
-        buf_off := !buf_off + n;
-        buf_len := !buf_len - n
-      );
-      n
-
-    method close () =
-      if close_noerr then (
-        try Unix.close fd with _ -> ()
-      ) else
-        Unix.close fd
-  end

src/lwt/IO_out.ml

@@ -1,118 +0,0 @@
-open Common_
-
-class type t = object
-  method output_char : char -> unit
-  method output : bytes -> int -> int -> unit
-  method flush : unit -> unit
-  method close : unit -> unit
-end
-
-let create ?(flush = ignore) ?(close = ignore) ~output_char ~output () : t =
-  object
-    method flush () = flush ()
-    method close () = close ()
-    method output_char c = output_char c
-    method output bs i len = output bs i len
-  end
-
-let dummy : t =
-  object
-    method flush () = ()
-    method close () = ()
-    method output_char _ = ()
-    method output _ _ _ = ()
-  end
-
-let of_unix_fd ?(close_noerr = false) ?(buf = Bytes.create _default_buf_size) fd
-    : t =
-  let buf_off = ref 0 in
-
-  let[@inline] is_full () = !buf_off = Bytes.length buf in
-
-  let flush () =
-    if !buf_off > 0 then (
-      IO.write fd buf 0 !buf_off;
-      buf_off := 0
-    )
-  in
-
-  object
-    method output_char c =
-      if is_full () then flush ();
-      Bytes.set buf !buf_off c;
-      incr buf_off
-
-    method output bs i len : unit =
-      let i = ref i in
-      let len = ref len in
-
-      while !len > 0 do
-        (* make space *)
-        if is_full () then flush ();
-
-        let n = min !len (Bytes.length buf - !buf_off) in
-        Bytes.blit bs !i buf !buf_off n;
-        buf_off := !buf_off + n;
-        i := !i + n;
-        len := !len - n
-      done;
-      (* if full, write eagerly *)
-      if is_full () then flush ()
-
-    method close () =
-      if close_noerr then (
-        try
-          flush ();
-          Unix.close fd
-        with _ -> ()
-      ) else (
-        flush ();
-        Unix.close fd
-      )
-
-    method flush = flush
-  end
-
-let of_buffer (buf : Buffer.t) : t =
-  object
-    method close () = ()
-    method flush () = ()
-    method output_char c = Buffer.add_char buf c
-    method output bs i len = Buffer.add_subbytes buf bs i len
-  end
-
-(** Output the buffer slice into this channel *)
-let[@inline] output_char (self : #t) c : unit = self#output_char c
-
-(** Output the buffer slice into this channel *)
-let[@inline] output (self : #t) buf i len : unit = self#output buf i len
-
-let[@inline] output_string (self : #t) (str : string) : unit =
-  self#output (Bytes.unsafe_of_string str) 0 (String.length str)
-
-let output_line (self : #t) (str : string) : unit =
-  output_string self str;
-  output_char self '\n'
-
-(** Close the channel. *)
-let[@inline] close self : unit = self#close ()
-
-(** Flush (ie. force write) any buffered bytes. *)
-let[@inline] flush self : unit = self#flush ()
-
-let output_int self i =
-  let s = string_of_int i in
-  output_string self s
-
-let output_lines self seq = Seq.iter (output_line self) seq
-
-let tee (l : t list) : t =
-  match l with
-  | [] -> dummy
-  | [ oc ] -> oc
-  | _ ->
-    let output bs i len = List.iter (fun oc -> output oc bs i len) l in
-    let output_char c = List.iter (fun oc -> output_char oc c) l in
-    let close () = List.iter close l in
-    let flush () = List.iter flush l in
-    create ~flush ~close ~output ~output_char ()

src/lwt/base.ml

@@ -1,167 +0,0 @@
-open Common_
-module Trigger = M.Trigger
-module Fiber = Moonpool_fib.Fiber
-module FLS = Moonpool_fib.Fls
-
-(** Action scheduled from outside the loop *)
-module Action = struct
-  type event = Lwt_engine.event
-  type cb = event -> unit
-
-  (** Action that we ask the lwt loop to perform, from the outside *)
-  type t =
-    | Wait_readable of Unix.file_descr * cb
-    | Wait_writable of Unix.file_descr * cb
-    | Sleep of float * bool * cb
-    (* TODO: provide actions with cancellation, alongside a "select" operation *)
-    (* | Cancel of event *)
-    | On_termination : 'a Lwt.t * 'a Exn_bt.result ref * Trigger.t -> t
-    | Wakeup : 'a Lwt.u * 'a -> t
-    | Wakeup_exn : _ Lwt.u * exn -> t
-    | Other of (unit -> unit)
-
-  (** Perform the action from within the Lwt thread *)
-  let perform (self : t) : unit =
-    match self with
-    | Wait_readable (fd, cb) -> ignore (Lwt_engine.on_readable fd cb : event)
-    | Wait_writable (fd, cb) -> ignore (Lwt_engine.on_writable fd cb : event)
-    | Sleep (f, repeat, cb) -> ignore (Lwt_engine.on_timer f repeat cb : event)
-    (* | Cancel ev -> Lwt_engine.stop_event ev *)
-    | On_termination (fut, res, trigger) ->
-      Lwt.on_any fut
-        (fun x ->
-          res := Ok x;
-          Trigger.signal trigger)
-        (fun exn ->
-          res := Error (Exn_bt.get_callstack 10 exn);
-          Trigger.signal trigger)
-    | Wakeup (prom, x) -> Lwt.wakeup prom x
-    | Wakeup_exn (prom, e) -> Lwt.wakeup_exn prom e
-    | Other f -> f ()
-end
-
-module Action_queue = struct
-  type t = { q: Action.t list Atomic.t } [@@unboxed]
-
-  let create () : t = { q = Atomic.make [] }
-  let pop_all (self : t) : _ list = Atomic.exchange self.q []
-
-  (** Push the action and return whether the queue was previously empty *)
-  let push (self : t) (a : Action.t) : bool =
-    let is_first = ref true in
-    while
-      let old = Atomic.get self.q in
-      if Atomic.compare_and_set self.q old (a :: old) then (
-        is_first := old == [];
-        false
-      ) else
-        true
-    do
-      ()
-    done;
-    !is_first
-end
-
-module Perform_action_in_lwt = struct
-  open struct
-    let actions_ : Action_queue.t = Action_queue.create ()
-
-    (** Gets the current set of notifications and perform them from inside the
-    Lwt thread *)
-    let perform_pending_actions () : unit =
-      let@ _sp =
-        Moonpool.Private.Tracing_.with_span
-          "moonpool-lwt.perform-pending-actions"
-      in
-
-      let l = Action_queue.pop_all actions_ in
-      List.iter Action.perform l
-
-    let notification : int =
-      Lwt_unix.make_notification ~once:false perform_pending_actions
-  end
-
-  let schedule (a : Action.t) : unit =
-    let is_first = Action_queue.push actions_ a in
-    if is_first then Lwt_unix.send_notification notification
-end
-
-let get_runner () : M.Runner.t =
-  match M.Runner.get_current_runner () with
-  | Some r -> r
-  | None -> failwith "Moonpool_lwt.get_runner: not inside a runner"
-
-let lwt_of_fut (fut : 'a M.Fut.t) : 'a Lwt.t =
-  let lwt_fut, lwt_prom = Lwt.wait () in
-  M.Fut.on_result fut (function
-    | Ok x -> Perform_action_in_lwt.schedule @@ Action.Wakeup (lwt_prom, x)
-    | Error ebt ->
-      let exn = Exn_bt.exn ebt in
-      Perform_action_in_lwt.schedule @@ Action.Wakeup_exn (lwt_prom, exn));
-  lwt_fut
-
-let fut_of_lwt (lwt_fut : _ Lwt.t) : _ M.Fut.t =
-  match Lwt.poll lwt_fut with
-  | Some x -> M.Fut.return x
-  | None ->
-    let fut, prom = M.Fut.make () in
-    Lwt.on_any lwt_fut
-      (fun x -> M.Fut.fulfill prom (Ok x))
-      (fun exn ->
-        let bt = Printexc.get_callstack 10 in
-        M.Fut.fulfill prom (Error (Exn_bt.make exn bt)));
-    fut
-
-let _dummy_exn_bt : Exn_bt.t =
-  Exn_bt.get_callstack 0 (Failure "dummy Exn_bt from moonpool-lwt")
-
-let await_lwt (fut : _ Lwt.t) =
-  match Lwt.poll fut with
-  | Some x -> x
-  | None ->
-    (* suspend fiber, wake it up when [fut] resolves *)
-    let trigger = M.Trigger.create () in
-    let res = ref (Error _dummy_exn_bt) in
-    Perform_action_in_lwt.(schedule Action.(On_termination (fut, res, trigger)));
-    Trigger.await trigger |> Option.iter Exn_bt.raise;
-    Exn_bt.unwrap !res
-
-let run_in_lwt f : _ M.Fut.t =
-  let fut, prom = M.Fut.make () in
-  Perform_action_in_lwt.schedule
-    (Action.Other
-       (fun () ->
-         let lwt_fut = f () in
-         Lwt.on_any lwt_fut
-           (fun x -> M.Fut.fulfill prom @@ Ok x)
-           (fun exn -> M.Fut.fulfill prom @@ Error (Exn_bt.get exn))));
-  fut
-
-let run_in_lwt_and_await f = M.Fut.await @@ run_in_lwt f
-
-let detach_in_runner ~runner f : _ Lwt.t =
-  let fut, promise = Lwt.wait () in
-  M.Runner.run_async runner (fun () ->
-      match f () with
-      | x -> Perform_action_in_lwt.schedule @@ Action.Wakeup (promise, x)
-      | exception exn ->
-        Perform_action_in_lwt.schedule @@ Action.Wakeup_exn (promise, exn));
-  fut
-
-let main_with_runner ~runner (f : unit -> 'a) : 'a =
-  let lwt_fut, lwt_prom = Lwt.wait () in
-
-  let _fiber =
-    Fiber.spawn_top ~on:runner (fun () ->
-        try
-          let x = f () in
-          Perform_action_in_lwt.schedule (Action.Wakeup (lwt_prom, x))
-        with exn ->
-          Perform_action_in_lwt.schedule (Action.Wakeup_exn (lwt_prom, exn)))
-  in
-
-  Lwt_main.run lwt_fut
-
-let main f =
-  let@ runner = M.Ws_pool.with_ () in
-  main_with_runner ~runner f

src/lwt/common_.ml

@@ -1,5 +0,0 @@
-module M = Moonpool
-module Exn_bt = M.Exn_bt
-
-let ( let@ ) = ( @@ )
-let _default_buf_size = 4 * 1024

src/lwt/dune

@@ -1,12 +1,10 @@
 (library
  (name moonpool_lwt)
  (public_name moonpool-lwt)
- (private_modules common_)
  (enabled_if
   (>= %{ocaml_version} 5.0))
  (libraries
   (re_export moonpool)
-  (re_export moonpool.fib)
   picos
   (re_export lwt)
   lwt.unix))

src/lwt/moonpool_lwt.ml

@@ -1,6 +1,310 @@
-include Base
-module IO = IO
-module IO_out = IO_out
-module IO_in = IO_in
-module TCP_server = Tcp_server
-module TCP_client = Tcp_client
+module Exn_bt = Moonpool.Exn_bt
+
+open struct
+  module WL = Moonpool.Private.Worker_loop_
+  module M = Moonpool
+end
+
+module Fut = Moonpool.Fut
+
+let on_uncaught_exn : (Moonpool.Exn_bt.t -> unit) ref =
+  ref (fun ebt ->
+      Printf.eprintf "uncaught exception in moonpool-lwt:\n%s" (Exn_bt.show ebt))
+
+module Scheduler_state = struct
+  type st = {
+    tasks: WL.task_full Queue.t;
+    actions_from_other_threads: (unit -> unit) Queue.t;
+        (** Other threads ask us to run closures in the lwt thread *)
+    mutex: Mutex.t;
+    mutable thread: int;
+    closed: bool Atomic.t;
+    cleanup_done: bool Atomic.t;
+    mutable as_runner: Moonpool.Runner.t;
+    mutable enter_hook: Lwt_main.Enter_iter_hooks.hook option;
+    mutable leave_hook: Lwt_main.Leave_iter_hooks.hook option;
+    mutable notification: int;
+        (** A lwt_unix notification to wake up the event loop *)
+    has_notified: bool Atomic.t;
+  }
+
+  (** Main state *)
+  let cur_st : st option Atomic.t = Atomic.make None
+
+  let create_new () : st =
+    {
+      tasks = Queue.create ();
+      actions_from_other_threads = Queue.create ();
+      mutex = Mutex.create ();
+      thread = Thread.id (Thread.self ());
+      closed = Atomic.make false;
+      cleanup_done = Atomic.make false;
+      as_runner = Moonpool.Runner.dummy;
+      enter_hook = None;
+      leave_hook = None;
+      notification = 0;
+      has_notified = Atomic.make false;
+    }
+
+  let[@inline] notify_ (self : st) : unit =
+    if not (Atomic.exchange self.has_notified true) then
+      Lwt_unix.send_notification self.notification
+
+  let[@inline never] add_action_from_another_thread_ (self : st) f : unit =
+    Mutex.lock self.mutex;
+    Queue.push f self.actions_from_other_threads;
+    Mutex.unlock self.mutex;
+    notify_ self
+
+  let[@inline] on_lwt_thread_ (self : st) : bool =
+    Thread.id (Thread.self ()) = self.thread
+
+  let[@inline] run_on_lwt_thread_ (self : st) (f : unit -> unit) : unit =
+    if on_lwt_thread_ self then
+      f ()
+    else
+      add_action_from_another_thread_ self f
+
+  let cleanup (st : st) =
+    match Atomic.get cur_st with
+    | Some st' ->
+      if st != st' then
+        failwith
+          "moonpool-lwt: cleanup failed (state is not the currently active \
+           one!)";
+      if not (on_lwt_thread_ st) then
+        failwith "moonpool-lwt: cleanup from the wrong thread";
+      Atomic.set st.closed true;
+      if not (Atomic.exchange st.cleanup_done true) then (
+        Option.iter Lwt_main.Enter_iter_hooks.remove st.enter_hook;
+        Option.iter Lwt_main.Leave_iter_hooks.remove st.leave_hook;
+        Lwt_unix.stop_notification st.notification
+      );
+
+      Atomic.set cur_st None
+    | None -> failwith "moonpool-lwt: cleanup failed (no current active state)"
+end
+
+module Ops = struct
+  type st = Scheduler_state.st
+
+  let schedule (self : st) t =
+    if Atomic.get self.closed then
+      failwith "moonpool-lwt.schedule: scheduler is closed";
+    Scheduler_state.run_on_lwt_thread_ self (fun () -> Queue.push t self.tasks)
+
+  let get_next_task (self : st) =
+    if Atomic.get self.closed then raise WL.No_more_tasks;
+    try Queue.pop self.tasks with Queue.Empty -> raise WL.No_more_tasks
+
+  let on_exn _ ebt = !on_uncaught_exn ebt
+  let runner (self : st) = self.as_runner
+  let cleanup = Scheduler_state.cleanup
+
+  let as_runner (self : st) : Moonpool.Runner.t =
+    Moonpool.Runner.For_runner_implementors.create
+      ~size:(fun () -> 1)
+      ~num_tasks:(fun () ->
+        Mutex.lock self.mutex;
+        let n = Queue.length self.tasks in
+        Mutex.unlock self.mutex;
+        n)
+      ~run_async:(fun ~fiber f -> schedule self @@ WL.T_start { fiber; f })
+      ~shutdown:(fun ~wait:_ () -> Atomic.set self.closed true)
+      ()
+
+  let before_start (self : st) : unit =
+    self.as_runner <- as_runner self;
+    ()
+
+  let ops : st WL.ops =
+    { schedule; get_next_task; on_exn; runner; before_start; cleanup }
+
+  let setup st =
+    if Atomic.compare_and_set Scheduler_state.cur_st None (Some st) then
+      before_start st
+    else
+      failwith "moonpool-lwt: setup failed (state already in place)"
+end
+
+(** Resolve [prom] with the result of [lwt_fut] *)
+let transfer_lwt_to_fut (lwt_fut : 'a Lwt.t) (prom : 'a Fut.promise) : unit =
+  Lwt.on_any lwt_fut
+    (fun x -> M.Fut.fulfill_idempotent prom (Ok x))
+    (fun exn ->
+      let bt = Printexc.get_callstack 10 in
+      M.Fut.fulfill_idempotent prom (Error (Exn_bt.make exn bt)))
+
+let[@inline] register_trigger_on_lwt_termination (lwt_fut : _ Lwt.t)
+    (tr : M.Trigger.t) : unit =
+  Lwt.on_termination lwt_fut (fun _ -> M.Trigger.signal tr)
+
+let[@inline] await_lwt_terminated (fut : _ Lwt.t) =
+  match Lwt.state fut with
+  | Return x -> x
+  | Fail exn -> raise exn
+  | Sleep -> assert false
+
+module Main_state = struct
+  let[@inline] get_st () : Scheduler_state.st =
+    match Atomic.get Scheduler_state.cur_st with
+    | Some st ->
+      if Atomic.get st.closed then failwith "moonpool-lwt: scheduler is closed";
+      st
+    | None -> failwith "moonpool-lwt: scheduler is not setup"
+
+  let[@inline] run_on_lwt_thread f =
+    Scheduler_state.run_on_lwt_thread_ (get_st ()) f
+
+  let[@inline] on_lwt_thread () : bool =
+    Scheduler_state.on_lwt_thread_ (get_st ())
+
+  let[@inline] add_action_from_another_thread f : unit =
+    Scheduler_state.add_action_from_another_thread_ (get_st ()) f
+end
+
+let await_lwt_from_another_thread fut =
+  let tr = M.Trigger.create () in
+  Main_state.add_action_from_another_thread (fun () ->
+      register_trigger_on_lwt_termination fut tr);
+  M.Trigger.await_exn tr;
+  await_lwt_terminated fut
+
+let await_lwt (fut : _ Lwt.t) =
+  if Scheduler_state.on_lwt_thread_ (Main_state.get_st ()) then (
+    (* can directly access the future *)
+      match Lwt.state fut with
+    | Return x -> x
+    | Fail exn -> raise exn
+    | Sleep ->
+      let tr = M.Trigger.create () in
+      register_trigger_on_lwt_termination fut tr;
+      M.Trigger.await_exn tr;
+      await_lwt_terminated fut
+  ) else
+    await_lwt_from_another_thread fut
+
+let lwt_of_fut (fut : 'a M.Fut.t) : 'a Lwt.t =
+  if not (Main_state.on_lwt_thread ()) then
+    failwith "lwt_of_fut: not on the lwt thread";
+  let lwt_fut, lwt_prom = Lwt.wait () in
+
+  (* in lwt thread, resolve [lwt_fut] *)
+  let wakeup_using_res = function
+    | Ok x -> Lwt.wakeup lwt_prom x
+    | Error ebt ->
+      let exn = Exn_bt.exn ebt in
+      Lwt.wakeup_exn lwt_prom exn
+  in
+
+  M.Fut.on_result fut (fun res ->
+      Main_state.run_on_lwt_thread (fun () ->
+          (* can safely wakeup from the lwt thread *)
+          wakeup_using_res res));
+
+  lwt_fut
+
+let fut_of_lwt (lwt_fut : _ Lwt.t) : _ M.Fut.t =
+  if Main_state.on_lwt_thread () then (
+    match Lwt.state lwt_fut with
+    | Return x -> M.Fut.return x
+    | _ ->
+      let fut, prom = M.Fut.make () in
+      transfer_lwt_to_fut lwt_fut prom;
+      fut
+  ) else (
+    let fut, prom = M.Fut.make () in
+    Main_state.add_action_from_another_thread (fun () ->
+        transfer_lwt_to_fut lwt_fut prom);
+    fut
+  )
+
+module Setup_lwt_hooks (ARG : sig
+  val st : Scheduler_state.st
+end) =
+struct
+  open ARG
+
+  module FG =
+    WL.Fine_grained
+      (struct
+        include Scheduler_state
+
+        let st = st
+        let ops = Ops.ops
+      end)
+      ()
+
+  let run_in_hook () =
+    (* execute actions sent from other threads; first transfer them
+     all atomically to a local queue to reduce contention *)
+    let local_acts = Queue.create () in
+    Mutex.lock st.mutex;
+    Queue.transfer st.actions_from_other_threads local_acts;
+    Atomic.set st.has_notified false;
+    Mutex.unlock st.mutex;
+
+    Queue.iter (fun f -> f ()) local_acts;
+
+    (* run tasks *)
+    FG.run ~max_tasks:1000 ();
+
+    if not (Queue.is_empty st.tasks) then ignore (Lwt.pause () : unit Lwt.t);
+    ()
+
+  let setup () =
+    (* only one thread does this *)
+    FG.setup ~block_signals:false ();
+
+    st.thread <- Thread.self () |> Thread.id;
+    st.enter_hook <- Some (Lwt_main.Enter_iter_hooks.add_last run_in_hook);
+    st.leave_hook <- Some (Lwt_main.Leave_iter_hooks.add_last run_in_hook);
+    (* notification used to wake lwt up *)
+    st.notification <- Lwt_unix.make_notification ~once:false run_in_hook
+end
+
+let setup () : Scheduler_state.st =
+  let st = Scheduler_state.create_new () in
+  Ops.setup st;
+  let module Setup_lwt_hooks' = Setup_lwt_hooks (struct
+    let st = st
+  end) in
+  Setup_lwt_hooks'.setup ();
+  st
+
+let[@inline] is_setup () = Option.is_some @@ Atomic.get Scheduler_state.cur_st
+
+let spawn_lwt f : _ Lwt.t =
+  let st = Main_state.get_st () in
+  let lwt_fut, lwt_prom = Lwt.wait () in
+  M.run_async st.as_runner (fun () ->
+      try
+        let x = f () in
+        Lwt.wakeup lwt_prom x
+      with exn -> Lwt.wakeup_exn lwt_prom exn);
+  lwt_fut
+
+let spawn_lwt_ignore f = ignore (spawn_lwt f : unit Lwt.t)
+let on_lwt_thread = Main_state.on_lwt_thread
+
+let run_in_lwt_and_await (f : unit -> 'a) : 'a =
+  let st = Main_state.get_st () in
+  if Scheduler_state.on_lwt_thread_ st then
+    (* run immediately *)
+    f ()
+  else
+    await_lwt_from_another_thread @@ spawn_lwt f
+
+let lwt_main (f : _ -> 'a) : 'a =
+  let st = setup () in
+  (* make sure to cleanup *)
+  let finally () = Scheduler_state.cleanup st in
+  Fun.protect ~finally @@ fun () ->
+  let fut = spawn_lwt (fun () -> f st.as_runner) in
+  (* make sure the scheduler isn't already sleeping *)
+  Scheduler_state.notify_ st;
+  Lwt_main.run fut
+
+let[@inline] lwt_main_runner () =
+  let st = Main_state.get_st () in
+  st.as_runner

src/lwt/moonpool_lwt.mli

@@ -1,146 +1,73 @@
 (** Lwt_engine-based event loop for Moonpool.
 
-    In what follows, we mean by "lwt thread" the thread
-    running [Lwt_main.run] (so, the thread where the Lwt event
-    loop and all Lwt callbacks execute).
+    In what follows, we mean by "lwt thread" the thread running {!lwt_main}
+    (which wraps [Lwt_main.run]; so, the thread where the Lwt event loop and all
+    Lwt callbacks execute).
 
     {b NOTE}: this is experimental and might change in future versions.
 
-    @since 0.6 *)
+    @since 0.6
 
-module Fiber = Moonpool_fib.Fiber
-module FLS = Moonpool_fib.Fls
+    The API has entirely changed since 0.9 , see
+    https://github.com/c-cube/moonpool/pull/37 *)
+
+module Fut = Moonpool.Fut
 
 (** {2 Basic conversions} *)
 
 val fut_of_lwt : 'a Lwt.t -> 'a Moonpool.Fut.t
-(** [fut_of_lwt lwt_fut] makes a thread-safe moonpool future that
-    completes when [lwt_fut] does. This must be run from within
-    the Lwt thread. *)
+(** [fut_of_lwt lwt_fut] makes a thread-safe moonpool future that completes when
+    [lwt_fut] does. This can be run from any thread. *)
 
 val lwt_of_fut : 'a Moonpool.Fut.t -> 'a Lwt.t
-(** [lwt_of_fut fut] makes a lwt future that completes when
-    [fut] does. This must be called from the Lwt thread, and the result
-    must always be used only from inside the Lwt thread. *)
+(** [lwt_of_fut fut] makes a lwt future that completes when [fut] does. This
+    must be called from the Lwt thread, and the result must always be used only
+    from inside the Lwt thread.
+    @raise Failure if not run from the lwt thread. *)
 
 (** {2 Helpers on the moonpool side} *)
 
+val spawn_lwt : (unit -> 'a) -> 'a Lwt.t
+(** This spawns a task that runs in the Lwt scheduler. This function is thread
+    safe.
+    @raise Failure if {!lwt_main} was not called. *)
+
+val spawn_lwt_ignore : (unit -> unit) -> unit
+(** Like {!spawn_lwt} but ignores the result, like [Lwt.async]. This function is
+    thread safe. *)
+
 val await_lwt : 'a Lwt.t -> 'a
-(** [await_lwt fut] awaits a Lwt future from inside a task running on
-    a moonpool runner. This must be run from within a Moonpool runner
-    so that the await-ing effect is handled. *)
+(** [await_lwt fut] awaits a Lwt future from inside a task running on a moonpool
+    runner. This must be run from within a Moonpool runner so that the await-ing
+    effect is handled, but it doesn't have to run from inside the Lwt thread. *)
 
-val run_in_lwt : (unit -> 'a Lwt.t) -> 'a Moonpool.Fut.t
-(** [run_in_lwt f] runs [f()] from within the Lwt thread
-    and returns a thread-safe future. This can be run from anywhere. *)
+val run_in_lwt_and_await : (unit -> 'a) -> 'a
+(** [run_in_lwt_and_await f] runs [f()] in the lwt thread, just like
+    [spawn_lwt f], and then calls {!await_lwt} on the result. This means [f()]
+    can use Lwt functions and libraries, use {!await_lwt} on them freely, etc.
 
-val run_in_lwt_and_await : (unit -> 'a Lwt.t) -> 'a
-(** [run_in_lwt_and_await f] runs [f] in the Lwt thread, and
-    awaits its result. Must be run from inside a moonpool runner
-    so that the await-in effect is handled.
-
-    This is similar to [Moonpool.await @@ run_in_lwt f]. *)
-
-val get_runner : unit -> Moonpool.Runner.t
-(** Returns the runner from within which this is called.
-    Must be run from within a fiber.
-    @raise Failure if not run within a fiber *)
-
-(** {2 IO} *)
-
-(** IO using the Lwt event loop.
-
-    These IO operations work on non-blocking file descriptors
-    and rely on a [Lwt_engine] event loop being active (meaning,
-    [Lwt_main.run] is currently running in some thread).
-
-    Calling these functions must be done from a moonpool runner.
-    A function like [read] will first try to perform the IO action
-    directly (here, call {!Unix.read}); if the action fails because
-    the FD is not ready, then [await_readable] is called:
-    it suspends the fiber and subscribes it to Lwt to be awakened
-    when the FD becomes ready.
-*)
-module IO : sig
-  val read : Unix.file_descr -> bytes -> int -> int -> int
-  (** Read from the file descriptor *)
-
-  val await_readable : Unix.file_descr -> unit
-  (** Suspend the fiber until the FD is readable *)
-
-  val write_once : Unix.file_descr -> bytes -> int -> int -> int
-  (** Perform one write into the file descriptor *)
-
-  val await_writable : Unix.file_descr -> unit
-  (** Suspend the fiber until the FD is writable *)
-
-  val write : Unix.file_descr -> bytes -> int -> int -> unit
-  (** Loop around {!write_once} to write the entire slice. *)
-
-  val sleep_s : float -> unit
-  (** Suspend the fiber for [n] seconds. *)
-end
-
-module IO_in = IO_in
-(** Input channel *)
-
-module IO_out = IO_out
-(** Output channel *)
-
-module TCP_server : sig
-  type t = Lwt_io.server
-
-  val establish_lwt :
-    ?backlog:(* ?server_fd:Unix.file_descr -> *)
-             int ->
-    ?no_close:bool ->
-    runner:Moonpool.Runner.t ->
-    Unix.sockaddr ->
-    (Unix.sockaddr -> Lwt_io.input_channel -> Lwt_io.output_channel -> unit) ->
-    t
-  (** [establish ~runner addr handler] runs a TCP server in the Lwt
-        thread. When a client connects, a moonpool fiber is started on [runner]
-        to handle it. *)
-
-  val establish :
-    ?backlog:(* ?server_fd:Unix.file_descr -> *)
-             int ->
-    ?no_close:bool ->
-    runner:Moonpool.Runner.t ->
-    Unix.sockaddr ->
-    (Unix.sockaddr -> IO_in.t -> IO_out.t -> unit) ->
-    t
-  (** Like {!establish_lwt} but uses {!IO} to directly handle
-        reads and writes on client sockets. *)
-
-  val shutdown : t -> unit
-  (** Shutdown the server *)
-end
-
-module TCP_client : sig
-  val connect : Unix.sockaddr -> Unix.file_descr
-
-  val with_connect : Unix.sockaddr -> (IO_in.t -> IO_out.t -> 'a) -> 'a
-  (** Open a connection, and use {!IO} to read and write from
-      the socket in a non blocking way. *)
-
-  val with_connect_lwt :
-    Unix.sockaddr -> (Lwt_io.input_channel -> Lwt_io.output_channel -> 'a) -> 'a
-  (** Open a connection. *)
-end
-
-(** {2 Helpers on the lwt side} *)
-
-val detach_in_runner : runner:Moonpool.Runner.t -> (unit -> 'a) -> 'a Lwt.t
-(** [detach_in_runner ~runner f] runs [f] in the given moonpool runner,
-    and returns a lwt future. This must be run from within the thread
-    running [Lwt_main]. *)
+    This function must run from within a task running on a moonpool runner so
+    that it can [await_lwt]. *)
 
 (** {2 Wrappers around Lwt_main} *)
 
-val main_with_runner : runner:Moonpool.Runner.t -> (unit -> 'a) -> 'a
-(** [main_with_runner ~runner f] starts a Lwt-based event loop and runs [f()] inside
-    a fiber in [runner]. *)
+val on_uncaught_exn : (Moonpool.Exn_bt.t -> unit) ref
+(** Exception handler for tasks that raise an uncaught exception. *)
 
-val main : (unit -> 'a) -> 'a
-(** Like {!main_with_runner} but with a default choice of runner. *)
+val lwt_main : (Moonpool.Runner.t -> 'a) -> 'a
+(** [lwt_main f] sets the moonpool-lwt bridge up, runs lwt main, calls [f],
+    destroys the bridge, and return the result of [f()]. Only one thread should
+    call this at a time. *)
+
+val on_lwt_thread : unit -> bool
+(** [on_lwt_thread ()] is true if the current thread is the one currently
+    running {!lwt_main}. This is thread safe.
+    @raise Failure if {!lwt_main} was not called. *)
+
+val lwt_main_runner : unit -> Moonpool.Runner.t
+(** The runner from {!lwt_main}. The runner is only going to work if {!lwt_main}
+    is currently running in some thread. This is thread safe.
+    @raise Failure if {!lwt_main} was not called. *)
+
+val is_setup : unit -> bool
+(** Is the moonpool-lwt bridge setup? This is thread safe. *)

src/lwt/tcp_client.ml

@@ -1,53 +0,0 @@
-open Common_
-open Base
-
-let connect addr : Unix.file_descr =
-  let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
-  Unix.set_nonblock sock;
-  Unix.setsockopt sock Unix.TCP_NODELAY true;
-
-  (* connect asynchronously *)
-  while
-    try
-      Unix.connect sock addr;
-      false
-    with
-    | Unix.Unix_error ((Unix.EWOULDBLOCK | Unix.EINPROGRESS | Unix.EAGAIN), _, _)
-    ->
-      IO.await_writable sock;
-      true
-  do
-    ()
-  done;
-  sock
-
-let with_connect addr (f : IO_in.t -> IO_out.t -> 'a) : 'a =
-  let sock = connect addr in
-
-  let ic = IO_in.of_unix_fd sock in
-  let oc = IO_out.of_unix_fd sock in
-
-  let finally () = try Unix.close sock with _ -> () in
-  let@ () = Fun.protect ~finally in
-  f ic oc
-
-let with_connect_lwt addr
-    (f : Lwt_io.input_channel -> Lwt_io.output_channel -> 'a) : 'a =
-  let sock = connect addr in
-
-  let ic =
-    run_in_lwt_and_await (fun () ->
-        Lwt.return @@ Lwt_io.of_unix_fd ~mode:Lwt_io.input sock)
-  in
-  let oc =
-    run_in_lwt_and_await (fun () ->
-        Lwt.return @@ Lwt_io.of_unix_fd ~mode:Lwt_io.output sock)
-  in
-
-  let finally () =
-    (try run_in_lwt_and_await (fun () -> Lwt_io.close ic) with _ -> ());
-    (try run_in_lwt_and_await (fun () -> Lwt_io.close oc) with _ -> ());
-    try Unix.close sock with _ -> ()
-  in
-  let@ () = Fun.protect ~finally in
-  f ic oc

src/lwt/tcp_server.ml

@@ -1,38 +0,0 @@
-open Common_
-open Base
-
-type t = Lwt_io.server
-
-let establish_lwt ?backlog ?no_close ~runner addr handler : t =
-  let server =
-    Lwt_io.establish_server_with_client_socket ?backlog ?no_close addr
-      (fun client_addr client_sock ->
-        let ic = Lwt_io.of_fd ~mode:Lwt_io.input client_sock in
-        let oc = Lwt_io.of_fd ~mode:Lwt_io.output client_sock in
-
-        let fut =
-          M.Fut.spawn ~on:runner (fun () -> handler client_addr ic oc)
-        in
-
-        let lwt_fut = lwt_of_fut fut in
-        lwt_fut)
-  in
-  await_lwt server
-
-let establish ?backlog ?no_close ~runner addr handler : t =
-  let server =
-    Lwt_io.establish_server_with_client_socket ?backlog ?no_close addr
-      (fun client_addr client_sock ->
-        let ic = IO_in.of_unix_fd @@ Lwt_unix.unix_file_descr client_sock in
-        let oc = IO_out.of_unix_fd @@ Lwt_unix.unix_file_descr client_sock in
-
-        let fut =
-          M.Fut.spawn ~on:runner (fun () -> handler client_addr ic oc)
-        in
-
-        let lwt_fut = lwt_of_fut fut in
-        lwt_fut)
-  in
-  await_lwt server
-
-let shutdown self = await_lwt @@ Lwt_io.shutdown_server self

src/private/atomic_.ml

@@ -1,46 +0,0 @@
-[@@@ifge 4.12]
-
-include Atomic
-
-[@@@else_]
-
-type 'a t = { mutable x: 'a }
-
-let[@inline] make x = { x }
-let[@inline] get { x } = x
-let[@inline] set r x = r.x <- x
-
-let[@inline never] exchange r x =
-  (* atomic *)
-  let y = r.x in
-  r.x <- x;
-  (* atomic *)
-  y
-
-let[@inline never] compare_and_set r seen v =
-  (* atomic *)
-  if r.x == seen then (
-    r.x <- v;
-    (* atomic *)
-    true
-  ) else
-    false
-
-let[@inline never] fetch_and_add r x =
-  (* atomic *)
-  let v = r.x in
-  r.x <- x + r.x;
-  (* atomic *)
-  v
-
-let[@inline never] incr r =
-  (* atomic *)
-  r.x <- 1 + r.x
-(* atomic *)
-
-let[@inline never] decr r =
-  (* atomic *)
-  r.x <- r.x - 1
-(* atomic *)
-
-[@@@endif]

src/private/domain_.ml

@@ -1,4 +1,3 @@
-[@@@ifge 5.0]
 [@@@ocaml.alert "-unstable"]
 
 let recommended_number () = Domain.recommended_domain_count ()
@@ -10,18 +9,3 @@ let spawn : _ -> t = Domain.spawn
 let relax = Domain.cpu_relax
 let join = Domain.join
 let is_main_domain = Domain.is_main_domain
-
-[@@@ocaml.alert "+unstable"]
-[@@@else_]
-
-let recommended_number () = 1
-
-type t = Thread.t
-
-let get_id (self : t) : int = Thread.id self
-let spawn f : t = Thread.create f ()
-let relax () = Thread.yield ()
-let join = Thread.join
-let is_main_domain () = true
-
-[@@@endif]

src/private/dune

@@ -2,9 +2,6 @@
  (name moonpool_private)
  (public_name moonpool.private)
  (synopsis "Private internal utils for Moonpool (do not rely on)")
- (preprocess
-  (action
-   (run %{project_root}/src/cpp/cpp.exe %{input-file})))
  (libraries
   threads
   either

src/private/signals_.ml

@@ -0,0 +1,15 @@
+let ignore_signals_ () =
+  try
+    Thread.sigmask SIG_BLOCK
+      [
+        Sys.sigpipe;
+        Sys.sigbus;
+        Sys.sigterm;
+        Sys.sigchld;
+        Sys.sigalrm;
+        Sys.sigint;
+        Sys.sigusr1;
+        Sys.sigusr2;
+      ]
+    |> ignore
+  with _ -> ()

src/private/ws_deque_.ml

@@ -1,4 +1,4 @@
-module A = Atomic_
+module A = Atomic
 
 (* terminology:
 

src/private/ws_deque_.mli

@@ -1,11 +1,10 @@
 (** Work-stealing deque.
 
-  Adapted from "Dynamic circular work stealing deque", Chase & Lev.
+    Adapted from "Dynamic circular work stealing deque", Chase & Lev.
 
-  However note that this one is not dynamic in the sense that there
-  is no resizing. Instead we return [false] when [push] fails, which
-  keeps the implementation fairly lightweight.
-  *)
+    However note that this one is not dynamic in the sense that there is no
+    resizing. Instead we return [false] when [push] fails, which keeps the
+    implementation fairly lightweight. *)
 
 type 'a t
 (** Deque containing values of type ['a] *)
@@ -14,12 +13,12 @@ val create : dummy:'a -> unit -> 'a t
 (** Create a new deque. *)
 
 val push : 'a t -> 'a -> bool
-(** Push value at the bottom of deque. returns [true] if it succeeds.
-    This must be called only by the owner thread. *)
+(** Push value at the bottom of deque. returns [true] if it succeeds. This must
+    be called only by the owner thread. *)
 
 val pop : 'a t -> 'a option
-(** Pop value from the bottom of deque.
-    This must be called only by the owner thread. *)
+(** Pop value from the bottom of deque. This must be called only by the owner
+    thread. *)
 
 exception Empty
 

src/sync/dune

@@ -1,5 +0,0 @@
-(library
- (name moonpool_sync)
- (public_name moonpool.sync)
- (synopsis "Cooperative synchronization primitives for Moonpool")
- (libraries moonpool picos picos_std.sync picos_std.event))

src/sync/event.ml

@@ -1,11 +0,0 @@
-include Picos_std_event.Event
-
-let[@inline] of_fut (fut : _ Moonpool.Fut.t) : _ t =
-  from_computation (Moonpool.Fut.Private_.as_computation fut)
-
-module Infix = struct
-  let[@inline] ( let+ ) x f = map f x
-  let ( >|= ) = ( let+ )
-end
-
-include Infix

src/sync/event.mli

@@ -1,12 +0,0 @@
-include module type of struct
-  include Picos_std_event.Event
-end
-
-val of_fut : 'a Moonpool.Fut.t -> 'a t
-
-module Infix : sig
-  val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t
-  val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
-end
-
-include module type of Infix

src/sync/lock.ml

@@ -1,38 +0,0 @@
-module Mutex = Picos_std_sync.Mutex
-
-type 'a t = {
-  mutex: Mutex.t;
-  mutable content: 'a;
-}
-
-let create content : _ t = { mutex = Mutex.create (); content }
-
-let with_ (self : _ t) f =
-  Mutex.lock self.mutex;
-  try
-    let x = f self.content in
-    Mutex.unlock self.mutex;
-    x
-  with e ->
-    Mutex.unlock self.mutex;
-    raise e
-
-let[@inline] mutex self = self.mutex
-let[@inline] update self f = with_ self (fun x -> self.content <- f x)
-
-let[@inline] update_map l f =
-  with_ l (fun x ->
-      let x', y = f x in
-      l.content <- x';
-      y)
-
-let get l =
-  Mutex.lock l.mutex;
-  let x = l.content in
-  Mutex.unlock l.mutex;
-  x
-
-let set l x =
-  Mutex.lock l.mutex;
-  l.content <- x;
-  Mutex.unlock l.mutex

src/sync/lock.mli

@@ -1,56 +0,0 @@
-(** Mutex-protected resource.
-
-    This lock is a synchronous concurrency primitive, as a thin wrapper
-    around {!Mutex} that encourages proper management of the critical
-    section in RAII style:
-
-    {[
-      let (let@) = (@@)
-
-
-      …
-      let compute_foo =
-        (* enter critical section *)
-        let@ x = Lock.with_ protected_resource in
-        use_x;
-        return_foo ()
-        (* exit critical section *)
-      in
-      …
-    ]}
-
-    This lock is based on {!Picos_sync.Mutex} so it is [await]-safe.
-
-    @since 0.7 *)
-
-type 'a t
-(** A value protected by a cooperative mutex *)
-
-val create : 'a -> 'a t
-(** Create a new protected value. *)
-
-val with_ : 'a t -> ('a -> 'b) -> 'b
-(** [with_ l f] runs [f x] where [x] is the value protected with
-    the lock [l], in a critical section. If [f x] fails, [with_lock l f]
-    fails too but the lock is released. *)
-
-val update : 'a t -> ('a -> 'a) -> unit
-(** [update l f] replaces the content [x] of [l] with [f x], while protected
-    by the mutex. *)
-
-val update_map : 'a t -> ('a -> 'a * 'b) -> 'b
-(** [update_map l f] computes [x', y = f (get l)], then puts [x'] in [l]
-    and returns [y], while protected by the mutex. *)
-
-val mutex : _ t -> Picos_std_sync.Mutex.t
-(** Underlying mutex. *)
-
-val get : 'a t -> 'a
-(** Atomically get the value in the lock. The value that is returned
-    isn't protected! *)
-
-val set : 'a t -> 'a -> unit
-(** Atomically set the value.
-
-    {b NOTE} caution: using {!get} and {!set} as if this were a {!ref}
-    is an anti pattern and will not protect data against some race conditions. *)

src/sync/moonpool_sync.ml

@@ -1,9 +0,0 @@
-module Mutex = Picos_std_sync.Mutex
-module Condition = Picos_std_sync.Condition
-module Lock = Lock
-module Event = Event
-module Semaphore = Picos_std_sync.Semaphore
-module Lazy = Picos_std_sync.Lazy
-module Latch = Picos_std_sync.Latch
-module Ivar = Picos_std_sync.Ivar
-module Stream = Picos_std_sync.Stream

test/dune

@@ -10,8 +10,7 @@
   t_resource
   t_unfair
   t_ws_deque
-  t_ws_wait
-  t_bounded_queue)
+  t_ws_wait)
  (package moonpool)
  (libraries
   moonpool

test/effect-based/dune

@@ -9,9 +9,6 @@
   t_sort
   t_fork_join
   t_fork_join_heavy)
- (preprocess
-  (action
-   (run %{project_root}/src/cpp/cpp.exe %{input-file})))
  (enabled_if
   (and
    (= %{system} "linux")

test/effect-based/t_fib1.ml

@@ -1,5 +1,3 @@
-[@@@ifge 5.0]
-
 open Moonpool
 
 let ( let@ ) = ( @@ )
@@ -56,5 +54,3 @@ let main () =
 let () =
   let@ () = Trace_tef.with_setup () in
   main ()
-
-[@@@endif]

test/effect-based/t_fib_fork_join.ml

@@ -1,5 +1,3 @@
-[@@@ifge 5.0]
-
 open Moonpool
 module FJ = Moonpool_forkjoin
 
@@ -52,5 +50,3 @@ let () =
   (* now make sure we can do this with multiple pools in parallel *)
   let jobs = Array.init 2 (fun _ -> Thread.create run_test ()) in
   Array.iter Thread.join jobs
-
-[@@@endif]

test/effect-based/t_fib_fork_join_all.ml

@@ -1,5 +1,3 @@
-[@@@ifge 5.0]
-
 let ( let@ ) = ( @@ )
 
 open Moonpool
@@ -44,5 +42,3 @@ let () =
   (* now make sure we can do this with multiple pools in parallel *)
   let jobs = Array.init 2 (fun _ -> Thread.create run_test ()) in
   Array.iter Thread.join jobs
-
-[@@@endif]

test/effect-based/t_fork_join.ml

@@ -1,5 +1,3 @@
-[@@@ifge 5.0]
-
 let spf = Printf.sprintf
 let ( let@ ) = ( @@ )
 
@@ -328,5 +326,3 @@ let () =
       t_for_nested ~min:1 ~chunk_size:100 ();
       t_for_nested ~min:4 ~chunk_size:100 ();
     ]
-
-[@@@endif]

test/effect-based/t_fork_join_heavy.ml

@@ -1,5 +1,3 @@
-[@@@ifge 5.0]
-
 module Q = QCheck
 
 let spf = Printf.sprintf
@@ -52,5 +50,3 @@ let () =
   run ~min:4 ();
   run ~min:1 ();
   Printf.printf "done\n%!"
-
-[@@@endif]

test/effect-based/t_futs1.ml

@@ -1,5 +1,3 @@
-[@@@ifge 5.0]
-
 open! Moonpool
 
 let pool = Ws_pool.create ~num_threads:4 ()
@@ -53,5 +51,3 @@ let () =
   in
   let fut = Fut.both f1 f2 in
   assert (Fut.wait_block fut = Ok (2, 20))
-
-[@@@endif]

test/effect-based/t_many.ml

@@ -1,5 +1,3 @@
-[@@@ifge 5.0]
-
 open Moonpool
 
 let ( let@ ) = ( @@ )
@@ -44,5 +42,3 @@ let () =
    run ~pool ());
 
   ()
-
-[@@@endif]

test/effect-based/t_sort.ml

@@ -1,5 +1,3 @@
-[@@@ifge 5.0]
-
 open Moonpool
 module FJ = Moonpool_forkjoin
 
@@ -69,5 +67,3 @@ let () =
   (* Printf.printf "arr: [%s]\n%!" *)
   (*   (String.concat ", " @@ List.map string_of_int @@ Array.to_list arr); *)
   assert (sorted arr)
-
-[@@@endif]

test/fiber/dune

@@ -4,8 +4,8 @@
   (>= %{ocaml_version} 5.0))
  (package moonpool)
  (libraries
+  t_fibers
   moonpool
-  moonpool.fib
   trace
   trace-tef
   qcheck-core

test/fiber/lib/dune

@@ -0,0 +1,5 @@
+(library
+ (name t_fibers)
+ (package moonpool)
+ (optional)
+ (libraries moonpool trace qcheck-core hmap))

test/fiber/lib/fib.ml

@@ -0,0 +1,170 @@
+module Chan = Moonpool.Chan
+module Exn_bt = Moonpool.Exn_bt
+module A = Atomic
+module Fut = Moonpool.Fut
+
+let ( let@ ) = ( @@ )
+
+module TS = struct
+  type t = int list
+
+  let show (s : t) = String.concat "." @@ List.map string_of_int s
+  let init = [ 0 ]
+
+  let next_ = function
+    | [] -> [ 0 ]
+    | n :: tl -> (n + 1) :: tl
+
+  let tick (t : t ref) = t := next_ !t
+
+  let tick_get t =
+    tick t;
+    !t
+end
+
+(* more deterministic logging of events *)
+module Log_ = struct
+  let events : (TS.t * string) list A.t = A.make []
+
+  let add_event t msg : unit =
+    while
+      let old = A.get events in
+      not (A.compare_and_set events old ((t, msg) :: old))
+    do
+      ()
+    done
+
+  let logf t fmt = Printf.ksprintf (add_event t) fmt
+
+  let print_and_clear () =
+    let l =
+      A.exchange events []
+      |> List.map (fun (ts, msg) -> List.rev ts, msg)
+      |> List.sort Stdlib.compare
+    in
+    List.iter (fun (ts, msg) -> Printf.printf "%s: %s\n" (TS.show ts) msg) l
+end
+
+let logf = Log_.logf
+
+let run1 ~runner () =
+  Printf.printf "============\nstart\n%!";
+  let clock = ref TS.init in
+  let fut =
+    Fut.spawn ~on:runner @@ fun () ->
+    let chan_progress = Chan.create ~max_size:4 () in
+    let chans = Array.init 5 (fun _ -> Chan.create ~max_size:4 ()) in
+
+    let subs =
+      List.init 5 (fun i ->
+          Fut.spawn ~on:runner @@ fun _n ->
+          Thread.delay (float i *. 0.01);
+          Chan.pop chans.(i);
+          Chan.push chan_progress i;
+          i)
+    in
+
+    logf (TS.tick_get clock) "wait for subs";
+
+    Moonpool.run_async runner (fun () ->
+        for i = 0 to 4 do
+          Chan.push chans.(i) ();
+          let i' = Chan.pop chan_progress in
+          assert (i = i')
+        done);
+
+    (let clock0 = !clock in
+     List.iteri
+       (fun i f ->
+         let clock = ref (0 :: i :: clock0) in
+         logf !clock "await fiber %d" i;
+         let res = Fut.await f in
+         Fut.yield ();
+         logf (TS.tick_get clock) "res %d = %d" i res)
+       subs);
+
+    logf (TS.tick_get clock) "main fiber done"
+  in
+
+  Fut.await fut;
+  logf (TS.tick_get clock) "main fiber exited";
+  Log_.print_and_clear ();
+  ()
+
+let run2 ~runner () =
+  (* same but now, cancel one of the sub-fibers *)
+  Printf.printf "============\nstart\n";
+
+  let to_await = ref [] in
+
+  let clock = ref TS.init in
+  let fut =
+    Fut.spawn ~on:runner @@ fun () ->
+    let chans_unblock = Array.init 10 (fun _i -> Chan.create ~max_size:4 ()) in
+    let chan_progress = Chan.create ~max_size:4 () in
+
+    logf (TS.tick_get clock) "start fibers";
+    let subs =
+      let clock0 = !clock in
+      List.init 10 (fun i ->
+          let clock = ref (0 :: i :: clock0) in
+          Fut.spawn ~on:runner @@ fun _n ->
+          Thread.delay 0.002;
+
+          (* sync for determinism *)
+          Chan.pop chans_unblock.(i);
+          Chan.push chan_progress i;
+
+          if i = 7 then (
+            logf (TS.tick_get clock) "I'm fiber %d and I'm about to fail…" i;
+            failwith "oh no!"
+          );
+
+          i)
+    in
+
+    let post = TS.tick_get clock in
+    List.iteri
+      (fun i fib ->
+        Fut.on_result fib (function
+          | Ok _ -> logf (i :: post) "fiber %d resolved as ok" i
+          | Error _ -> logf (i :: post) "fiber %d resolved as error" i))
+      subs;
+
+    (* sequentialize the fibers, for determinism *)
+    let sender =
+      Fut.spawn ~on:runner (fun () ->
+          for j = 0 to 9 do
+            Chan.push chans_unblock.(j) ();
+            let j' = Chan.pop chan_progress in
+            assert (j = j')
+          done)
+    in
+    to_await := sender :: !to_await;
+
+    logf (TS.tick_get clock) "wait for subs";
+    List.iteri
+      (fun i f ->
+        logf (TS.tick_get clock) "await fiber %d" i;
+        let res = Fut.await f in
+        logf (TS.tick_get clock) "res %d = %d" i res)
+      subs;
+    logf (TS.tick_get clock) "yield";
+    Fut.yield ();
+    logf (TS.tick_get clock) "yielded";
+    logf (TS.tick_get clock) "main fiber done"
+  in
+
+  Fut.on_result fut (function
+    | Ok () -> logf (TS.tick_get clock) "main fiber result: ok"
+    | Error ebt ->
+      logf (TS.tick_get clock) "main fiber result: error %s" (Exn_bt.show ebt));
+
+  (try Fut.await fut
+   with Failure msg -> logf (TS.tick_get clock) "main fib failed with %S" msg);
+  logf (TS.tick_get clock) "main fiber exited";
+
+  List.iter Fut.await !to_await;
+
+  Log_.print_and_clear ();
+  ()

test/fiber/lib/fls.ml

@@ -0,0 +1,166 @@
+open! Moonpool
+module A = Atomic
+module F = Moonpool.Fut
+module FLS = Moonpool.Task_local_storage
+
+(* ### dummy little tracing system with local storage *)
+
+type span_id = int
+
+let k_parent : span_id Hmap.key = Hmap.Key.create ()
+let ( let@ ) = ( @@ )
+let spf = Printf.sprintf
+
+module Span = struct
+  let new_id_ : unit -> span_id =
+    let n = A.make 0 in
+    fun () -> A.fetch_and_add n 1
+
+  type t = {
+    id: span_id;
+    parent: span_id option;
+    msg: string;
+  }
+end
+
+module Tracer = struct
+  type t = { spans: Span.t list A.t }
+
+  let create () : t = { spans = A.make [] }
+  let get self = A.get self.spans
+
+  let add (self : t) span =
+    while
+      let old = A.get self.spans in
+      not (A.compare_and_set self.spans old (span :: old))
+    do
+      ()
+    done
+
+  let with_span self name f =
+    let id = Span.new_id_ () in
+    let parent = FLS.get_in_local_hmap_opt k_parent in
+    let span = { Span.id; parent; msg = name } in
+    add self span;
+    FLS.with_in_local_hmap k_parent id f
+end
+
+module Render = struct
+  type span_tree = {
+    msg: string;  (** message of the span at the root *)
+    children: span_tree list;
+  }
+
+  type t = { roots: span_tree list }
+
+  let build (tracer : Tracer.t) : t =
+    let tops : (span_id, Span.t) Hashtbl.t = Hashtbl.create 16 in
+    let children : (span_id, Span.t list) Hashtbl.t = Hashtbl.create 16 in
+
+    (* everyone is a root at first *)
+    let all_spans = Tracer.get tracer in
+    List.iter (fun (sp : Span.t) -> Hashtbl.add tops sp.id sp) all_spans;
+
+    (* now consider the parenting relationships *)
+    let add_span_to_parent (span : Span.t) =
+      match span.parent with
+      | None -> ()
+      | Some p ->
+        Hashtbl.remove tops span.id;
+        let l = try Hashtbl.find children p with Not_found -> [] in
+        Hashtbl.replace children p (span :: l)
+    in
+    List.iter add_span_to_parent all_spans;
+
+    (* build the tree *)
+    let rec build_tree (sp : Span.t) : span_tree =
+      let children = try Hashtbl.find children sp.id with Not_found -> [] in
+      let children = List.map build_tree children |> List.sort Stdlib.compare in
+      { msg = sp.msg; children }
+    in
+
+    let roots =
+      Hashtbl.fold (fun _ sp l -> build_tree sp :: l) tops []
+      |> List.sort Stdlib.compare
+    in
+
+    { roots }
+
+  let pp (oc : out_channel) (self : t) : unit =
+    let rec pp_tree indent out (t : span_tree) =
+      let prefix = String.make indent ' ' in
+      Printf.fprintf out "%s%S\n" prefix t.msg;
+      List.iter (pp_tree (indent + 2) out) t.children
+    in
+    List.iter (pp_tree 2 oc) self.roots
+end
+
+let run ~pool ~pool_name () =
+  let tracer = Tracer.create () in
+
+  let sub_sub_child ~idx ~idx_child ~idx_sub ~idx_sub_sub () =
+    let@ () =
+      Tracer.with_span tracer
+        (spf "child_%d.%d.%d.%d" idx idx_child idx_sub idx_sub_sub)
+    in
+
+    for j = 1 to 5 do
+      let@ () = Tracer.with_span tracer (spf "iter.loop %d" j) in
+      F.yield ()
+    done
+  in
+
+  let sub_child ~idx ~idx_child ~idx_sub () =
+    let@ () =
+      Tracer.with_span tracer (spf "child_%d.%d.%d" idx idx_child idx_sub)
+    in
+
+    for i = 1 to 10 do
+      let@ () = Tracer.with_span tracer (spf "iter.loop %02d" i) in
+      F.yield ()
+    done;
+
+    let subs =
+      List.init 2 (fun idx_sub_sub ->
+          F.spawn ~on:pool (fun () ->
+              sub_sub_child ~idx ~idx_child ~idx_sub ~idx_sub_sub ()))
+    in
+    List.iter F.await subs
+  in
+
+  let top_child ~idx ~idx_child () =
+    let@ () = Tracer.with_span tracer (spf "child.%d.%d" idx idx_child) in
+
+    let subs =
+      List.init 2 (fun k ->
+          F.spawn ~on:pool @@ fun () -> sub_child ~idx ~idx_child ~idx_sub:k ())
+    in
+
+    let@ () =
+      Tracer.with_span tracer
+        (spf "child.%d.%d.99.await_children" idx idx_child)
+    in
+    List.iter F.await subs
+  in
+
+  let top idx =
+    let@ () = Tracer.with_span tracer (spf "top_%d" idx) in
+
+    let subs =
+      List.init 5 (fun j ->
+          F.spawn ~on:pool @@ fun () -> top_child ~idx ~idx_child:j ())
+    in
+
+    List.iter F.await subs
+  in
+
+  Printf.printf "run test on pool = %s\n" pool_name;
+  let fibs = List.init 8 (fun idx -> F.spawn ~on:pool (fun () -> top idx)) in
+  List.iter F.await fibs;
+
+  Printf.printf "tracing complete\n";
+  Printf.printf "spans:\n";
+  let tree = Render.build tracer in
+  Render.pp stdout tree;
+  Printf.printf "done\n%!";
+  ()

test/fiber/t_fib1.expected

@@ -2,33 +2,21 @@
 start
 1: wait for subs
 1.0.0: await fiber 0
-1.0.1: cur fiber[0] is some: true
-1.0.2: cur fiber[0] is some: true
-1.0.3: res 0 = 0
+1.0.1: res 0 = 0
 1.1.0: await fiber 1
-1.1.1: cur fiber[1] is some: true
-1.1.2: cur fiber[1] is some: true
-1.1.3: res 1 = 1
+1.1.1: res 1 = 1
 1.2.0: await fiber 2
-1.2.1: cur fiber[2] is some: true
-1.2.2: cur fiber[2] is some: true
-1.2.3: res 2 = 2
+1.2.1: res 2 = 2
 1.3.0: await fiber 3
-1.3.1: cur fiber[3] is some: true
-1.3.2: cur fiber[3] is some: true
-1.3.3: res 3 = 3
+1.3.1: res 3 = 3
 1.4.0: await fiber 4
-1.4.1: cur fiber[4] is some: true
-1.4.2: cur fiber[4] is some: true
-1.4.3: res 4 = 4
+1.4.1: res 4 = 4
 2: main fiber done
 3: main fiber exited
 ============
 start
 1: start fibers
 1.7.1: I'm fiber 7 and I'm about to fail…
-1.8.1: sub-fiber 8 was cancelled
-1.9.1: sub-fiber 9 was cancelled
 2.0: fiber 0 resolved as ok
 2.1: fiber 1 resolved as ok
 2.2: fiber 2 resolved as ok
@@ -37,8 +25,8 @@ start
 2.5: fiber 5 resolved as ok
 2.6: fiber 6 resolved as ok
 2.7: fiber 7 resolved as error
-2.8: fiber 8 resolved as error
-2.9: fiber 9 resolved as error
+2.8: fiber 8 resolved as ok
+2.9: fiber 9 resolved as ok
 3: wait for subs
 4: await fiber 0
 5: res 0 = 0
@@ -55,7 +43,6 @@ start
 16: await fiber 6
 17: res 6 = 6
 18: await fiber 7
-19: main fiber cancelled with Failure("oh no!")
-20: main fiber result: error Failure("oh no!")
-21: main fib failed with "oh no!"
-22: main fiber exited
+19: main fiber result: error Failure("oh no!")
+20: main fib failed with "oh no!"
+21: main fiber exited

test/fiber/t_fib1.ml

@@ -1,179 +1,6 @@
-open! Moonpool
-module A = Atomic
-module F = Moonpool_fib.Fiber
-
 let ( let@ ) = ( @@ )
-let runner = Fifo_pool.create ~num_threads:1 ()
-
-module TS = struct
-  type t = int list
-
-  let show (s : t) = String.concat "." @@ List.map string_of_int s
-  let init = [ 0 ]
-
-  let next_ = function
-    | [] -> [ 0 ]
-    | n :: tl -> (n + 1) :: tl
-
-  let tick (t : t ref) = t := next_ !t
-
-  let tick_get t =
-    tick t;
-    !t
-end
-
-(* more deterministic logging of events *)
-module Log_ = struct
-  let events : (TS.t * string) list A.t = A.make []
-
-  let add_event t msg : unit =
-    while
-      let old = A.get events in
-      not (A.compare_and_set events old ((t, msg) :: old))
-    do
-      ()
-    done
-
-  let logf t fmt = Printf.ksprintf (add_event t) fmt
-
-  let print_and_clear () =
-    let l =
-      A.exchange events []
-      |> List.map (fun (ts, msg) -> List.rev ts, msg)
-      |> List.sort Stdlib.compare
-    in
-    List.iter (fun (ts, msg) -> Printf.printf "%s: %s\n" (TS.show ts) msg) l
-end
-
-let logf = Log_.logf
 
 let () =
-  Printf.printf "============\nstart\n";
-  let clock = ref TS.init in
-  let fib =
-    F.spawn_top ~on:runner @@ fun () ->
-    let chan_progress = Chan.create ~max_size:4 () in
-    let chans = Array.init 5 (fun _ -> Chan.create ~max_size:4 ()) in
-
-    let subs =
-      List.init 5 (fun i ->
-          F.spawn ~protect:false @@ fun _n ->
-          Thread.delay (float i *. 0.01);
-          Chan.pop chans.(i);
-          Chan.push chan_progress i;
-          F.check_if_cancelled ();
-          i)
-    in
-
-    logf (TS.tick_get clock) "wait for subs";
-
-    F.spawn_ignore (fun () ->
-        for i = 0 to 4 do
-          Chan.push chans.(i) ();
-          let i' = Chan.pop chan_progress in
-          assert (i = i')
-        done);
-
-    (let clock0 = !clock in
-     List.iteri
-       (fun i f ->
-         let clock = ref (0 :: i :: clock0) in
-         logf !clock "await fiber %d" i;
-         logf (TS.tick_get clock) "cur fiber[%d] is some: %b" i
-           (Option.is_some @@ F.Private_.get_cur_opt ());
-         let res = F.await f in
-         logf (TS.tick_get clock) "cur fiber[%d] is some: %b" i
-           (Option.is_some @@ F.Private_.get_cur_opt ());
-         F.yield ();
-         logf (TS.tick_get clock) "res %d = %d" i res)
-       subs);
-
-    logf (TS.tick_get clock) "main fiber done"
-  in
-
-  Fut.wait_block_exn @@ F.res fib;
-  logf (TS.tick_get clock) "main fiber exited";
-  Log_.print_and_clear ();
-  ()
-
-let () =
-  let@ _r = Moonpool_fib.main in
-  (* same but now, cancel one of the sub-fibers *)
-  Printf.printf "============\nstart\n";
-
-  let clock = ref TS.init in
-  let fib =
-    F.spawn_top ~on:runner @@ fun () ->
-    let@ () =
-      F.with_on_self_cancel (fun ebt ->
-          logf (TS.tick_get clock) "main fiber cancelled with %s"
-          @@ Exn_bt.show ebt)
-    in
-
-    let chans_unblock = Array.init 10 (fun _i -> Chan.create ~max_size:4 ()) in
-    let chan_progress = Chan.create ~max_size:4 () in
-
-    logf (TS.tick_get clock) "start fibers";
-    let subs =
-      let clock0 = !clock in
-      List.init 10 (fun i ->
-          let clock = ref (0 :: i :: clock0) in
-          F.spawn ~protect:false @@ fun _n ->
-          let@ () =
-            F.with_on_self_cancel (fun _ ->
-                logf (TS.tick_get clock) "sub-fiber %d was cancelled" i)
-          in
-          Thread.delay 0.002;
-
-          (* sync for determinism *)
-          Chan.pop chans_unblock.(i);
-          Chan.push chan_progress i;
-
-          if i = 7 then (
-            logf (TS.tick_get clock) "I'm fiber %d and I'm about to fail…" i;
-            failwith "oh no!"
-          );
-
-          F.check_if_cancelled ();
-          i)
-    in
-
-    let post = TS.tick_get clock in
-    List.iteri
-      (fun i fib ->
-        F.on_result fib (function
-          | Ok _ -> logf (i :: post) "fiber %d resolved as ok" i
-          | Error _ -> logf (i :: post) "fiber %d resolved as error" i))
-      subs;
-
-    (* sequentialize the fibers, for determinism *)
-    F.spawn_ignore (fun () ->
-        for j = 0 to 9 do
-          Chan.push chans_unblock.(j) ();
-          let j' = Chan.pop chan_progress in
-          assert (j = j')
-        done);
-
-    logf (TS.tick_get clock) "wait for subs";
-    List.iteri
-      (fun i f ->
-        logf (TS.tick_get clock) "await fiber %d" i;
-        let res = F.await f in
-        logf (TS.tick_get clock) "res %d = %d" i res)
-      subs;
-    logf (TS.tick_get clock) "yield";
-    F.yield ();
-    logf (TS.tick_get clock) "yielded";
-    logf (TS.tick_get clock) "main fiber done"
-  in
-
-  F.on_result fib (function
-    | Ok () -> logf (TS.tick_get clock) "main fiber result: ok"
-    | Error ebt ->
-      logf (TS.tick_get clock) "main fiber result: error %s" (Exn_bt.show ebt));
-
-  (try Fut.wait_block_exn @@ F.res fib
-   with Failure msg -> logf (TS.tick_get clock) "main fib failed with %S" msg);
-  logf (TS.tick_get clock) "main fiber exited";
-  Log_.print_and_clear ();
-  ()
+  let@ runner = Moonpool.main in
+  T_fibers.Fib.run1 ~runner ();
+  T_fibers.Fib.run2 ~runner ()