domain-local-await-1.0.1/0000755000175000017500000000000014707251211013645 5ustar kylekyledomain-local-await-1.0.1/update-gh-pages-for-tag0000755000175000017500000000260314557452702020117 0ustar kylekyle#!/bin/bash set -xeuo pipefail TMP=tmp NAME=domain-local-await MAIN=doc GIT="git@github.com:ocaml-multicore/$NAME.git" DOC="_build/default/_doc/_html" GH_PAGES=gh-pages TAG="$1" if ! [ -e $NAME.opam ] || [ $# -ne 1 ] || \ { [ "$TAG" != main ] && ! [ "$(git tag -l "$TAG")" ]; }; then CMD="${0##*/}" cat << EOF Usage: $CMD tag-name-or-main This script - clones the repository into a temporary directory ($TMP/$NAME), - builds the documentation for the specified tag or main, - updates $GH_PAGES branch with the documentation in directory for the tag, - prompts whether to also update the main documentation in $MAIN directory, and - prompts whether to push changes to $GH_PAGES. EOF exit 1 fi mkdir $TMP cd $TMP git clone $GIT cd $NAME git checkout "$TAG" dune build @doc --root=. git checkout $GH_PAGES if [ "$TAG" != main ]; then echo "Updating the $TAG doc." if [ -e "$TAG" ]; then git rm -rf "$TAG" fi cp -r $DOC "$TAG" git add "$TAG" fi read -p "Update the main doc? (y/N) " -n 1 -r echo if [[ $REPLY =~ ^[Yy]$ ]]; then if [ -e $MAIN ]; then git rm -rf $MAIN fi cp -r $DOC $MAIN git add $MAIN else echo "Skipped main doc update." fi git commit -m "Update $NAME doc for $TAG" read -p "Push changes to $GH_PAGES? (y/N) " -n 1 -r echo if ! [[ $REPLY =~ ^[Yy]$ ]]; then echo "Leaving $TMP for you to examine." exit 1 fi git push cd .. cd .. rm -rf $TMP domain-local-await-1.0.1/src/0000755000175000017500000000000014557452702014447 5ustar kylekyledomain-local-await-1.0.1/src/domain.ocaml4.ml0000644000175000017500000000014614557452702017427 0ustar kylekylemodule DLS = struct let new_key default = ref (default ()) let get = ( ! ) let set = ( := ) end domain-local-await-1.0.1/src/Domain_local_await.mli0000644000175000017500000001110314557452702020714 0ustar kylekyle(** A scheduler independent blocking mechanism. This is designed as a low level mechanism intended for writing higher level libraries that need to block in a scheduler friendly manner. A library that needs to suspend and later resume the current thread of execution may simply call {!prepare_for_await} to obtain a pair of [await] and [release] operations for the purpose. To provide an efficient and scheduler friendly implementation of the mechanism, schedulers may install an implementation by wrapping the scheduler main loop with a call to {!using}. The implementation is then stored in a domain, and optionally thread, local variable. The overhead that this imposes on a scheduler should be insignificant. An application can the choose to use schedulers that provide the necessary implementation. An implementation that works with plain domains and threads is provided as a default. The end result is effective interoperability between schedulers and concurrent programming libraries. *) (** {1 Interface for blocking} *) type t = { release : unit -> unit; (** [t.release ()] resumes the corresponding caller of [t.await ()] or does nothing in case the corresponding [t.await ()] has already resumed or the target fiber has been canceled. {b NOTE}: An implementation of [t.release ()] should never fail. *) await : unit -> unit; (** [t.await ()] suspends the caller at most until [t.release ()] is called. *) } (** Represents an asynchronous trigger. {b NOTE}: {!release} and {!await} should be parallelism-safe and ideally optimized with the assumption that {!release} may be called multiple times and even before {!await} is called. Furthermore, {!await} may be called at most once. *) val prepare_for_await : unit -> t (** [prepare_for_await ()] prepares and returns a trigger [t] for at most one use of [t.await ()] by calling the [prepare] function registered for the current domain. {!prepare_for_await} and {!t.await} are allowed to raise an (unspecified) exception that indicates that the caller's fiber has been canceled (and should terminate). If an exception is raised, then the caller should perform whatever cleanup is necessary to e.g. avoid space leaks. {b NOTE}: It is allowed for two different calls of [prepare_for_await] to return the same trigger and e.g. share a single trigger per domain or per fiber or even just have one single trigger. *) (** {1 Interface for schedulers} *) val using : prepare_for_await:(unit -> t) -> while_running:(unit -> 'a) -> 'a (** [using ~prepare_for_await ~while_running] registers the given asynchronous trigger mechanism for the current domain, or, if the domain has been configured to use {!per_thread} schedulers, the current systhread, for the duration of running the given scheduler. In other words, this sets the implementation of {!prepare_for_await} for blocking under the scheduler. {b NOTE}: The given [prepare_for_await] function is called every time {!prepare_for_await} is called while the scheduler is running. {b NOTE}: This is normally only called by libraries that implement schedulers and the specified [prepare_for_await] typically returns a trigger mechanism {!t} that tightly integrates with the scheduler by e.g. performing an effect to suspend the current fiber when {!t.await} is called. *) (** {2 Per thread configuration} *) include module type of Thread_intf val per_thread : (module Thread) -> unit (** [per_thread (module Thread)] configures the current domain to store and select the trigger mechanism per systhread. This can be called at most once per domain before any calls to {!prepare_for_await}. The reason why this is an opt-in feature is that this allows domain local await to be implemented without depending on [Thread] which also depends on [Unix]. Usage: {[ Domain.spawn @@ fun () -> Domain_local_await.per_thread (module Thread); (* ... *) () |> Thread.create (fun () -> Domain_local_await.using ~prepare_for_await:prepare_for_scheduler_a ~while_running:scheduler_a); () |> Thread.create (fun () -> Domain_local_await.using ~prepare_for_await:prepare_for_scheduler_b ~while_running:scheduler_b); (* ... *) ]} {b NOTE}: It is not necessary to use per systhread configuration on a domain unless you want different systhreads to use different schedulers. *) domain-local-await-1.0.1/src/Domain_local_await.ml0000644000175000017500000000712314557452702020552 0ustar kylekyletype t = { release : unit -> unit; await : unit -> unit } module Default = struct type t = { mutex : Mutex.t; condition : Condition.t } let init () = let t = let mutex = Mutex.create () and condition = Condition.create () in { mutex; condition } in fun () -> let released = ref false in let release () = if not !released then begin Mutex.lock t.mutex; if not !released then begin released := true; Mutex.unlock t.mutex; Condition.broadcast t.condition end else Mutex.unlock t.mutex end and await () = if not !released then begin Mutex.lock t.mutex; match while not !released do (* NOTE: [Condition.wait] may raise an asynchronous exception. *) Condition.wait t.condition t.mutex done with | () -> Mutex.unlock t.mutex | exception exn -> Mutex.unlock t.mutex; raise exn end in { release; await } end include Thread_intf type config = | Per_domain : { mutable prepare_for_await : unit -> t } -> config | Per_thread : { mutable prepare_for_await : unit -> t; self : unit -> 'handle; id : 'handle -> int; id_to_prepare : (unit -> t) Thread_table.t; } -> config let default_init = ref (fun () -> failwith "unimplemented") let default () = !default_init () let key = Domain.DLS.new_key @@ fun () -> Per_domain { prepare_for_await = default } (* Below we use [@poll error] and [@inline never] to ensure that there are no safe-points where thread switches might occur during critical section. *) let[@poll error] [@inline never] update_prepare_atomically state prepare_for_await = match state with | Per_domain r -> let current = r.prepare_for_await in if current == default then begin r.prepare_for_await <- prepare_for_await; prepare_for_await end else current | Per_thread r -> let current = r.prepare_for_await in if current == default then begin r.prepare_for_await <- prepare_for_await; prepare_for_await end else current let () = default_init := fun () -> let prepare_for_await = Default.init () in let prepare_for_await = update_prepare_atomically (Domain.DLS.get key) prepare_for_await in prepare_for_await () let per_thread (module Thread : Thread) = match Domain.DLS.get key with | Per_thread _ -> failwith "Domain_local_await: per_thread called twice on a single domain" | Per_domain { prepare_for_await } -> let open Thread in let id_to_prepare = Thread_table.create () in Domain.DLS.set key (Per_thread { prepare_for_await; self; id; id_to_prepare }) let using ~prepare_for_await ~while_running = match Domain.DLS.get key with | Per_domain r -> let previous = r.prepare_for_await in r.prepare_for_await <- prepare_for_await; Fun.protect while_running ~finally:(fun () -> r.prepare_for_await <- previous) | Per_thread r -> let id = r.id (r.self ()) in Thread_table.add r.id_to_prepare id prepare_for_await; Fun.protect while_running ~finally:(fun () -> Thread_table.remove r.id_to_prepare id) let prepare_for_await () = match Domain.DLS.get key with | Per_domain r -> r.prepare_for_await () | Per_thread r -> begin match Thread_table.find r.id_to_prepare (r.id (r.self ())) with | prepare -> prepare () | exception Not_found -> r.prepare_for_await () end domain-local-await-1.0.1/src/Thread_intf.ml0000644000175000017500000000027014557452702017227 0ustar kylekyle(** Signature for a minimal subset of the [Stdlib.Thread] module needed by domain local await. *) module type Thread = sig type t val self : unit -> t val id : t -> int end domain-local-await-1.0.1/src/dune0000644000175000017500000000066614557452702015335 0ustar kylekyle(* -*- tuareg -*- *) let maybe_threads = if Jbuild_plugin.V1.ocaml_version < "5" then "threads.posix" else "" let () = Jbuild_plugin.V1.send @@ {| (library (name Domain_local_await) (public_name domain-local-await) (libraries thread-table |} ^ maybe_threads ^ {| )) (rule (targets domain.ml) (deps domain.ocaml4.ml) (enabled_if (< %{ocaml_version} 5.0.0)) (action (progn (copy domain.ocaml4.ml domain.ml)))) |} domain-local-await-1.0.1/README.md0000644000175000017500000005540114557452702015144 0ustar kylekyle[API reference](https://ocaml-multicore.github.io/domain-local-await/doc/domain-local-await/Domain_local_await/index.html) # **domain-local-await** — Scheduler independent blocking A low level mechanism intended for writing higher level libraries that need to block in a scheduler friendly manner. A library that needs to suspend and later resume the current thread of execution may simply call [`prepare_for_await`](https://ocaml-multicore.github.io/domain-local-await/doc/domain-local-await/Domain_local_await/index.html#val-prepare_for_await) to obtain a pair of [`await`](https://ocaml-multicore.github.io/domain-local-await/doc/domain-local-await/Domain_local_await/index.html#type-t.await) and [`release`](https://ocaml-multicore.github.io/domain-local-await/doc/domain-local-await/Domain_local_await/index.html#type-t.release) operations for the purpose. To provide an efficient and scheduler friendly implementation of the mechanism, schedulers may install an implementation by wrapping the scheduler main loop with a call to [`using`](https://ocaml-multicore.github.io/domain-local-await/doc/domain-local-await/Domain_local_await/index.html#val-using). The implementation is then stored in a domain, and optionally thread, local variable. The overhead that this imposes on a scheduler should be insignificant. An application can then choose to use schedulers that provide the necessary implementation. An implementation that works with plain domains and threads is provided as a default. The end result is effective interoperability between schedulers and concurrent programming libraries. ## Contents - [Example: Concurrency-safe lazy](#example-concurrency-safe-lazy) - [Example: Scheduler-friendly Mutex](#example-scheduler-friendly-mutex) - [Example: Awaitable atomic locations](#example-awaitable-atomic-locations) - [Example: Transparently asynchronous IO](#example-transparently-asynchronous-io) - [References](#references) ## Example: Concurrency-safe lazy At the time of writing this, the documentation of the Stdlib `Lazy` module includes the following note: > Note: `Lazy.force` is not concurrency-safe. If you use this module with > multiple fibers, systhreads or domains, then you will need to add some locks. Let's build a draft of a concurrency-safe version of lazy using atomics and domain-local-await! First we need to require the library: ```ocaml # #require "domain-local-await" ``` Here is a pair of types to represent the internal state of a lazy computation: ```ocaml type 'a state = | Fun of (unit -> 'a) | Run of (unit -> unit) list | Val of 'a | Exn of exn type 'a lazy_t = 'a state Atomic.t ``` A lazy computation starts as a thunk: ```ocaml # let from_fun th = Atomic.make (Fun th) val from_fun : (unit -> 'a) -> 'a state Atomic.t = ``` Or can be directly constructed with the given value: ```ocaml # let from_val v = Atomic.make (Val v) val from_val : 'a -> 'a state Atomic.t = ``` The interesting bits are in the `force` implementation: ```ocaml # let rec force t = match Atomic.get t with | Val v -> v | Exn e -> raise e | Fun th as before -> if Atomic.compare_and_set t before (Run []) then let result = match th () with | v -> Val v | exception e -> Exn e in match Atomic.exchange t result with | (Val _ | Exn _ | Fun _) -> failwith "impossible" | Run waiters -> List.iter ((|>) ()) waiters; force t else force t | Run waiters as before -> let dla = Domain_local_await.prepare_for_await () in let after = Run (dla.release :: waiters) in if Atomic.compare_and_set t before after then match dla.await () with | () -> force t | exception cancelation_exn -> let rec cleanup () = match Atomic.get t with | (Val _ | Exn _ | Fun _) -> () | Run waiters as before -> let after = Run (List.filter ((!=) dla.release) waiters) in if not (Atomic.compare_and_set t before after) then cleanup () in cleanup (); raise cancelation_exn else force t val force : 'a state Atomic.t -> 'a = ``` First `force` examines the state of the lazy computation. In case the result is already known, the value is returned or the exception is raised. Otherwise either the computation is started or the current thread of execution is suspended using domain-local-await. Once the thunk returns, the lazy is updated with the new state, any awaiters are released, and then all the `force` attempts will retry to examine the result. Notice also that the above `force` implementation is careful to perform a `cleanup` in case the `await` call raises an exception, which indicates cancellation. Let's then try it by creating a lazy computation and forcing it from two different domains: ```ocaml # let hello = from_fun (fun () -> Unix.sleepf 0.25; "Hello!") val hello : string state Atomic.t = # let other = Domain.spawn (fun () -> force hello) val other : string Domain.t = # force hello - : string = "Hello!" # Domain.join other - : string = "Hello!" ``` Hello, indeed! Note that the above implementation of lazy is intentionally kept relatively simple. It could be optimized slightly to reduce allocations and proper propagation of exception backtraces should be implemented. It could also be useful to have a scheduler independent mechanism to get a unique id corresponding to the current fiber, systhread, or domain and store that in the lazy state to be able to give an error in case of recursive forcing. ## Example: Scheduler-friendly Mutex At the time of writing this, the Stdlib `Mutex` implementation does not take into account the possibility of having an effects based scheduler and simply blocks the current domain (or (sys)thread) without giving a potential scheduler the opportunity to schedule another fiber on the domain. Let's build a draft of a scheduler-friendly mutex using atomics and domain-local-await. Here is a pair of types to represent a mutex: ```ocaml type state = | Unlocked | Locked of (unit -> unit) list type mutex = state Atomic.t ``` Essentially, a mutex is either unlocked or locked with a list of awaiters. To construct a mutex we simply allocate a new atomic: ```ocaml # let mutex () = Atomic.make Unlocked val mutex : unit -> state Atomic.t = ``` The `unlock` operation just marks the mutex as unlocked and then wakes up all the awaiters: ```ocaml # let rec unlock t = match Atomic.exchange t Unlocked with | Unlocked -> invalid_arg "mutex: already unlocked" | Locked awaiters -> List.iter ((|>) ()) awaiters val unlock : state Atomic.t -> unit = ``` The `lock` operation is more complex: ```ocaml # let rec lock t = match Atomic.get t with | Unlocked -> if not (Atomic.compare_and_set t Unlocked (Locked [])) then lock t | Locked awaiters as before -> let dla = Domain_local_await.prepare_for_await () in let after = Locked (dla.release :: awaiters) in if Atomic.compare_and_set t before after then match dla.await () with | () -> lock t | exception cancellation_exn -> let rec cleanup () = match Atomic.get t with | Unlocked -> () | Locked awaiters as before -> if List.for_all ((==) dla.release) awaiters then let after = Locked (List.filter ((!=) dla.release) awaiters) in if not (Atomic.compare_and_set t before after) then cleanup () in cleanup (); raise cancellation_exn else lock t val lock : state Atomic.t -> unit = ``` In case the mutex is already locked, domain-local-await is used to `await` until the mutex is unlocked and the corresponding `release` is called. In case await raises, `unlock` makes sure to remove the `release` operation from the mutex to avoid a potential space leak. Let's then use the mutex in a simple example of increment a counter from multiple domains: ```ocaml # let mutex = mutex () val mutex : state Atomic.t = # let counter = ref 0 val counter : int ref = {contents = 0} # let domains = List.init 3 @@ fun _ -> Domain.spawn @@ fun () -> for _ = 1 to 10000 do lock mutex; incr counter; unlock mutex; done val domains : unit Domain.t list = [; ; ] # List.iter Domain.join domains - : unit = () # !counter - : int = 30000 ``` Note that, like with the previous lazy implementation, the above mutex implementation is intentionally kept relatively simple and can be improved in various ways. It would make sense to use a [backoff](https://github.com/ocaml-multicore/backoff) in case of contention. The representation could also be optimized to reduce memory usage. The above mutex implementation is also unfair. ## Example: Awaitable atomic locations Let's implement a simple awaitable atomic location abstraction. An awaitable location contains both the current value of the location and a list of awaiters, which are just `unit -> unit` functions: ```ocaml type 'a awaitable_atomic = ('a * (unit -> unit) list) Atomic.t ``` The constructor of awaitable locations just pairs the initial value with an empty list of awaiters: ```ocaml # let awaitable_atomic v : _ awaitable_atomic = Atomic.make (v, []) val awaitable_atomic : 'a -> 'a awaitable_atomic = ``` Operations that modify awaitable locations, like `fetch_and_add`, need to call the awaiters to wake them up after a successful modification: ```ocaml # let rec fetch_and_add x n = let (i, awaiters) as was = Atomic.get x in if Atomic.compare_and_set x was (i+n, []) then begin List.iter ((|>) ()) awaiters; i end else fetch_and_add x n val fetch_and_add : (int * (unit -> unit) list) Atomic.t -> int -> int = ``` We can also have read-only operations, like `get_as`, that can be used to await for an awaitable location to have a specific value: ```ocaml # let rec get_as fn x = let (v, awaiters) as was = Atomic.get x in match fn v with | Some w -> w | None -> let dla = Domain_local_await.prepare_for_await () in if Atomic.compare_and_set x was (v, dla.release :: awaiters) then match dla.await () with | () -> get_as fn x | exception cancelation_exn -> let rec cleanup () = let (w, awaiters) as was = Atomic.get x in if v == w then let awaiters = List.filter ((!=) dla.release) awaiters in if not (Atomic.compare_and_set x was (w, awaiters)) then cleanup () in cleanup (); raise cancelation_exn else get_as fn x val get_as : ('a -> 'b option) -> ('a * (unit -> unit) list) Atomic.t -> 'b = ``` Notice that we carefully cleaned up in case the `await` was canceled. We could, of course, also have operations that potentially awaits for the location to have an acceptable value before attempting modification. Let's leave that as an exercise. To test awaitable locations, let's first create a location: ```ocaml # let x = awaitable_atomic 0 val x : int awaitable_atomic = ``` And let's then create a thread that awaits until the value of the location has changed and then modifies the value of the location: ```ocaml # let a_thread = () |> Thread.create @@ fun () -> get_as (fun x -> if x = 0 then None else Some ()) x; fetch_and_add x 21 |> ignore val a_thread : Thread.t = ``` The other thread is now awaiting for the initial modification: ```ocaml # assert (0 = fetch_and_add x 21) - : unit = () ``` And we can await for the thread to perform its modification: ```ocaml # get_as (fun x -> if x <> 21 then Some x else None) x; - : int = 42 ``` Let's then finish by joining with the other thread: ```ocaml # Thread.join a_thread - : unit = () ``` ## Example: Transparently asynchronous IO As a final example, let's sketch out an implementation of something a bit more involved — transparently asynchronous IO. The idea is that we implement operations such as `read` and `write` on Unix file descriptors in such a way that they block in a scheduler friendly manner allowing other fibers to run while waiting for the IO. But first, we want to perform certain operations atomically. For that purpose we extend the `Atomic` module with a couple of helpers: ```ocaml version>=5.0.0 module Atomic = struct include Stdlib.Atomic let rec update t fn = let before = Atomic.get t in let after = fn before in if Atomic.compare_and_set t before after then before else update t fn let modify t fn = update t fn |> ignore end ``` Below is the asynchronous IO module. It exposes `read`, `write`, and `accept` operations on Unix file descriptors. The operations block in a scheduler friendly manner. The implementation automatically manages a systhread per domain that runs a `select` loop, which takes care of awaiting for IO operations to be immediately executable. The operations on file descriptors communicate with the `select` loop thread. ```ocaml version>=5.0.0 module Async_io : sig open Unix val read : file_descr -> bytes -> int -> int -> int val write : file_descr -> bytes -> int -> int -> int val accept : ?cloexec:bool -> file_descr -> file_descr * sockaddr end = struct module Awaiter = struct type t = { file_descr : Unix.file_descr; release : unit -> unit } let file_descr_of t = t.file_descr let rec signal aws file_descr = match aws with | [] -> () | aw :: aws -> if aw.file_descr == file_descr then aw.release () else signal aws file_descr let signal_or_wakeup wakeup aws file_descr = if file_descr == wakeup then begin let n = Unix.read file_descr (Bytes.create 1) 0 1 in assert (n = 1) end else signal aws file_descr let reject file_descr = List.filter (fun aw -> aw.file_descr != file_descr) end type state = { mutable state : [ `Init | `Locked | `Alive | `Dead ]; mutable pipe_out : Unix.file_descr; reading : Awaiter.t list Atomic.t; writing : Awaiter.t list Atomic.t; } let key = Domain.DLS.new_key @@ fun () -> { state = `Init; pipe_out = (* Unfortunately we cannot safely allocate a pipe here, so we use stdin as a dummy value. *) Unix.stdin; reading = Atomic.make []; writing = Atomic.make []; } let[@poll error] try_lock s = s.state == `Init && begin s.state <- `Locked; true end let needs_init s = s.state != `Alive let[@poll error] unlock s pipe_out = s.pipe_out <- pipe_out; s.state <- `Alive let wakeup s = let n = Unix.write s.pipe_out (Bytes.create 1) 0 1 in assert (n = 1) let rec init s = (* DLS initialization may be run multiple times, so we perform more involved initialization here. *) if try_lock s then begin (* The pipe is used to wake up the select after changing the lists of reading and writing file descriptors. *) let pipe_inn, pipe_out = Unix.pipe ~cloexec:true () in unlock s pipe_out; let t = () |> Thread.create @@ fun () -> (* This is the IO select loop that performs select and then wakes up fibers blocked on IO. *) while s.state != `Dead do let rs, ws, _ = Unix.select (pipe_inn :: List.map Awaiter.file_descr_of (Atomic.get s.reading)) (List.map Awaiter.file_descr_of (Atomic.get s.writing)) [] (-1.0) in List.iter (Awaiter.signal_or_wakeup pipe_inn (Atomic.get s.reading)) rs; List.iter (Awaiter.signal (Atomic.get s.writing)) ws; Atomic.modify s.reading (List.fold_right Awaiter.reject rs); Atomic.modify s.writing (List.fold_right Awaiter.reject ws); done; Unix.close pipe_inn; Unix.close pipe_out in Domain.at_exit @@ fun () -> s.state <- `Dead; wakeup s; Thread.join t end else if needs_init s then begin Thread.yield (); init s; end let get () = let s = Domain.DLS.get key in if needs_init s then init s; s let await s r file_descr = let Domain_local_await.{ await; release } = Domain_local_await.prepare_for_await () in let awaiter = Awaiter.{ file_descr; release } in Atomic.modify r (List.cons awaiter); wakeup s; try await () with cancellation_exn -> Atomic.modify r (List.filter ((!=) awaiter)); raise cancellation_exn let read file_descr bytes pos len = let s = get () in await s s.reading file_descr; Unix.read file_descr bytes pos len let write file_descr bytes pos len = let s = get () in await s s.writing file_descr; Unix.write file_descr bytes pos len let accept ?cloexec file_descr = let s = get () in await s s.reading file_descr; Unix.accept ?cloexec file_descr end ``` To demonstrate that we can perform IO operations without blocking the thread we implement a very minimalistic effects based toy scheduler. We could also use any existing scheduler that provides support for domain-local-await ([see](#references)). ```ocaml version>=5.0.0 module Toy_scheduler : sig val fiber : (unit -> unit) -> unit val run : (unit -> unit) -> unit end = struct type _ Effect.t += | Suspend : (('a, unit) Effect.Deep.continuation -> unit) -> 'a Effect.t let ready = Atomic.make [] let num_alive_fibers = ref 0 let fiber thunk = incr num_alive_fibers; let thunk () = thunk (); decr num_alive_fibers in Atomic.modify ready (List.cons thunk) let run program = let needs_wakeup = Atomic.make false in let pipe_inn, pipe_out = Unix.pipe ~cloexec:true () in let rec scheduler () = match Atomic.update ready (function [] -> [] | _::xs -> xs) with | work::_ -> let effc (type a) : a Effect.t -> _ = function | Suspend ef -> Some ef | _ -> None in Effect.Deep.try_with work () { effc }; scheduler () | [] -> if !num_alive_fibers <> 0 then begin if Atomic.get needs_wakeup then (* There are blocked fibers, so we wait for them to become unblocked. *) let _ = Unix.select [pipe_inn] [] [] (-1.0) in let n = Unix.read pipe_inn (Bytes.create 1) 0 1 in assert (n = 1) else (* There are blocked fibers, so we need to wait for them to become ready. But we need to check the ready list once more before we do so. *) Atomic.set needs_wakeup true; scheduler () end in let prepare_for_await _ = let state = Atomic.make `Init in let release () = if Atomic.get state != `Released then match Atomic.exchange state `Released with | `Awaiting k -> let thunk = Effect.Deep.continue k in Atomic.modify ready (List.cons thunk); if Atomic.get needs_wakeup && Atomic.compare_and_set needs_wakeup true false then (* The scheduler is potentially waiting on select, so we need to perform a wakeup. *) let n = Unix.write pipe_out (Bytes.create 1) 0 1 in assert (n = 1) | _ -> () in let await () = if Atomic.get state != `Released then Effect.perform @@ Suspend (fun k -> if not (Atomic.compare_and_set state `Init (`Awaiting k)) then Effect.Deep.continue k ()) in Domain_local_await.{ release; await } in Domain_local_await.using ~prepare_for_await ~while_running:(fun () -> incr num_alive_fibers; let program () = program (); decr num_alive_fibers in Atomic.modify ready (List.cons program); scheduler ()) end ``` The toy scheduler and the async IO implementation do not depend on each other and, more generally, know nothing about each other. They simply _interoperate_ through the use of domain-local-await! Finally here is an example program that runs a client and a server fiber that communicate through sockets: ```ocaml version>=5.0.0 # Toy_scheduler.run @@ fun () -> let n = 100 in let port = Random.self_init (); Random.int 1000 + 3000 in let server_addr = Unix.ADDR_INET (Unix.inet_addr_loopback, port) in let () = Toy_scheduler.fiber @@ fun () -> Printf.printf " Client running\n%!"; let socket = Unix.socket ~cloexec:true PF_INET SOCK_STREAM 0 in Fun.protect ~finally:(fun () -> Unix.close socket) @@ fun () -> Unix.connect socket server_addr; Printf.printf " Client connected\n%!"; let bytes = Bytes.create n in let n = Async_io.write socket bytes 0 (Bytes.length bytes) in Printf.printf " Client wrote %d\n%!" n; let n = Async_io.read socket bytes 0 (Bytes.length bytes) in Printf.printf " Client read %d\n%!" n in let () = Toy_scheduler.fiber @@ fun () -> Printf.printf " Server running\n%!"; let client, _client_addr = let socket = Unix.socket ~cloexec:true PF_INET SOCK_STREAM 0 in Fun.protect ~finally:(fun () -> Unix.close socket) @@ fun () -> Unix.set_nonblock socket; Unix.bind socket server_addr; Unix.listen socket 1; Printf.printf " Server listening\n%!"; Async_io.accept ~cloexec:true socket in Fun.protect ~finally:(fun () -> Unix.close client) @@ fun () -> Unix.set_nonblock client; let bytes = Bytes.create n in let n = Async_io.read client bytes 0 (Bytes.length bytes) in Printf.printf " Server read %d\n%!" n; let n = Async_io.write client bytes 0 (n / 2) in Printf.printf " Server wrote %d\n%!" n in Printf.printf "Client server test\n%!" Client server test Server running Server listening Client running Client connected Client wrote 100 Server read 100 Server wrote 50 Client read 50 - : unit = () ``` This proof-of-concept shows that using just domain-local-await and a systhread we can implement scheduler agnostic transparently asynchronous IO. There is a lot of room for optimizations and other kinds of improvements. ## References DLA is used to implement blocking operations by the following libraries: - [Kcas](https://ocaml-multicore.github.io/kcas/) DLA support is provided by the following schedulers: - [Eio](https://github.com/ocaml-multicore/eio) (>= 0.10) - [Domainslib](https://github.com/ocaml-multicore/domainslib) (>= 0.5.1) - [Moonpool](https://github.com/c-cube/moonpool) (>= 0.3) domain-local-await-1.0.1/dune-project0000644000175000017500000000147414557452702016210 0ustar kylekyle(lang dune 3.8) (name domain-local-await) (version 1.0.1) (generate_opam_files true) (source (github ocaml-multicore/domain-local-await)) (authors "Vesa Karvonen ") (maintainers "Vesa Karvonen ") (homepage "https://github.com/ocaml-multicore/domain-local-await") (license "ISC") (implicit_transitive_deps false) (package (name domain-local-await) (synopsis "A scheduler independent blocking mechanism") (description "A low level mechanism intended for writing higher level libraries that need to block in a scheduler friendly manner.") (depends (ocaml (>= 4.12.0)) (thread-table (>= 1.0.0)) (alcotest (and (>= 1.7.0) :with-test)) (mdx (and (>= 2.3.0) :with-test)) (ocaml-version (and (>= 3.6.1) :with-test)) (domain_shims (and (>= 0.1.0) :with-test)))) (using mdx 0.4) domain-local-await-1.0.1/.ocamlformat0000644000175000017500000000007214557452702016164 0ustar kylekyleprofile = default version = 0.26.1 exp-grouping=preserve domain-local-await-1.0.1/LICENSE.md0000644000175000017500000000133214557452702015263 0ustar kylekyleCopyright © 2023 Vesa Karvonen Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. domain-local-await-1.0.1/.prettierrc0000644000175000017500000000021514557452702016042 0ustar kylekyle{ "arrowParens": "avoid", "bracketSpacing": false, "printWidth": 80, "semi": false, "singleQuote": true, "proseWrap": "always" } domain-local-await-1.0.1/domain-local-await.opam0000644000175000017500000000203114557452702020174 0ustar kylekyleversion: "1.0.1" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "A scheduler independent blocking mechanism" description: "A low level mechanism intended for writing higher level libraries that need to block in a scheduler friendly manner." maintainer: ["Vesa Karvonen "] authors: ["Vesa Karvonen "] license: "ISC" homepage: "https://github.com/ocaml-multicore/domain-local-await" bug-reports: "https://github.com/ocaml-multicore/domain-local-await/issues" depends: [ "dune" {>= "3.8"} "ocaml" {>= "4.12.0"} "thread-table" {>= "1.0.0"} "alcotest" {>= "1.7.0" & with-test} "mdx" {>= "2.3.0" & with-test} "ocaml-version" {>= "3.6.1" & with-test} "domain_shims" {>= "0.1.0" & 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/ocaml-multicore/domain-local-await.git"domain-local-await-1.0.1/.gitignore0000644000175000017500000000000714557452702015645 0ustar kylekyle_build domain-local-await-1.0.1/dune0000644000175000017500000000013614557452702014536 0ustar kylekyle(mdx (package domain-local-await) (deps (package domain-local-await)) (files README.md)) domain-local-await-1.0.1/test/0000755000175000017500000000000014557452702014637 5ustar kylekyledomain-local-await-1.0.1/test/test.ml0000644000175000017500000000177114557452702016156 0ustar kylekylelet[@poll error] [@inline never] push_atomically r before after = !r == before && begin r := after; true end let rec push r x = let before = !r in let after = x :: before in if not (push_atomically r before after) then push r x let test_all_threads_are_woken_up () = let n = ref 2 in let barrier = Domain_local_await.prepare_for_await () in let awaiters = ref [] in let threads = List.init !n @@ fun _ -> () |> Thread.create @@ fun () -> let t = Domain_local_await.prepare_for_await () in push awaiters t.release; decr n; if !n = 0 then barrier.release (); t.await () in barrier.await (); !awaiters |> List.iter (fun awaiter -> awaiter ()); threads |> List.iter Thread.join let basics () = test_all_threads_are_woken_up (); Domain_local_await.per_thread (module Thread); test_all_threads_are_woken_up () let () = Alcotest.run "Domain_local_await" [ ("basics", [ Alcotest.test_case "" `Quick basics ]) ] domain-local-await-1.0.1/test/dune0000644000175000017500000000011314557452702015510 0ustar kylekyle(test (name test) (libraries domain-local-await threads.posix alcotest)) domain-local-await-1.0.1/HACKING.md0000644000175000017500000000064714557452702015255 0ustar kylekyle### Formatting This project uses [ocamlformat](https://github.com/ocaml-ppx/ocamlformat) (for OCaml) and [prettier](https://prettier.io/) (for Markdown). ### To make a new release 1. Update [CHANGES.md](CHANGES.md). 2. Run `dune-release tag VERSION` to create a tag for the new `VERSION`. 3. Run `dune-release` to publish the new `VERSION`. 4. Run `./update-gh-pages-for-tag VERSION` to update the online documentation. domain-local-await-1.0.1/.gitattributes0000644000175000017500000000006214557452702016551 0ustar kylekyle# To work around MDX issues README.md text eol=lf domain-local-await-1.0.1/CHANGES.md0000644000175000017500000000123414557452702015252 0ustar kylekyle# Release notes All notable changes to this project will be documented in this file. ## 1.0.1 - Add `(implicit_transitive_deps false)` (@polytypic) - Fix to unlock mutex even when condition wait raises (@polytypic) ## 1.0.0 - Internal improvements (@polytypic) - Change license to ISC from 0BSD (@tarides) ## 0.2.1 - Support OCaml 4.12.0+ (@polytypic) - Use lock-free thread-safe hash table for per thread configuration (@polytypic) ## 0.2.0 - Avoid unnecessary type alias for `(module Thread)` (@polytypic) - Fix to update per thread configuration atomically (@polytypic) ## 0.1.0 - Initial version of scheduler independent blocking mechanism (@polytypic) domain-local-await-1.0.1/.github/0000755000175000017500000000000014557452702015220 5ustar kylekyledomain-local-await-1.0.1/.github/workflows/0000755000175000017500000000000014557452702017255 5ustar kylekyledomain-local-await-1.0.1/.github/workflows/workflow.yml0000644000175000017500000000172414557452702021656 0ustar kylekylename: build-and-test on: pull_request: push: branches: - main jobs: build-windows: strategy: matrix: ocaml-compiler: - ocaml.5.0.0,ocaml-option-mingw - ocaml.5.1.1,ocaml-option-mingw runs-on: windows-latest env: QCHECK_MSG_INTERVAL: '60' steps: - name: Check out code uses: actions/checkout@v3 - name: Set up OCaml uses: ocaml/setup-ocaml@v2 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} opam-repositories: | dra27: https://github.com/dra27/opam-repository.git#windows-5.0 default: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset standard: https://github.com/ocaml/opam-repository.git - name: Install dependencies run: opam install . --deps-only --with-test - name: Build run: opam exec -- dune build - name: Test run: opam exec -- dune runtest