sharpetronics/eio
1
0
Fork 0
mirror of https://github.com/ocaml-multicore/eio.git synced 2025-08-29 00:03:47 -04:00
Code Issues Projects Releases Wiki Activity

Split cancellation out from Switch

Browse Source 
Cancellation and grouping are easier to handle separately.

`Fibre.both` no longer takes a switch, but instead just creates a new
cancellation context.
This commit is contained in:
Thomas Leonard 2021-11-09 09:47:03 +00:00
parent ed2382bed5
commit 3713d9470b
31 changed files with 773 additions and 681 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
README.md
View File

@ -15,7 +15,8 @@ This is an unreleased repository, as it's very much a work-in-progress.
* [Testing with Mocks](#testing-with-mocks)
* [Fibres](#fibres)
* [Tracing](#tracing)
* [Switches, Errors, and Cancellation](#switches-errors-and-cancellation)
* [Cancellation](#cancellation)
* [Switches](#switches)
* [Design Note: Results vs Exceptions](#design-note-results-vs-exceptions)
* [Performance](#performance)
* [Networking](#networking)
@ -153,8 +154,7 @@ Here's an example running two threads of execution (fibres) concurrently:
```ocaml
let main _env =
Switch.top @@ fun sw ->
Fibre.both ~sw
Fibre.both
(fun () -> for x = 1 to 3 do traceln "x = %d" x; Fibre.yield () done)
(fun () -> for y = 1 to 3 do traceln "y = %d" y; Fibre.yield () done);;
```
@ -204,17 +204,14 @@ The file is a ring buffer, so when it gets full, old events will start to be ove
This shows the two counting threads and the lifetime of the `sw` switch.
Note that the output from `traceln` appears in the trace as well as on the console.
## Switches, Errors, and Cancellation
## Cancellation
A switch is used to group fibres together, so they can be cancelled or waited on together.
This is a form of [structured concurrency][].
Here's what happens if one of the two threads above fails:
Every fibre has a cancellation context.
If one of the `Fibre.both` fibres fails, the other is cancelled:
```ocaml
# Eio_main.run @@ fun _env ->
Switch.top @@ fun sw ->
Fibre.both ~sw
Fibre.both
(fun () -> for x = 1 to 3 do traceln "x = %d" x; Fibre.yield () done)
(fun () -> failwith "Simulated error");;
+x = 1
@ -223,17 +220,27 @@ Exception: Failure "Simulated error".
What happened here was:
1. The first fibre ran, printed `x = 1` and yielded.
2. The second fibre raised an exception.
3. `Fibre.both` caught the exception and turned off the switch.
4. The first thread's `yield` saw the switch was off and raised a `Cancelled` exception there.
5. Once both threads had finished, `Fibre.both` re-raised the exception.
1. `Fibre.both` created a new cancellation context for the child fibres.
2. The first fibre ran, printed `x = 1` and yielded.
3. The second fibre raised an exception.
4. `Fibre.both` caught the exception and cancelled the context.
5. The first thread's `yield` raised a `Cancelled` exception there.
6. Once both threads had finished, `Fibre.both` re-raised the original exception.
Switches can also be used to wait for threads even when there isn't an error. e.g.
You should assume that any operation that can switch fibres can also raise a `Cancelled` exception if a sibling fibre crashes.
If you want to make an operation non-cancellable, wrap it with `Cancel.protect`
(this creates a new context that isn't cancelled with its parent).
## Switches
A switch is used to group fibres together, so they can be waited on together.
This is a form of [structured concurrency][].
For example:
```ocaml
# Eio_main.run @@ fun _env ->
Switch.top (fun sw ->
Switch.run (fun sw ->
Fibre.fork_ignore ~sw
(fun () -> for i = 1 to 3 do traceln "i = %d" i; Fibre.yield () done);
traceln "First thread forked";
@ -254,15 +261,31 @@ Switches can also be used to wait for threads even when there isn't an error. e.
- : unit = ()
```
`Switch.top` is used for top-level switches. You can also use `Fibre.fork_sub_ignore` to create a child sub-switch.
`Switch.run fn` creates a new switch `sw` and runs `fn sw`.
`fn` may spawn new fibres and attach them to the switch.
It may also attach other resources such as open file handles.
`Switch.run` waits until `fn` and all other attached fibres have finished, and then
releases any attached resources (e.g. closing all attached file handles).
If you call a function without giving it access to a switch,
then when the function returns you can be sure that any fibres it spawned have finished,
and any files it opened have been closed.
So, a `Switch.run` puts a bound on the lifetime of things created within it,
leading to clearer code and avoiding resource leaks.
For example, `fork_ignore` creates a new fibre that continues running after `fork_ignore` returns,
so it needs to take a switch argument.
Every switch also creates a new cancellation context,
and you can turn off the switch to cancel all fibres within it.
You can also use `Fibre.fork_sub_ignore` to create a child sub-switch.
Turning off the parent switch will also turn off the child switch, but turning off the child doesn't disable the parent.
For example, a web-server might use one switch for the whole server and then create one sub-switch for each incoming connection.
This allows you to end all fibres handling a single connection by turning off that connection's switch,
or to exit the whole application using the top-level switch.
If you want to make an operation non-cancellable, wrap it in a `Switch.top` to create a fresh switch.
## Design Note: Results vs Exceptions
The OCaml standard library uses exceptions to report errors in most cases.
@ -334,11 +357,11 @@ Eio provides a simple high-level API for networking.
Here is a client that connects to address `addr` using `network` and sends a message:
```ocaml
let run_client ~sw ~net ~addr =
let run_client ~net ~addr =
traceln "Connecting to server...";
Switch.run @@ fun sw ->
let flow = Eio.Net.connect ~sw net addr in
Eio.Flow.copy_string "Hello from client" flow;
Eio.Flow.shutdown flow `Send
Eio.Flow.copy_string "Hello from client" flow
```
Note: the `flow` is attached to `sw` and will be closed automatically when it finishes.
@ -346,13 +369,14 @@ Note: the `flow` is attached to `sw` and will be closed automatically when it fi
Here is a server that listens on `socket` and handles a single connection by reading a message:
```ocaml
let run_server ~sw socket =
let run_server socket =
Switch.run @@ fun sw ->
Eio.Net.accept_sub socket ~sw (fun ~sw flow _addr ->
traceln "Server accepted connection from client";
let b = Buffer.create 100 in
Eio.Flow.copy flow (Eio.Flow.buffer_sink b);
traceln "Server received: %S" (Buffer.contents b)
) ~on_error:(fun ex -> traceln "Error handling connection: %s" (Printexc.to_string ex));
) ~on_error:(traceln "Error handling connection: %a" Fmt.exn);
traceln "(normally we'd loop and accept more connections here)"
```
@ -366,12 +390,12 @@ We can test them in a single process using `Fibre.both`:
```ocaml
let main ~net ~addr =
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in
traceln "Server ready...";
Fibre.both ~sw
(fun () -> run_server ~sw server)
(fun () -> run_client ~sw ~net ~addr)
Fibre.both
(fun () -> run_server server)
(fun () -> run_client ~net ~addr)
```
```ocaml
@ -496,7 +520,7 @@ You can use `open_dir` (or `with_open_dir`) to create a restricted capability to
- : unit = ()
```
Please note: you only need to use `open_dir` if you want to create a new sandboxed environment.
You only need to use `open_dir` if you want to create a new sandboxed environment.
You can use a single directory object to access all paths beneath it,
and this allows following symlinks within that subtree.
@ -545,13 +569,12 @@ We can use `Eio.Domain_manager` to run this in a separate domain:
```ocaml
let main ~domain_mgr =
Switch.top @@ fun sw ->
let test n =
traceln "sum 1..%d = %d" n
(Eio.Domain_manager.run_compute_unsafe domain_mgr
(fun () -> sum_to n))
in
Fibre.both ~sw
Fibre.both
(fun () -> test 100000)
(fun () -> test 50000)
```

2
bench/bench.ml
View File

@ -7,7 +7,7 @@ let main ~clock =
n_fibres |> List.iter (fun n_fibres ->
let n_iters = 1000000 / n_fibres in
let t0 = Eio.Time.now clock in
Switch.top (fun sw ->
Switch.run (fun sw ->
for _ = 1 to n_fibres do
Fibre.fork_ignore ~sw (fun () ->
for _ = 1 to n_iters do

104
lib_eio/cancel.ml Normal file
View File

@ -0,0 +1,104 @@
open EffectHandlers
exception Cancel_hook_failed of exn list
exception Cancelled of exn
let () =
Printexc.register_printer @@ function
| Cancel_hook_failed exns -> Some ("During cancellation:\n" ^ String.concat "\nand\n" (List.map Printexc.to_string exns))
| Cancelled ex -> Some ("Cancelled: " ^ Printexc.to_string ex)
| _ -> None
type state =
| On of (exn -> unit) Lwt_dllist.t
| Cancelling of exn * Printexc.raw_backtrace
| Finished
type t = {
mutable state : state;
}
(* A dummy value for bootstrapping *)
let boot = {
state = Finished;
}
type _ eff += Set_cancel : t -> t eff
let check t =
match t.state with
| On _ -> ()
| Cancelling (ex, _) -> raise (Cancelled ex)
| Finished -> invalid_arg "Cancellation context finished!"
let get_error t =
match t.state with
| On _ -> None
| Cancelling (ex, _) -> Some (Cancelled ex)
| Finished -> Some (Invalid_argument "Cancellation context finished!")
let is_finished t =
match t.state with
| Finished -> true
| On _ | Cancelling _ -> false
let with_t fn =
let q = Lwt_dllist.create () in
let t = { state = On q } in
Fun.protect (fun () -> fn t)
~finally:(fun () -> t.state <- Finished)
let protect_full fn =
with_t @@ fun t ->
let x =
let old = perform (Set_cancel t) in
Fun.protect (fun () -> fn t)
~finally:(fun () -> ignore (perform (Set_cancel old)))
in
check t;
x
let protect fn = protect_full (fun (_ : t) -> fn ())
let add_hook_unwrapped t hook =
match t.state with
| Finished -> invalid_arg "Cancellation context finished!"
| Cancelling (ex, _) -> protect (fun () -> hook ex); Hook.null
| On q ->
let node = Lwt_dllist.add_r hook q in
(fun () -> Lwt_dllist.remove node)
let add_hook t hook = add_hook_unwrapped t (fun ex -> hook (Cancelled ex))
let cancel t ex =
match t.state with
| Finished -> invalid_arg "Cancellation context finished!"
| Cancelling _ -> ()
| On q ->
let bt = Printexc.get_raw_backtrace () in
t.state <- Cancelling (ex, bt);
let rec aux () =
match Lwt_dllist.take_opt_r q with
| None -> []
| Some f ->
match f ex with
| () -> aux ()
| exception ex2 -> ex2 :: aux ()
in
match protect aux with
| [] -> ()
| exns -> raise (Cancel_hook_failed exns)
let sub fn =
with_t @@ fun t ->
let x =
let old = perform (Set_cancel t) in
Fun.protect (fun () ->
let unhook = add_hook_unwrapped old (cancel t) in
Fun.protect (fun () -> fn t) ~finally:unhook
)
~finally:(fun () -> ignore (perform (Set_cancel old)))
in
check t;
x

31
lib_eio/eio.ml
View File

@ -1,5 +1,8 @@
open EffectHandlers
module Hook = Hook
module Cancel = Cancel
module Std = struct
module Promise = Promise
module Fibre = Fibre
@ -13,6 +16,7 @@ end
module Semaphore = Semaphore
module Stream = Stream
module Multiple_exn = Multiple_exn
open Std
@ -62,7 +66,6 @@ module Flow = struct
inherit source
method private read_source_buffer fn =
Fibre.yield ();
let rec aux () =
match data with
| [] -> raise End_of_file
@ -75,7 +78,6 @@ module Flow = struct
[ Read_source_buffer self#read_source_buffer ]
method read_into dst =
Fibre.yield ();
let avail, src = Cstruct.fillv ~dst ~src:data in
if avail = 0 then raise End_of_file;
data <- src;
@ -217,14 +219,14 @@ module Dir = struct
let open_dir ~sw (t:#t) = t#open_dir ~sw
let mkdir (t:#t) = t#mkdir
let with_open_in ?sw (t:#t) path fn =
Switch.sub_opt sw @@ fun sw -> fn (open_in ~sw t path)
let with_open_in (t:#t) path fn =
Switch.run @@ fun sw -> fn (open_in ~sw t path)
let with_open_out ?sw ?append ~create (t:#t) path fn =
Switch.sub_opt sw @@ fun sw -> fn (open_out ~sw ?append ~create t path)
let with_open_out ?append ~create (t:#t) path fn =
Switch.run @@ fun sw -> fn (open_out ~sw ?append ~create t path)
let with_open_dir ?sw (t:#t) path fn =
Switch.sub_opt sw @@ fun sw -> fn (open_dir ~sw t path)
let with_open_dir (t:#t) path fn =
Switch.run @@ fun sw -> fn (open_dir ~sw t path)
end
module Stdenv = struct
@ -250,16 +252,19 @@ module Stdenv = struct
end
module Private = struct
type context = Suspend.context = {
tid : Ctf.id;
mutable cancel : Cancel.t;
}
module Effects = struct
type 'a enqueue = 'a Suspend.enqueue
type _ eff +=
| Suspend = Suspend.Suspend
| Suspend_unchecked = Suspend.Suspend_unchecked
| Suspend = Suspend.Suspend
| Fork = Fibre.Fork
| Fork_ignore = Fibre.Fork_ignore
| Trace = Std.Trace
| Yield = Fibre.Yield
| Set_switch = Switch.Set_switch
| Set_cancel = Cancel.Set_cancel
end
let boot_switch = Switch.boot_switch
let boot_cancel = Cancel.boot
end

212
lib_eio/eio.mli
View File

@ -1,47 +1,44 @@
(** Effects based parallel IO for OCaml *)
(** Reporting multiple failures at once. *)
module Multiple_exn : sig
exception T of exn list
(** Raised if multiple fibres fail, to report all the exceptions. *)
end
(** Handles for removing callbacks. *)
module Hook : sig
type t
val remove : t -> unit
(** [remove t] removes a previously-added hook.
If the hook has already been removed, this does nothing. *)
val null : t
(** A dummy hook. Removing it does nothing. *)
end
(** {1 Concurrency primitives} *)
(** Commonly used standard features. This module is intended to be [open]ed. *)
module Std : sig
(** Controlling the lifetime of fibres (groups, exceptions, cancellations, timeouts). *)
(** Grouping fibres and other resources. *)
module Switch : sig
type t
(** A switch controls a group of fibres.
Once a switch is turned off, all activities in that context should cancel themselves. *)
(** A switch contains a group of fibres and other resources (such as open file handles).
Once a switch is turned off, the fibres should cancel themselves.
A switch is created with [Switch.run fn],
which does not return until all fibres attached to the switch have finished,
and all attached resources have been closed.
Each switch includes its own {!Cancel.t} context. *)
type hook
(** A handle to a cancellation hook. *)
exception Multiple_exceptions of exn list
exception Cancelled of exn
(** [Cancelled ex] indicates that the switch was turned off with exception [ex].
It is usually not necessary to report a [Cancelled] exception to the user,
as the original problem will be handled elsewhere. *)
val top : (t -> 'a) -> 'a
(** [top fn] runs [fn] with a fresh top-level switch (initially on).
When [fn] exits, [top] waits for all operations registered with the switch to finish
val run : (t -> 'a) -> 'a
(** [run fn] runs [fn] with a fresh switch (initially on).
When [fn] exits, [run] waits for all operations registered with the switch to finish
(it does not turn the switch off itself).
If the switch is turned off before it returns, [top] re-raises the switch's exception(s).
@raise Multiple_exceptions If [turn_off] is called more than once. *)
val sub : ?on_release:(unit -> unit) -> t -> on_error:(exn -> 'a) -> (t -> 'a) -> 'a
(** [sub sw ~on_error fn] is like [top fn], but the new switch is a child of [t], so that
cancelling [t] also cancels the child (but not the other way around).
If [fn] raises an exception then it is passed to [on_error].
If you only want to use [sub] to wait for a group of threads to finish, but not to contain
errors, you can use [~on_error:raise].
@param on_release Register this function with [Switch.on_release sub] once the sub-switch is created.
If creating the sub-switch fails, run it immediately. *)
val sub_opt : ?on_release:(unit -> unit) -> t option -> (t -> 'a) -> 'a
(** Run a function with a new switch, optionally a child of another switch.
[sub_opt (Some sw)] is [sub sw ~on_error:raise].
[sub None] is [top].
@param on_release Register this function with [Switch.on_release sub] once the new switch is created.
If creating the switch fails, run it immediately. *)
If the switch is turned off before it returns, [run] re-raises the switch's exception(s).
@raise Multiple_exn.T If [turn_off] is called more than once. *)
val check : t -> unit
(** [check t] checks that [t] is still on.
@ -66,27 +63,18 @@ module Std : sig
If you want to allow other release handlers to run concurrently, you can start the release
operation and then call [on_release] again from within [fn] to register a function to await the result.
This will be added to a fresh batch of handlers, run after the original set have finished.
Note that [fn] must work even if the switch has been turned off,
so using [sub t] or similar within [fn] is usually a bad idea. *)
Note that [fn] is called within a {!Cancel.protect}, since aborting clean-up actions is usually a bad idea
and the switch may have been cancelled by the time it runs. *)
val on_release_cancellable : t -> (unit -> unit) -> hook
val on_release_cancellable : t -> (unit -> unit) -> Hook.t
(** Like [on_release], but the handler can be removed later. *)
val add_cancel_hook : t -> (exn -> unit) -> hook
(** [add_cancel_hook t cancel] registers shutdown function [cancel] with [t].
val add_cancel_hook : t -> (exn -> unit) -> Hook.t
(** [add_cancel_hook t cancel] registers cancel function [cancel] with [t].
When [t] is turned off, [cancel] is called.
This can be used to encourage other fibres to exit.
If [Switch.run] returns successfully, the hook will not run.
If [t] is already off, it calls [cancel] immediately. *)
val add_cancel_hook_opt : t option -> (exn -> unit) -> hook
(**[add_cancel_hook_opt (Some t)] is [add_cancel_hook t].
If called with [None], it does nothing and returns {!null_hook}. *)
val remove_hook : hook -> unit
(** [remove_hook h] removes a hook.
If the hook has already been removed, this does nothing. *)
val null_hook : hook
(** A dummy hook. Removing it does nothing. *)
end
module Promise : sig
@ -100,16 +88,15 @@ module Std : sig
(** [create ()] is a fresh promise/resolver pair.
The promise is initially unresolved. *)
val await : ?sw:Switch.t -> 'a t -> 'a
val await : 'a t -> 'a
(** [await t] blocks until [t] is resolved.
If [t] is already resolved then this returns immediately.
If [t] is broken, it raises the exception.
@param sw Cancel wait if [sw] is turned off. *)
If [t] is broken, it raises the exception. *)
val await_result : ?sw:Switch.t -> 'a t -> ('a, exn) result
val await_result : 'a t -> ('a, exn) result
(** [await_result t] is like [await t], but returns [Error ex] if [t] is broken
instead of raising an exception.
Note that turning off [sw] still raises an exception. *)
Note that if the [await_result] itself is cancelled then it still raises. *)
val fulfill : 'a u -> 'a -> unit
(** [fulfill u v] successfully resolves [u]'s promise with the value [v].
@ -149,21 +136,29 @@ module Std : sig
end
module Fibre : sig
val both : sw:Switch.t -> (unit -> unit) -> (unit -> unit) -> unit
(** [both ~sw f g] runs [f ()] and [g ()] concurrently.
If either raises an exception, [sw] is turned off.
[both] waits for both functions to finish even if one raises. *)
val both : (unit -> unit) -> (unit -> unit) -> unit
(** [both f g] runs [f ()] and [g ()] concurrently.
They run in a new cancellation sub-context, and
if either raises an exception, the other is cancelled.
[both] waits for both functions to finish even if one raises
(it will then re-raise the original exception).
@raise Multiple_exn.T if both fibres raise exceptions (excluding {!Cancel.Cancelled}). *)
val fork_ignore : sw:Switch.t -> (unit -> unit) -> unit
(** [fork_ignore ~sw fn] runs [fn ()] in a new fibre, but does not wait for it to complete.
The new fibre is attached to [sw] (which can't finish until the fibre ends).
The new fibre inherits [sw]'s cancellation context.
If the fibre raises an exception, [sw] is turned off.
If [sw] is already off then [fn] fails immediately, but the calling thread continues. *)
val fork_sub_ignore : ?on_release:(unit -> unit) -> sw:Switch.t -> on_error:(exn -> unit) -> (Switch.t -> unit) -> unit
(** [fork_sub_ignore ~sw ~on_error fn] is like [fork_ignore], but it creates a new sub-switch for the fibre.
This means that you can cancel the child switch without cancelling the parent.
This is a convenience function for running {!Switch.sub} inside a {!fork_ignore}. *)
This is a convenience function for running {!Switch.run} inside a {!fork_ignore}.
@param on_release If given, this function is called when the new fibre ends.
If the fibre cannot be created (e.g. because [sw] is already off), it runs immediately.
@param on_error This is called if the fibre raises an exception.
If it raises in turn, the parent switch is turned off. *)
val fork : sw:Switch.t -> exn_turn_off:bool -> (unit -> 'a) -> 'a Promise.t
(** [fork ~sw ~exn_turn_off fn] starts running [fn ()] in a new fibre and returns a promise for its result.
@ -215,10 +210,9 @@ module Semaphore : sig
If other fibres are waiting on [t], the one that has been waiting the longest is resumed.
@raise Sys_error if the value of the semaphore would overflow [max_int] *)
val acquire : ?sw:Switch.t -> t -> unit
val acquire : t -> unit
(** [acquire t] blocks the calling fibre until the value of semaphore [t]
is not zero, then atomically decrements the value of [t] and returns.
@param sw Abort if the switch is turned off. *)
is not zero, then atomically decrements the value of [t] and returns. *)
val get_value : t -> int
(** [get_value t] returns the current value of semaphore [t]. *)
@ -233,17 +227,64 @@ module Stream : sig
(** [create capacity] is a new stream which can hold up to [capacity] items without blocking writers.
If [capacity = 0] then writes block until a reader is ready. *)
val add : ?sw:Switch.t -> 'a t -> 'a -> unit
val add : 'a t -> 'a -> unit
(** [add t item] adds [item] to [t].
If this would take [t] over capacity, it blocks until there is space.
@param sw Stop waiting if the switch is turned off. *)
If this would take [t] over capacity, it blocks until there is space. *)
val take : ?sw:Switch.t -> 'a t -> 'a
val take : 'a t -> 'a
(** [take t] takes the next item from the head of [t].
If no items are available, it waits until one becomes available.
@param sw Stop waiting if the switch is turned off. *)
If no items are available, it waits until one becomes available. *)
end
(** Cancelling other fibres when an exception occurs. *)
module Cancel : sig
(** This is the low-level interface to cancellation.
Every {!Switch} includes a cancellation context and most users will just use that API instead. *)
type t
(** A cancellation context. *)
exception Cancelled of exn
(** [Cancelled ex] indicates that the context was cancelled with exception [ex].
It is usually not necessary to report a [Cancelled] exception to the user,
as the original problem will be handled elsewhere. *)
exception Cancel_hook_failed of exn list
(** Raised by {!cancel} if any of the cancellation hooks themselves fail. *)
val sub : (t -> 'a) -> 'a
(** [sub fn] installs a new cancellation context [t], runs [fn t] inside it, and then restores the old context.
If the old context is cancelled while [fn] is running then [t] is cancelled too.
[t] cannot be used after [sub] returns. *)
val protect : (unit -> 'a) -> 'a
(** [protect fn] runs [fn] in a new cancellation context that isn't cancelled when its parent is.
This can be used to clean up resources on cancellation.
However, it is usually better to use {!Switch.on_release} (which calls this for you). *)
val protect_full : (t -> 'a) -> 'a
(** [protect_full fn] is like {!protect}, but also gives access to the new context. *)
val check : t -> unit
(** [check t] checks that [t] hasn't been cancelled.
@raise Cancelled If the context has been cancelled. *)
val get_error : t -> exn option
(** [get_error t] is like [check t] except that it returns the exception instead of raising it.
If [t] is finished, this returns (rather than raising) the [Invalid_argument] exception too. *)
val add_hook : t -> (exn -> unit) -> Hook.t
(** [add_hook t fn] registers cancellation function [fn] with [t].
When [t] is cancelled, [protect (fun () -> fn ex)] is called.
If [t] is already cancelled, it calls [fn] immediately. *)
val cancel : t -> exn -> unit
(** [cancel t ex] marks [t] as cancelled and then calls all registered hooks,
passing [ex] as the argument.
All hooks are run, even if some of them raise exceptions.
@raise Cancel_hook_failed if one or more hooks fail. *)
end
(** {1 Cross-platform OS API} *)
(** A base class for objects that can be queried at runtime for extra features. *)
@ -456,7 +497,7 @@ module Dir : sig
(** [open_in ~sw t path] opens [t/path] for reading.
Note: files are always opened in binary mode. *)
val with_open_in : ?sw:Switch.t -> #t -> path -> (<Flow.source; Flow.close> -> 'a) -> 'a
val with_open_in : #t -> path -> (<Flow.source; Flow.close> -> 'a) -> 'a
(** [with_open_in] is like [open_in], but calls [fn flow] with the new flow and closes
it automatically when [fn] returns (if it hasn't already been closed by then). *)
@ -471,7 +512,6 @@ module Dir : sig
@param create Controls whether to create the file, and what permissions to give it if so. *)
val with_open_out :
?sw:Switch.t ->
?append:bool ->
create:create ->
#t -> path -> (<rw; Flow.close> -> 'a) -> 'a
@ -485,7 +525,7 @@ module Dir : sig
(** [open_dir ~sw t path] opens [t/path].
This can be passed to functions to grant access only to the subtree [t/path]. *)
val with_open_dir : ?sw:Switch.t -> #t -> path -> (<t; Flow.close> -> 'a) -> 'a
val with_open_dir : #t -> path -> (<t; Flow.close> -> 'a) -> 'a
(** [with_open_dir] is like [open_dir], but calls [fn dir] with the new directory and closes
it automatically when [fn] returns (if it hasn't already been closed by then). *)
end
@ -527,6 +567,11 @@ end
(** API for use by the scheduler implementation. *)
module Private : sig
type context = {
tid : Ctf.id;
mutable cancel : Cancel.t;
}
module Effects : sig
open EffectHandlers
@ -534,16 +579,12 @@ module Private : sig
(** A function provided by the scheduler to reschedule a previously-suspended thread. *)
type _ eff +=
| Suspend : (Ctf.id -> 'a enqueue -> unit) -> 'a eff
| Suspend : (context -> 'a enqueue -> unit) -> 'a eff
(** [Suspend fn] is performed when a fibre must be suspended
(e.g. because it called {!Promise.await} on an unresolved promise).
The effect handler runs [fn tid enqueue] in the scheduler context,
passing it the suspended fibre's thread ID (for tracing) and a function to resume it.
[fn] should arrange for [enqueue] to be called once the thread is ready to run again.
If a cancellation is pending, this will raise it. *)
| Suspend_unchecked : (Ctf.id -> 'a enqueue -> unit) -> 'a eff
(** [Suspend_unchecked] is like [Suspend], but doesn't raise pending exceptions. *)
The effect handler runs [fn fibre enqueue] in the scheduler context,
passing it the suspended fibre's context and a function to resume it.
[fn] should arrange for [enqueue] to be called once the thread is ready to run again. *)
| Fork : (unit -> 'a) -> 'a Promise.t eff
(** See {!Fibre.fork} *)
@ -551,18 +592,17 @@ module Private : sig
| Fork_ignore : (unit -> unit) -> unit eff
(** See {!Fibre.fork_ignore} *)
| Yield : unit eff
| Trace : (?__POS__:(string * int * int * int) -> ('a, Format.formatter, unit, unit) format4 -> 'a) eff
(** [perform Trace fmt] writes trace logging to the configured trace output.
It must not switch fibres, as tracing must not affect scheduling.
If the system is not ready to receive the trace output,
the whole domain must block until it is. *)
| Set_switch : Switch.t -> Switch.t eff
| Set_cancel : Cancel.t -> Cancel.t eff
(** [Set_cancel c] sets the running fibre's cancel context to [c] and returns the previous context. *)
end
val boot_switch : Switch.t
val boot_cancel : Cancel.t
(** A dummy context which is useful briefly during start up before the backend calls {!Cancel.protect}
to install a proper context. *)
end

73
lib_eio/fibre.ml
View File

@ -1,7 +1,6 @@
open EffectHandlers
type _ eff += Fork : (unit -> 'a) -> 'a Promise.t eff
type _ eff += Yield : unit eff
let fork ~sw ~exn_turn_off f =
let f () =
@ -18,40 +17,54 @@ type _ eff += Fork_ignore : (unit -> unit) -> unit eff
let fork_ignore ~sw f =
let f () =
Switch.with_op sw @@ fun () ->
try f ()
try
Cancel.protect_full @@ fun c ->
let hook = Switch.add_cancel_hook sw (Cancel.cancel c) in
Fun.protect f
~finally:(fun () -> Hook.remove hook)
with ex ->
Switch.turn_off sw ex;
raise ex
Switch.turn_off sw ex
in
perform (Fork_ignore f)
let yield () =
perform Yield
let c = ref Cancel.boot in
Suspend.enter (fun fibre enqueue ->
c := fibre.cancel;
enqueue (Ok ())
);
Cancel.check !c
let both ~sw f g =
let x = fork ~sw ~exn_turn_off:true f in
begin
try g ()
with ex -> Switch.turn_off sw ex
end;
ignore (Promise.await_result x : (unit, exn) result);
match sw.state with
| On _ -> ()
| Off (ex, bt) ->
Switch.raise_with_extras sw ex bt
| Finished -> assert false
let both f g =
Cancel.sub @@ fun cancel ->
let f () =
try f ()
with ex -> Cancel.cancel cancel ex; raise ex
in
let x = perform (Fork f) in
match g () with
| () -> Promise.await x (* [g] succeeds - just report [f]'s result *)
| exception gex ->
Cancel.cancel cancel gex;
match Cancel.protect (fun () -> Promise.await_result x) with
| Ok () | Error (Cancel.Cancelled _) -> raise gex (* [g] fails, nothing to report for [f] *)
| Error fex ->
match gex with
| Cancel.Cancelled _ -> raise fex (* [f] fails, nothing to report for [g] *)
| _ -> raise (Multiple_exn.T [fex; gex]) (* Both fail *)
let fork_sub_ignore ?on_release ~sw ~on_error f =
if Switch.is_finished sw then (
(* If the switch is finished then we have no way to report the error after forking,
so do it now. *)
Option.iter (fun f -> f ()) on_release;
invalid_arg "Switch finished!"
);
let f () =
try Switch.sub ?on_release sw ~on_error f
with ex ->
Switch.turn_off sw ex;
raise ex
in
perform (Fork_ignore f)
let did_attach = ref false in
fork_ignore ~sw (fun () ->
try Switch.run (fun sw -> Option.iter (Switch.on_release sw) on_release; did_attach := true; f sw)
with ex ->
try on_error ex
with ex2 ->
Switch.turn_off sw ex;
Switch.turn_off sw ex2
);
if not !did_attach then (
Option.iter Cancel.protect on_release;
Switch.check sw;
assert false
)

5
lib_eio/hook.ml Normal file
View File

@ -0,0 +1,5 @@
type t = unit -> unit (* A function to remove the hook *)
let null = ignore
let remove t = t ()

6
lib_eio/multiple_exn.ml Normal file
View File

@ -0,0 +1,6 @@
exception T of exn list
let () =
Printexc.register_printer @@ function
| T exns -> Some ("Multiple exceptions:\n" ^ String.concat "\nand\n" (List.map Printexc.to_string exns))
| _ -> None

21
lib_eio/promise.ml
View File

@ -31,27 +31,22 @@ let broken ex =
Ctf.note_created id Ctf.Promise;
{ id; state = Broken ex }
let await ?sw t =
Option.iter Switch.check sw;
let await_result t =
match t.state with
| Fulfilled x ->
Ctf.note_read t.id;
x
Ok x
| Broken ex ->
Ctf.note_read t.id;
raise ex
Error ex
| Unresolved q ->
Ctf.note_try_read t.id;
Switch.await ?sw q t.id
Switch.await q t.id
let await_result ?sw t =
match await ?sw t with
| x ->
Option.iter Switch.check sw;
Ok x
| exception ex ->
Option.iter Switch.check sw;
Error ex
let await t =
match await_result t with
| Ok x -> x
| Error ex -> raise ex
let fulfill t v =
match t.state with

6
lib_eio/semaphore.ml
View File

@ -27,14 +27,14 @@ let release t =
| `Queue_empty ->
t.state <- Free 1
let rec acquire ?sw t =
let rec acquire t =
match t.state with
| Waiting q ->
Ctf.note_try_read t.id;
Switch.await ?sw q t.id
Switch.await q t.id |> Switch.or_raise
| Free 0 ->
t.state <- Waiting (Waiters.create ());
acquire ?sw t
acquire t
| Free n ->
Ctf.note_read t.id;
t.state <- Free (pred n)

14
lib_eio/stream.ml
View File

@ -29,8 +29,7 @@ let create capacity =
writers = Waiters.create ();
}
let add ?sw t item =
Option.iter Switch.check sw;
let add t item =
match Waiters.wake_one t.readers (Ok item) with
| `Ok -> ()
| `Queue_empty ->
@ -38,8 +37,8 @@ let add ?sw t item =
if Queue.length t.items < t.capacity then Queue.add item t.items
else (
(* The queue is full. Wait for our turn first. *)
Suspend.enter @@ fun tid enqueue ->
Switch.await_internal ?sw t.writers t.id tid (fun r ->
Suspend.enter @@ fun ctx enqueue ->
Switch.await_internal t.writers t.id ctx (fun r ->
if Result.is_ok r then (
(* We get here immediately when called by [take], either:
1. after removing an item, so there is space, or
@ -48,17 +47,16 @@ let add ?sw t item =
);
enqueue r
)
)
) |> Switch.or_raise
let take ?sw t =
Option.iter Switch.check sw;
let take t =
match Queue.take_opt t.items with
| None ->
(* There aren't any items, so we probably need to wait for one.
However, there's also the special case of a zero-capacity queue to deal with.
[is_empty writers || capacity = 0] *)
begin match Waiters.wake_one t.writers (Ok ()) with
| `Queue_empty -> Switch.await ?sw t.readers t.id
| `Queue_empty -> Switch.await t.readers t.id |> Switch.or_raise
| `Ok ->
(* [capacity = 0] (this is the only way we can get waiters and no items).
[wake_one] has just added an item to the queue, so remove it quickly to restore the invariant. *)

19
lib_eio/suspend.ml
View File

@ -1,8 +1,17 @@
open EffectHandlers
type 'a enqueue = ('a, exn) result -> unit
type _ eff += Suspend : (Ctf.id -> 'a enqueue -> unit) -> 'a eff
type _ eff += Suspend_unchecked : (Ctf.id -> 'a enqueue -> unit) -> 'a eff
type context = {
tid : Ctf.id;
mutable cancel : Cancel.t;
}
let enter fn = perform (Suspend fn)
let enter_unchecked fn = perform (Suspend_unchecked fn)
type 'a enqueue = ('a, exn) result -> unit
type _ eff += Suspend : (context -> 'a enqueue -> unit) -> 'a eff
let enter_unchecked fn = perform (Suspend fn)
let enter fn =
enter_unchecked @@ fun fibre enqueue ->
match Cancel.get_error fibre.cancel with
| None -> fn fibre enqueue
| Some ex -> enqueue (Error ex)

205
lib_eio/switch.ml
View File

@ -1,101 +1,36 @@
open EffectHandlers
exception Multiple_exceptions of exn list
exception Cancelled of exn
type hook = unit -> unit (* A function to remove the hook *)
let () =
Printexc.register_printer @@ function
| Multiple_exceptions exns -> Some ("Multiple exceptions:\n" ^ String.concat "\nand\n" (List.map Printexc.to_string exns))
| Cancelled ex -> Some ("Cancelled: " ^ Printexc.to_string ex)
| _ -> None
type state =
| On of (exn -> unit) Lwt_dllist.t
| Off of exn * Printexc.raw_backtrace
| Finished
type t = {
id : Ctf.id;
mutable state : state;
mutable fibres : int;
mutable extra_exceptions : exn list;
on_release : (unit -> unit) Lwt_dllist.t;
waiter : unit Waiters.t; (* The main [top]/[sub] function may wait here for fibres to finish. *)
cancel : Cancel.t;
}
(* A dummy switch for bootstrapping *)
let boot_switch = {
id = Ctf.mint_id ();
state = Finished;
fibres = 0;
extra_exceptions = [];
on_release = Lwt_dllist.create ();
waiter = Waiters.create ();
}
type _ eff += Set_switch : t -> t eff
let with_switch t fn =
let old = perform (Set_switch t) in
Fun.protect fn
~finally:(fun () -> ignore (perform (Set_switch old)))
let null_hook = ignore
let remove_hook h = h ()
let is_finished t = Cancel.is_finished t.cancel
let check t =
match t.state with
| On _ -> ()
| Off (ex, _) -> raise (Cancelled ex)
| Finished -> invalid_arg "Switch finished!"
if is_finished t then invalid_arg "Switch finished!";
Cancel.check t.cancel
let get_error t =
match t.state with
| On _ -> None
| Off (ex, _) -> Some (Cancelled ex)
| Finished -> Some (Invalid_argument "Switch finished!")
let is_finished t =
match t.state with
| Finished -> true
| On _ | Off _ -> false
Cancel.get_error t.cancel
let rec turn_off t ex =
match t.state with
match t.cancel.state with
| Finished -> invalid_arg "Switch finished!"
| Off (orig, _) when orig == ex || List.memq ex t.extra_exceptions -> ()
| Off _ ->
| Cancelling (orig, _) when orig == ex || List.memq ex t.extra_exceptions -> ()
| Cancelling _ ->
begin match ex with
| Cancelled _ -> () (* The original exception will be reported elsewhere *)
| Multiple_exceptions exns -> List.iter (turn_off t) exns
| Cancel.Cancelled _ -> () (* The original exception will be reported elsewhere *)
| Multiple_exn.T exns -> List.iter (turn_off t) exns
| _ -> t.extra_exceptions <- ex :: t.extra_exceptions
end
| On q ->
| On _ ->
Ctf.note_resolved t.id ~ex:(Some ex);
t.state <- Off (ex, Printexc.get_raw_backtrace ());
let rec aux () =
match Lwt_dllist.take_opt_r q with
| None -> ()
| Some f ->
begin
try f ex
with ex2 -> turn_off t ex2
end;
aux ()
in
aux ()
Cancel.cancel t.cancel ex
let add_cancel_hook t hook =
match t.state with
| Finished -> invalid_arg "Switch finished!"
| Off (ex, _) -> hook ex; ignore
| On q ->
let node = Lwt_dllist.add_r hook q in
(fun () -> Lwt_dllist.remove node)
let add_cancel_hook t hook = Cancel.add_hook t.cancel hook
let add_cancel_hook_opt t hook =
match t with
@ -112,29 +47,32 @@ let with_op t fn =
Waiters.wake_all t.waiter (Ok ())
)
let await_internal ?sw waiters id tid enqueue =
let await_internal waiters id (ctx:Suspend.context) enqueue =
let cleanup_hooks = Queue.create () in
let when_resolved r =
Queue.iter Waiters.remove_waiter cleanup_hooks;
Ctf.note_read ~reader:id tid;
Ctf.note_read ~reader:id ctx.tid;
enqueue r
in
let cancel ex = when_resolved (Error ex) in
sw |> Option.iter (fun sw ->
let cancel_waiter = add_cancel_hook sw cancel in
Queue.add cancel_waiter cleanup_hooks;
);
let resolved_waiter = Waiters.add_waiter waiters when_resolved in
let cancel_waiter = Cancel.add_hook ctx.cancel cancel in
Queue.add cancel_waiter cleanup_hooks;
let resolved_waiter = Waiters.add_waiter waiters (fun x -> when_resolved (Ok x)) in
Queue.add resolved_waiter cleanup_hooks
let await ?sw waiters id =
Suspend.enter_unchecked (await_internal ?sw waiters id)
(* Returns a result if the wait succeeds, or raises if cancelled. *)
let await waiters id =
Suspend.enter (await_internal waiters id)
let or_raise = function
| Ok x -> x
| Error ex -> raise ex
let rec await_idle t =
(* Wait for fibres to finish: *)
while t.fibres > 0 do
Ctf.note_try_read t.id;
await t.waiter t.id
await t.waiter t.id |> or_raise;
done;
(* Call on_release handlers: *)
let queue = Lwt_dllist.create () in
@ -152,103 +90,64 @@ let rec await_idle t =
in
release ()
let await_idle t = Cancel.protect (fun _ -> await_idle t)
let raise_with_extras t ex bt =
match t.extra_exceptions with
| [] -> Printexc.raise_with_backtrace ex bt
| exns -> Printexc.raise_with_backtrace (Multiple_exceptions (ex :: List.rev exns)) bt
| exns -> Printexc.raise_with_backtrace (Multiple_exn.T (ex :: List.rev exns)) bt
let top fn =
let run fn =
let id = Ctf.mint_id () in
Ctf.note_created id Ctf.Switch;
let q = Lwt_dllist.create () in
Cancel.sub @@ fun cancel ->
let t = {
id;
state = On q;
fibres = 0;
extra_exceptions = [];
waiter = Waiters.create ();
on_release = Lwt_dllist.create ();
cancel;
} in
with_switch t @@ fun () ->
match fn t with
| v ->
await_idle t;
begin match t.state with
begin match t.cancel.state with
| Finished -> assert false
| On _ ->
(* Success. Just mark the switch as unusable now. *)
t.state <- Finished;
(* Success. *)
Ctf.note_read t.id;
v
| Off (ex, bt) ->
| Cancelling (ex, bt) ->
(* Function succeeded, but got failure waiting for fibres to finish. *)
t.state <- Finished;
Ctf.note_read t.id;
raise_with_extras t ex bt
end
| exception ex ->
(* Main function failed.
Turn the switch off to cancel any running fibres, if it's not off already. *)
turn_off t ex;
begin
try turn_off t ex
with Cancel.Cancel_hook_failed _ as ex ->
t.extra_exceptions <- ex :: t.extra_exceptions
end;
await_idle t;
Ctf.note_read t.id;
match t.state with
match t.cancel.state with
| On _ | Finished -> assert false
| Off (ex, bt) ->
t.state <- Finished;
raise_with_extras t ex bt
| Cancelling (ex, bt) -> raise_with_extras t ex bt
let on_release_cancellable t fn =
match t.state with
let on_release_full t fn =
match t.cancel.state with
| On _ | Cancelling _ -> Lwt_dllist.add_r fn t.on_release
| Finished ->
fn ();
invalid_arg "Switch finished!"
| On _ | Off _ ->
let node = Lwt_dllist.add_r fn t.on_release in
(fun () -> Lwt_dllist.remove node)
match Cancel.protect fn with
| () -> invalid_arg "Switch finished!"
| exception ex -> raise (Multiple_exn.T [ex; Invalid_argument "Switch finished!"])
let on_release t fn =
match t.state with
| Finished ->
fn ();
invalid_arg "Switch finished!"
| On _ | Off _ ->
let _ : _ Lwt_dllist.node = Lwt_dllist.add_r fn t.on_release in
()
ignore (on_release_full t fn : _ Lwt_dllist.node)
let sub ?on_release:release sw ~on_error fn =
match sw.state with
| Finished ->
(* Can't create child switch. Run release hooks immediately. *)
Option.iter (fun f -> f ()) release;
invalid_arg "Switch finished!"
| Off (ex, _) ->
(* Can't create child switch. Run release hooks immediately. *)
Option.iter (fun f -> f ()) release;
raise (Cancelled ex)
| On _ ->
with_op sw @@ fun () ->
let w = ref ignore in
match
top (fun child ->
w := add_cancel_hook sw (turn_off child);
Option.iter (on_release child) release;
try fn child
with ex -> turn_off child ex; raise ex
)
with
| v ->
Waiters.remove_waiter !w;
v
| exception ex ->
Waiters.remove_waiter !w;
on_error ex
let sub_opt ?on_release:release t fn =
match t with
| Some t -> sub ?on_release:release ~on_error:raise t fn
| None ->
top (fun child ->
Option.iter (on_release child) release;
fn child
)
let on_release_cancellable t fn =
let node = on_release_full t fn in
(fun () -> Lwt_dllist.remove node)

256
lib_eio_linux/eio_linux.ml
View File

@ -43,7 +43,7 @@ type _ eff += Close : Unix.file_descr -> int eff
module FD = struct
type t = {
seekable : bool;
mutable release_hook : Switch.hook; (* Use this on close to remove switch's [on_release] hook. *)
mutable release_hook : Eio.Hook.t; (* Use this on close to remove switch's [on_release] hook. *)
mutable fd : [`Open of Unix.file_descr | `Closed]
}
@ -59,7 +59,7 @@ module FD = struct
Ctf.label "close";
let fd = get "close" t in
t.fd <- `Closed;
Switch.remove_hook t.release_hook;
Eio.Hook.remove t.release_hook;
let res = perform (Close fd) in
Log.debug (fun l -> l "close: woken up");
if res < 0 then
@ -76,7 +76,7 @@ module FD = struct
let to_unix = get "to_unix"
let of_unix_no_hook ~seekable fd =
{ seekable; fd = `Open fd; release_hook = Switch.null_hook }
{ seekable; fd = `Open fd; release_hook = Eio.Hook.null }
let of_unix ~sw ~seekable fd =
let t = of_unix_no_hook ~seekable fd in
@ -97,7 +97,7 @@ type rw_req = {
action : int Suspended.t;
}
type cancel_hook = Switch.hook ref
type cancel_hook = Eio.Hook.t ref
(* Type of user-data attached to jobs. *)
type io_job =
@ -108,7 +108,6 @@ type io_job =
type runnable =
| Thread : 'a Suspended.t * 'a -> runnable
| Thread_checked : unit Suspended.t -> runnable
| Failed_thread : 'a Suspended.t * exn -> runnable
type t = {
@ -152,40 +151,40 @@ let cancel job =
(* Cancellation
For operations that can be cancelled we need to attach a callback to the
switch to trigger the cancellation, and we need to remove that callback once
the operation is complete. The typical sequence is:
cancellation context, and we need to remove that callback once the operation
is complete. The typical sequence is:
1. We create an io_job with an empty [cancel_hook] (because we haven't registered it yet).
2. We submit the operation, getting back a uring job (needed for cancellation).
3. We register a cancellation hook with the switch. The hook uses the uring job to cancel.
3. We register a cancellation hook with the context. The hook uses the uring job to cancel.
4. We update the [cancel_hook] with the waiter for removing the cancellation hook.
This is the reason that [cancel_hook] is mutable.
When the job completes, we get the cancellation hook from the io_job and
ensure it is removed from the switch, as it's no longer needed. The hook
must have been set by this point because we don't poll for completions until
the above steps have all finished.
ensure it is removed, as it's no longer needed. The hook must have been set
by this point because we don't poll for completions until the above steps
have all finished.
If the switch is turned off while the operation is running, the switch will start calling
the hooks. If it gets to ours before it's removed, we will submit a cancellation request to uring.
If the context is cancelled while the operation is running, the hooks will start being called.
If it gets to ours before it's removed, we will submit a cancellation request to uring.
If the operation completes before Linux processes the cancellation, we get [ENOENT], which we ignore.
If the switch is turned off before starting then we discontinue the fibre. *)
If the context is cancelled before starting then we discontinue the fibre. *)
(* [with_cancel_hook ~sw ~action st fn] calls [fn] with a fresh cancel hook.
When [fn cancel_hook] returns, it registers a cancellation callback with [sw] and stores its handle in [cancel_hook].
If [sw] is already off, it schedules [action] to be discontinued.
(* [with_cancel_hook ~action st fn] calls [fn] with a fresh cancel hook.
When [fn cancel_hook] returns, it registers a cancellation callback with [action] and stores its handle in [cancel_hook].
If [action] is already cancelled, it schedules [action] to be discontinued.
@return Whether to retry the operation later, once there is space. *)
let with_cancel_hook ~action st fn =
let release = ref Switch.null_hook in
let sw = action.Suspended.fibre.switch in
match Switch.get_error sw with
let release = ref Eio.Hook.null in
let ctx = action.Suspended.fibre.cancel in
match Eio.Cancel.get_error ctx with
| Some ex -> enqueue_failed_thread st action ex; false
| None ->
match fn release with
| None -> true
| Some job ->
release := Switch.add_cancel_hook sw (fun _ -> cancel job);
release := Eio.Cancel.add_hook ctx (fun _ -> cancel job);
false
let rec submit_rw_req st ({op; file_offset; fd; buf; len; cur_off; action} as req) =
@ -344,11 +343,6 @@ let rec schedule ({run_q; sleep_q; mem_q; uring; _} as st) : [`Exit_scheduler] =
(* Wakeup any paused fibres *)
match Queue.take run_q with
| Thread (k, v) -> Suspended.continue k v (* We already have a runnable task *)
| Thread_checked k ->
begin match Switch.get_error k.fibre.switch with
| Some e -> Suspended.discontinue k e
| None -> Suspended.continue k ()
end
| Failed_thread (k, ex) -> Suspended.discontinue k ex
| exception Queue.Empty ->
let now = Unix.gettimeofday () in
@ -392,17 +386,21 @@ and handle_complete st ~runnable result =
match runnable with
| Read (req, cancel) ->
Log.debug (fun l -> l "read returned");
Switch.remove_hook !cancel;
Eio.Hook.remove !cancel;
complete_rw_req st req result
| Write (req, cancel) ->
Log.debug (fun l -> l "write returned");
Switch.remove_hook !cancel;
Eio.Hook.remove !cancel;
complete_rw_req st req result
| Job (k, cancel) ->
Switch.remove_hook !cancel;
begin match Switch.get_error k.fibre.switch with
| Some e -> Suspended.discontinue k e (* If cancelled, report that instead. *)
Eio.Hook.remove !cancel;
begin match Eio.Cancel.get_error k.fibre.cancel with
| None -> Suspended.continue k result
| Some e ->
(* If cancelled, report that instead.
Should we only do this on error, to avoid losing the return value?
We already do that with rw jobs. *)
Suspended.discontinue k e
end
| Job_no_cancel k ->
Suspended.continue k result
@ -410,7 +408,7 @@ and complete_rw_req st ({len; cur_off; action; _} as req) res =
match res, len with
| 0, _ -> Suspended.discontinue action End_of_file
| e, _ when e < 0 ->
begin match Switch.get_error action.fibre.switch with
begin match Eio.Cancel.get_error action.fibre.cancel with
| Some e -> Suspended.discontinue action e (* If cancelled, report that instead. *)
| None ->
if errno_is_retry e then (
@ -584,7 +582,7 @@ let mkdir_beneath ~perm ?dir path =
let dir_path = Filename.dirname path in
let leaf = Filename.basename path in
(* [mkdir] is really an operation on [path]'s parent. Get a reference to that first: *)
Switch.top (fun sw ->
Switch.run (fun sw ->
let parent =
wrap_errors path @@ fun () ->
openat2 ~sw ~seekable:false ?dir dir_path
@ -738,6 +736,7 @@ module Objects = struct
method close = FD.close fd
method accept_sub ~sw ~on_error fn =
Switch.check sw;
let client, client_addr = accept_loose_fd fd in
Fibre.fork_sub_ignore ~sw ~on_error
(fun sw ->
@ -925,140 +924,115 @@ let run ?(queue_depth=64) ?(block_size=4096) main =
let mem_q = Queue.create () in
let st = { mem; uring; run_q; io_q; mem_q; sleep_q; io_jobs = 0 } in
Log.debug (fun l -> l "starting main thread");
let rec fork ~tid ~switch:initial_switch fn =
let rec fork ~tid ~cancel:initial_cancel fn =
Ctf.note_switch tid;
let fibre = { Suspended.tid; switch = initial_switch } in
let fibre = { Eio.Private.tid; cancel = initial_cancel } in
match_with fn ()
{ retc = (fun () -> schedule st);
exnc = (fun e -> raise e);
effc = fun (type a) (e : a eff) ->
match e with
| Enter fn ->
Some (fun k ->
begin match Switch.get_error fibre.switch with
| Some e -> discontinue k e
| None ->
let k = { Suspended.k; fibre } in
fn st k;
schedule st
end)
| Enter_unchecked fn ->
Some (fun k ->
{ retc = (fun () -> schedule st);
exnc = raise;
effc = fun (type a) (e : a eff) ->
match e with
| Enter fn -> Some (fun k ->
match Eio.Cancel.get_error fibre.cancel with
| Some e -> discontinue k e
| None ->
let k = { Suspended.k; fibre } in
fn st k;
schedule st
)
| Enter_unchecked fn -> Some (fun k ->
let k = { Suspended.k; fibre } in
fn st k;
schedule st
)
| ERead args ->
Some (fun k ->
let k = { Suspended.k; fibre } in
enqueue_read st k args;
schedule st)
| Close fd ->
Some (fun k ->
let k = { Suspended.k; fibre } in
enqueue_close st k fd;
schedule st)
| EWrite args ->
Some (fun k ->
let k = { Suspended.k; fibre } in
enqueue_write st k args;
schedule st)
| Sleep_until time ->
Some (fun k ->
let k = { Suspended.k; fibre } in
let cancel_hook = ref Switch.null_hook in
let sw = fibre.switch in
begin match Switch.get_error sw with
| ERead args -> Some (fun k ->
let k = { Suspended.k; fibre } in
enqueue_read st k args;
schedule st)
| Close fd -> Some (fun k ->
let k = { Suspended.k; fibre } in
enqueue_close st k fd;
schedule st
)
| EWrite args -> Some (fun k ->
let k = { Suspended.k; fibre } in
enqueue_write st k args;
schedule st
)
| Sleep_until time -> Some (fun k ->
let k = { Suspended.k; fibre } in
match Eio.Cancel.get_error fibre.cancel with
| Some ex -> Suspended.discontinue k ex
| None ->
let cancel_hook = ref Eio.Hook.null in
let job = Zzz.add ~cancel_hook sleep_q time k in
cancel_hook := Switch.add_cancel_hook sw (fun ex ->
cancel_hook := Eio.Cancel.add_hook fibre.cancel (fun ex ->
Zzz.remove sleep_q job;
enqueue_failed_thread st k ex
);
schedule st
end)
| Eio.Private.Effects.Set_switch switch ->
Some (fun k ->
let old = fibre.switch in
fibre.switch <- switch;
)
| Eio.Private.Effects.Set_cancel cancel -> Some (fun k ->
let old = fibre.cancel in
fibre.cancel <- cancel;
continue k old
)
| Eio.Private.Effects.Yield ->
Some (fun k ->
| Eio.Private.Effects.Suspend f -> Some (fun k ->
let k = { Suspended.k; fibre } in
Queue.push (Thread_checked k) st.run_q;
schedule st
)
| Eio.Private.Effects.Suspend_unchecked f ->
Some (fun k ->
let k = { Suspended.k; fibre } in
f tid (function
f fibre (function
| Ok v -> enqueue_thread st k v
| Error ex -> enqueue_failed_thread st k ex
);
schedule st
)
| Eio.Private.Effects.Suspend f ->
Some (fun k ->
match Switch.get_error fibre.switch with
| Some e -> discontinue k e
| None ->
let k = { Suspended.k; fibre } in
f tid (function
| Ok v -> enqueue_thread st k v
| Error ex -> enqueue_failed_thread st k ex
);
schedule st
| Eio.Private.Effects.Fork f -> Some (fun k ->
let k = { Suspended.k; fibre } in
let id = Ctf.mint_id () in
Ctf.note_created id Ctf.Task;
let promise, resolver = Promise.create_with_id id in
enqueue_thread st k promise;
fork
~tid:id
~cancel:fibre.cancel
(fun () ->
match f () with
| x -> Promise.fulfill resolver x
| exception ex ->
Log.debug (fun f -> f "Forked fibre failed: %a" Fmt.exn ex);
Promise.break resolver ex
)
)
| Eio.Private.Effects.Fork f ->
Some (fun k ->
let k = { Suspended.k; fibre } in
let id = Ctf.mint_id () in
Ctf.note_created id Ctf.Task;
let promise, resolver = Promise.create_with_id id in
enqueue_thread st k promise;
fork
~tid:id
~switch:fibre.switch
(fun () ->
match f () with
| x -> Promise.fulfill resolver x
| exception ex ->
Log.debug (fun f -> f "Forked fibre failed: %a" Fmt.exn ex);
Promise.break resolver ex
))
| Eio.Private.Effects.Fork_ignore f ->
Some (fun k ->
let k = { Suspended.k; fibre } in
enqueue_thread st k ();
let child = Ctf.note_fork () in
Ctf.note_switch child;
fork ~tid:child ~switch:fibre.switch (fun () ->
match f () with
| () ->
Ctf.note_resolved child ~ex:None
| exception ex ->
Ctf.note_resolved child ~ex:(Some ex)
))
| Eio.Private.Effects.Trace -> Some (fun k -> continue k Eunix.Trace.default_traceln)
| Alloc ->
Some (fun k ->
let k = { Suspended.k; fibre } in
alloc_buf st k)
| Free buf ->
Some (fun k ->
free_buf st buf;
continue k ())
| _ -> None
}
| Eio.Private.Effects.Fork_ignore f -> Some (fun k ->
let k = { Suspended.k; fibre } in
enqueue_thread st k ();
let child = Ctf.note_fork () in
Ctf.note_switch child;
fork ~tid:child ~cancel:fibre.cancel (fun () ->
match f () with
| () ->
Ctf.note_resolved child ~ex:None
| exception ex ->
Ctf.note_resolved child ~ex:(Some ex)
)
)
| Eio.Private.Effects.Trace -> Some (fun k -> continue k Eunix.Trace.default_traceln)
| Alloc -> Some (fun k ->
let k = { Suspended.k; fibre } in
alloc_buf st k
)
| Free buf -> Some (fun k ->
free_buf st buf;
continue k ()
)
| _ -> None
}
in
let main_done = ref false in
let `Exit_scheduler =
fork ~tid:(Ctf.mint_id ()) ~switch:Eio.Private.boot_switch (fun () ->
Fun.protect (fun () -> Switch.top (fun _sw -> main stdenv))
fork ~tid:(Ctf.mint_id ()) ~cancel:Eio.Private.boot_cancel (fun () ->
Fun.protect (fun () -> Eio.Cancel.protect (fun () -> main stdenv))
~finally:(fun () -> main_done := true)
) in
) in
if not !main_done then
failwith "Deadlock detected: no events scheduled but main function hasn't returned";
Log.debug (fun l -> l "exit")

3
lib_eio_linux/eio_linux.mli
View File

@ -48,8 +48,7 @@ val noop : unit -> unit
(** {1 Time functions} *)
val sleep_until : float -> unit
(** [sleep_until time] blocks until the current time is [time].
@param sw Cancel the sleep if [sw] is turned off. *)
(** [sleep_until time] blocks until the current time is [time]. *)
(** {1 Memory allocation functions} *)

2
lib_eio_linux/tests/basic_eio_linux.ml
View File

@ -12,7 +12,7 @@ let setup_log level =
let () =
setup_log (Some Logs.Debug);
run @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let fd = Unix.handle_unix_error (openfile ~sw "test.txt" Unix.[O_RDONLY]) 0 in
let buf = alloc () in
let _ = read_exactly fd buf 5 in

4
lib_eio_linux/tests/eurcp_lib.ml
View File

@ -14,7 +14,7 @@ let read_then_write_chunk infd outfd file_offset len =
U.free buf
let copy_file infd outfd insize block_size =
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let rec copy_block file_offset =
let remaining = Int63.(sub insize file_offset) in
if remaining <> Int63.zero then (
@ -27,7 +27,7 @@ let copy_file infd outfd insize block_size =
let run_cp block_size queue_depth infile outfile () =
U.run ~queue_depth ~block_size @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let open Unix in
let infd = Eio_linux.openfile ~sw infile [O_RDONLY] 0 in
let outfd = Eio_linux.openfile ~sw outfile [O_WRONLY; O_CREAT; O_TRUNC] 0o644 in

16
lib_eio_linux/tests/test.ml
View File

@ -17,7 +17,7 @@ let read_one_byte ~sw r =
let test_poll_add () =
Eio_linux.run @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let r, w = Eio_linux.pipe sw in
let thread = read_one_byte ~sw r in
Fibre.yield ();
@ -30,7 +30,7 @@ let test_poll_add () =
let test_poll_add_busy () =
Eio_linux.run ~queue_depth:1 @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let r, w = Eio_linux.pipe sw in
let a = read_one_byte ~sw r in
let b = read_one_byte ~sw r in
@ -46,11 +46,11 @@ let test_poll_add_busy () =
(* Write a string to a pipe and read it out again. *)
let test_copy () =
Eio_linux.run ~queue_depth:2 @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let msg = "Hello!" in
let from_pipe, to_pipe = Eio_linux.pipe sw in
let buffer = Buffer.create 20 in
Fibre.both ~sw
Fibre.both
(fun () -> Eio.Flow.copy from_pipe (Eio.Flow.buffer_sink buffer))
(fun () ->
Eio.Flow.copy (Eio.Flow.string_source msg) to_pipe;
@ -63,13 +63,13 @@ let test_copy () =
(* Write a string via 2 pipes. The copy from the 1st to 2nd pipe will be optimised and so tests a different code-path. *)
let test_direct_copy () =
Eio_linux.run ~queue_depth:4 @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let msg = "Hello!" in
let from_pipe1, to_pipe1 = Eio_linux.pipe sw in
let from_pipe2, to_pipe2 = Eio_linux.pipe sw in
let buffer = Buffer.create 20 in
let to_output = Eio.Flow.buffer_sink buffer in
Switch.top (fun sw ->
Switch.run (fun sw ->
Fibre.fork_ignore ~sw (fun () -> Ctf.label "copy1"; Eio.Flow.copy from_pipe1 to_pipe2; Eio.Flow.close to_pipe2);
Fibre.fork_ignore ~sw (fun () -> Ctf.label "copy2"; Eio.Flow.copy from_pipe2 to_output);
Eio.Flow.copy (Eio.Flow.string_source msg) to_pipe1;
@ -82,7 +82,7 @@ let test_direct_copy () =
(* Read and write using IO vectors rather than the fixed buffers. *)
let test_iovec () =
Eio_linux.run ~queue_depth:4 @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let from_pipe, to_pipe = Eio_linux.pipe sw in
let from_pipe = Eio_linux.Objects.get_fd from_pipe in
let to_pipe = Eio_linux.Objects.get_fd to_pipe in
@ -93,7 +93,7 @@ let test_iovec () =
let got = Eio_linux.readv from_pipe cs in
recv (Cstruct.shiftv cs got)
in
Fibre.both ~sw
Fibre.both
(fun () -> recv [Cstruct.sub message 5 3; Cstruct.sub message 15 3])
(fun () ->
let b = Cstruct.of_string "barfoo" in

76
lib_eio_luv/eio_luv.ml
View File

@ -50,7 +50,7 @@ let or_raise_path path = function
module Suspended = struct
type 'a t = {
fibre : Eunix.Suspended.state;
fibre : Eio.Private.context;
k : ('a, unit) continuation;
}
@ -67,7 +67,7 @@ module Suspended = struct
| Error x -> discontinue t x
end
type _ eff += Await : (Eunix.Suspended.state -> ('a -> unit) -> unit) -> 'a eff
type _ eff += Await : (Eio.Private.context -> ('a -> unit) -> unit) -> 'a eff
let await fn = perform (Await fn)
type _ eff += Enter : ('a Suspended.t -> unit) -> 'a eff
@ -92,16 +92,16 @@ let enqueue_failed_thread k ex =
Luv.Timer.start yield 0 (fun () -> Suspended.discontinue k ex) |> or_raise
let with_cancel fibre ~request fn =
let cancel = Switch.add_cancel_hook fibre.Eunix.Suspended.switch (fun _ ->
let cancel = Eio.Cancel.add_hook fibre.Eio.Private.cancel (fun _ ->
match Luv.Request.cancel request with
| Ok () -> ()
| Error e -> Log.debug (fun f -> f "Cancel failed: %s" (Luv.Error.strerror e))
) in
Fun.protect fn ~finally:(fun () -> Switch.remove_hook cancel)
Fun.protect fn ~finally:(fun () -> Eio.Hook.remove cancel)
module Handle = struct
type 'a t = {
mutable release_hook : Switch.hook; (* Use this on close to remove switch's [on_release] hook. *)
mutable release_hook : Eio.Hook.t; (* Use this on close to remove switch's [on_release] hook. *)
mutable fd : [`Open of 'a Luv.Handle.t | `Closed]
}
@ -117,7 +117,7 @@ module Handle = struct
Ctf.label "close";
let fd = get "close" t in
t.fd <- `Closed;
Switch.remove_hook t.release_hook;
Eio.Hook.remove t.release_hook;
enter_unchecked @@ fun k ->
Luv.Handle.close fd (Suspended.continue k)
@ -127,7 +127,7 @@ module Handle = struct
let to_luv x = get "to_luv" x
let of_luv_no_hook fd =
{ fd = `Open fd; release_hook = Switch.null_hook }
{ fd = `Open fd; release_hook = Eio.Hook.null }
let of_luv ~sw fd =
let t = of_luv_no_hook fd in
@ -137,7 +137,7 @@ end
module File = struct
type t = {
mutable release_hook : Switch.hook; (* Use this on close to remove switch's [on_release] hook. *)
mutable release_hook : Eio.Hook.t; (* Use this on close to remove switch's [on_release] hook. *)
mutable fd : [`Open of Luv.File.t | `Closed]
}
@ -153,7 +153,7 @@ module File = struct
Ctf.label "close";
let fd = get "close" t in
t.fd <- `Closed;
Switch.remove_hook t.release_hook;
Eio.Hook.remove t.release_hook;
await_exn (fun _fibre -> Luv.File.close fd)
let ensure_closed t =
@ -162,7 +162,7 @@ module File = struct
let to_luv = get "to_luv"
let of_luv_no_hook fd =
{ fd = `Open fd; release_hook = Switch.null_hook }
{ fd = `Open fd; release_hook = Eio.Hook.null }
let of_luv ~sw fd =
let t = of_luv_no_hook fd in
@ -207,12 +207,12 @@ module Stream = struct
let rec read_into (sock:'a t) buf =
let r = enter (fun k ->
let cancel = Switch.add_cancel_hook k.fibre.switch (fun ex ->
let cancel = Eio.Cancel.add_hook k.fibre.cancel (fun ex ->
Luv.Stream.read_stop (Handle.get "read_into:cancel" sock) |> or_raise;
enqueue_failed_thread k (Switch.Cancelled ex)
enqueue_failed_thread k (Eio.Cancel.Cancelled ex)
) in
Luv.Stream.read_start (Handle.get "read_start" sock) ~allocate:(fun _ -> buf) (fun r ->
Switch.remove_hook cancel;
Eio.Hook.remove cancel;
Luv.Stream.read_stop (Handle.get "read_stop" sock) |> or_raise;
Suspended.continue k r
)
@ -248,13 +248,13 @@ let sleep_until due =
let delay = 1000. *. (due -. Unix.gettimeofday ()) |> ceil |> truncate |> max 0 in
let timer = Luv.Timer.init () |> or_raise in
enter @@ fun k ->
let cancel = Switch.add_cancel_hook k.fibre.switch (fun ex ->
let cancel = Eio.Cancel.add_hook k.fibre.cancel (fun ex ->
Luv.Timer.stop timer |> or_raise;
Luv.Handle.close timer (fun () -> ());
enqueue_failed_thread k ex
) in
Luv.Timer.start timer delay (fun () ->
Switch.remove_hook cancel;
Eio.Hook.remove cancel;
Suspended.continue k ()
) |> or_raise
@ -351,7 +351,7 @@ module Objects = struct
method close = Handle.close sock
method accept_sub ~sw ~on_error fn =
Eio.Semaphore.acquire ~sw ready;
Eio.Semaphore.acquire ready;
let client = self#make_client |> Handle.of_luv_no_hook in
match Luv.Stream.accept ~server:(Handle.get "accept" sock) ~client:(Handle.get "accept" client) with
| Error e ->
@ -583,9 +583,9 @@ end
let run main =
Log.debug (fun l -> l "starting run");
let stdenv = Objects.stdenv () in
let rec fork ~tid ~switch:initial_switch fn =
let rec fork ~tid ~cancel:initial_cancel fn =
Ctf.note_switch tid;
let fibre = { Eunix.Suspended.tid; switch = initial_switch } in
let fibre = { Eio.Private.tid; cancel = initial_cancel } in
match_with fn ()
{ retc = (fun () -> ());
exnc = (fun e -> raise e);
@ -606,7 +606,7 @@ let run main =
enqueue_thread k promise;
fork
~tid:id
~switch:fibre.switch
~cancel:fibre.cancel
(fun () ->
match f () with
| x -> Promise.fulfill resolver x
@ -620,56 +620,38 @@ let run main =
enqueue_thread k ();
let child = Ctf.note_fork () in
Ctf.note_switch child;
fork ~tid:child ~switch:fibre.switch (fun () ->
fork ~tid:child ~cancel:fibre.cancel (fun () ->
match f () with
| () ->
Ctf.note_resolved child ~ex:None
| exception ex ->
Ctf.note_resolved child ~ex:(Some ex)
))
| Eio.Private.Effects.Set_switch switch ->
| Eio.Private.Effects.Set_cancel cancel ->
Some (fun k ->
let old = fibre.switch in
fibre.switch <- switch;
let old = fibre.cancel in
fibre.cancel <- cancel;
continue k old
)
| Enter_unchecked fn -> Some (fun k ->
fn { Suspended.k; fibre }
)
| Enter fn -> Some (fun k ->
match Switch.get_error fibre.switch with
match Eio.Cancel.get_error fibre.cancel with
| Some e -> discontinue k e
| None -> fn { Suspended.k; fibre }
)
| Eio.Private.Effects.Yield ->
Some (fun k ->
let yield = Luv.Timer.init () |> or_raise in
Luv.Timer.start yield 0 (fun () ->
match Switch.get_error fibre.switch with
| Some e -> discontinue k e
| None -> continue k ()
)
|> or_raise
)
| Eio.Private.Effects.Suspend_unchecked fn ->
Some (fun k ->
let k = { Suspended.k; fibre } in
fn tid (enqueue_result_thread k)
)
| Eio.Private.Effects.Suspend fn ->
Some (fun k ->
begin match Switch.get_error fibre.switch with
| Some e -> discontinue k e
| None ->
let k = { Suspended.k; fibre } in
fn tid (enqueue_result_thread k)
end)
let k = { Suspended.k; fibre } in
fn fibre (enqueue_result_thread k)
)
| _ -> None
}
in
let main_status = ref `Running in
fork ~tid:(Ctf.mint_id ()) ~switch:Eio.Private.boot_switch (fun () ->
match Switch.top (fun _sw -> main stdenv) with
fork ~tid:(Ctf.mint_id ()) ~cancel:Eio.Private.boot_cancel (fun () ->
match Eio.Cancel.protect (fun () -> main stdenv) with
| () -> main_status := `Done
| exception ex -> main_status := `Ex (ex, Printexc.get_raw_backtrace ())
);

2
lib_eio_luv/eio_luv.mli
View File

@ -23,7 +23,7 @@ exception Luv_error of Luv.Error.t
val or_raise : 'a or_error -> 'a
(** [or_error (Error e)] raises [Luv_error e]. *)
val await : (Eunix.Suspended.state -> ('a -> unit) -> unit) -> 'a
val await : (Eio.Private.context -> ('a -> unit) -> unit) -> 'a
(** [await fn] converts a function using a luv-style callback to one using effects.
Use it as e.g. [await (fun fibre -> Luv.File.realpath path)].
Use [fibre] to implement cancellation. *)

2
lib_eio_luv/tests/files.md
View File

@ -32,7 +32,7 @@ Hello, world!
```ocaml
let main _stdenv =
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let fd = Eio_luv.File.open_ ~sw "/dev/zero" [] |> Eio_luv.or_raise in
let buf = Luv.Buffer.create 4 in
read_exactly fd buf;

7
lib_eunix/suspended.ml
View File

@ -1,12 +1,7 @@
open EffectHandlers.Deep
type state = {
tid : Ctf.id;
mutable switch : Eio.Std.Switch.t;
}
type 'a t = {
fibre : state;
fibre : Eio.Private.context;
k : ('a, [`Exit_scheduler]) continuation;
}

6
lib_eunix/zzz.ml
View File

@ -1,7 +1,5 @@
(** Keep track of scheduled alarms. *)
open Eio.Std
module Key = struct
type t = Optint.Int63.t
let compare = Optint.Int63.compare
@ -11,7 +9,7 @@ module Job = struct
type t = {
time : float;
thread : unit Suspended.t;
cancel_hook : Switch.hook ref;
cancel_hook : Eio.Hook.t ref;
}
let compare a b = Float.compare a.time b.time
@ -39,7 +37,7 @@ let remove t id =
let pop t ~now =
match Q.min t.sleep_queue with
| Some (_, { Job.time; thread; cancel_hook }) when time <= now ->
Switch.remove_hook !cancel_hook;
Eio.Hook.remove !cancel_hook;
t.sleep_queue <- Option.get (Q.rest t.sleep_queue);
`Due thread
| Some (_, { Job.time; _ }) -> `Wait_until time

4
lib_eunix/zzz.mli
View File

@ -1,5 +1,3 @@
open Eio.Std
module Key : sig
type t
end
@ -10,7 +8,7 @@ type t
val create : unit -> t
(** [create ()] is a fresh empty queue. *)
val add : cancel_hook:Switch.hook ref -> t -> float -> unit Suspended.t -> Key.t
val add : cancel_hook:Eio.Hook.t ref -> t -> float -> unit Suspended.t -> Key.t
(** [add ~cancel_hook t time thread] adds a new event, due at [time], and returns its ID.
[cancel_hook] will be released when the event is later returned by {!pop}. *)

3
tests/test_domains.md
View File

@ -38,10 +38,9 @@ Here, we use a mutex to check that the parent domain really did run while waitin
```ocaml
# run @@ fun mgr ->
Switch.top @@ fun sw ->
let mutex = Stdlib.Mutex.create () in
Mutex.lock mutex;
Fibre.both ~sw
Fibre.both
(fun () ->
traceln "Spawning new domain...";
let response = Eio.Domain_manager.run_compute_unsafe mgr (fun () ->

30
tests/test_fs.md
View File

@ -17,10 +17,9 @@ let () =
open Eio.Std
let run (fn : sw:Switch.t -> Eio.Stdenv.t -> unit) =
let run (fn : Eio.Stdenv.t -> unit) =
Eio_main.run @@ fun env ->
Switch.top @@ fun sw ->
fn ~sw env
fn env
let read_all flow =
let b = Buffer.create 100 in
@ -53,7 +52,7 @@ let chdir path =
Creating a file and reading it back:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
write_file ~create:(`Exclusive 0o666) cwd "test-file" "my-data";
traceln "Got %S" @@ read_file cwd "test-file";;
@ -72,7 +71,7 @@ Perm = 644
Trying to use cwd to access a file outside of that subtree fails:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
write_file ~create:(`Exclusive 0o666) cwd "../test-file" "my-data";
failwith "Should have failed";;
@ -81,7 +80,7 @@ Exception: Eio.Dir.Permission_denied ("../test-file", _)
Trying to use cwd to access an absolute path fails:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
write_file ~create:(`Exclusive 0o666) cwd "/tmp/test-file" "my-data";
failwith "Should have failed";;
@ -92,7 +91,7 @@ Exception: Eio.Dir.Permission_denied ("/tmp/test-file", _)
Exclusive create fails if already exists:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
write_file ~create:(`Exclusive 0o666) cwd "test-file" "first-write";
write_file ~create:(`Exclusive 0o666) cwd "test-file" "first-write";
@ -102,7 +101,7 @@ Exception: Eio.Dir.Already_exists ("test-file", _)
If-missing create succeeds if already exists:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
write_file ~create:(`If_missing 0o666) cwd "test-file" "1st-write-original";
write_file ~create:(`If_missing 0o666) cwd "test-file" "2nd-write";
@ -113,7 +112,7 @@ If-missing create succeeds if already exists:
Truncate create succeeds if already exists, and truncates:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
write_file ~create:(`Or_truncate 0o666) cwd "test-file" "1st-write-original";
write_file ~create:(`Or_truncate 0o666) cwd "test-file" "2nd-write";
@ -126,7 +125,7 @@ Truncate create succeeds if already exists, and truncates:
Error if no create and doesn't exist:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
write_file ~create:`Never cwd "test-file" "1st-write-original";
traceln "Got %S" @@ read_file cwd "test-file";;
@ -135,7 +134,7 @@ Exception: Eio.Dir.Not_found ("test-file", _)
Appending to an existing file:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
write_file ~create:(`Or_truncate 0o666) cwd "test-file" "1st-write-original";
write_file ~create:`Never ~append:true cwd "test-file" "2nd-write";
@ -149,7 +148,7 @@ Appending to an existing file:
# Mkdir
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
try_mkdir cwd "subdir";
try_mkdir cwd "subdir/nested";
@ -170,7 +169,7 @@ Creating directories with nesting, symlinks, etc:
- : unit = ()
# Unix.symlink "foo" "dangle";;
- : unit = ()
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
try_mkdir cwd "subdir";
try_mkdir cwd "to-subdir/nested";
@ -192,7 +191,8 @@ Creating directories with nesting, symlinks, etc:
Create a sandbox, write a file with it, then read it from outside:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
Switch.run @@ fun sw ->
let cwd = Eio.Stdenv.cwd env in
try_mkdir cwd "sandbox";
let subdir = Eio.Dir.open_dir ~sw cwd "sandbox" in
@ -210,7 +210,7 @@ Create a sandbox, write a file with it, then read it from outside:
We create a directory and chdir into it.
Using `cwd` we can't access the parent, but using `fs` we can:
```ocaml
# run @@ fun ~sw env ->
# run @@ fun env ->
let cwd = Eio.Stdenv.cwd env in
let fs = Eio.Stdenv.fs env in
try_mkdir cwd "fs-test";

13
tests/test_network.md
View File

@ -10,7 +10,7 @@ open Eio.Std
let run (fn : net:Eio.Net.t -> Switch.t -> unit) =
Eio_main.run @@ fun env ->
let net = Eio.Stdenv.net env in
Switch.top (fn ~net)
Switch.run (fn ~net)
let addr = `Tcp (Unix.inet_addr_loopback, 8081)
@ -56,7 +56,7 @@ let run_server ~sw socket =
let test_address addr ~net sw =
let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in
Fibre.both ~sw
Fibre.both
(fun () -> run_server ~sw server)
(fun () ->
run_client ~sw ~net ~addr;
@ -108,19 +108,18 @@ Cancelling the read:
# run @@ fun ~net sw ->
let shutdown, set_shutdown = Promise.create () in
let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in
Fibre.both ~sw
Fibre.both
(fun () ->
Eio.Net.accept_sub server ~sw (fun ~sw flow _addr ->
try
Fibre.both ~sw
Fibre.both
(fun () -> raise (Promise.await shutdown))
(fun () ->
let msg = read_all flow in
traceln "Server received: %S" msg
)
with Graceful_shutdown ->
Switch.top @@ fun _sw ->
Eio.Flow.copy_string "Request cancelled" flow;
Eio.Flow.copy_string "Request cancelled" flow
) ~on_error:raise
)
(fun () ->
@ -135,7 +134,7 @@ Cancelling the read:
+Connecting to server...
+Connection opened - cancelling server's read
+Client received: "Request cancelled"
Exception: Graceful_shutdown.
- : unit = ()
```
Calling accept when the switch is already off:

61
tests/test_stream.md
View File

@ -15,14 +15,14 @@ let run fn =
Eio_main.run @@ fun _ ->
fn ()
let add ?sw t v =
let add t v =
traceln "Adding %d to stream" v;
S.add ?sw t v;
S.add t v;
traceln "Added %d to stream" v
let take ?sw t =
let take t =
traceln "Reading from stream";
traceln "Got %d from stream" (S.take ?sw t)
traceln "Got %d from stream" (S.take t)
```
# Test cases
@ -51,10 +51,9 @@ Readers have to wait when the stream is empty:
```ocaml
# run @@ fun () ->
Switch.top @@ fun sw ->
let t = S.create 2 in
add t 1;
Fibre.both ~sw
Fibre.both
(fun () -> take t; take t)
(fun () -> add t 2);;
+Adding 1 to stream
@ -72,10 +71,9 @@ Writers have to wait when the stream is full:
```ocaml
# run @@ fun () ->
Switch.top @@ fun sw ->
let t = S.create 3 in
add t 1;
Fibre.both ~sw
Fibre.both
(fun () ->
add t 2;
add t 3;
@ -110,9 +108,8 @@ A zero-length queue is synchronous:
```ocaml
# run @@ fun () ->
Switch.top @@ fun sw ->
let t = S.create 0 in
Fibre.both ~sw
Fibre.both
(fun () ->
add t 1;
add t 2;
@ -138,10 +135,9 @@ Cancel reading from a stream:
# run @@ fun () ->
let t = S.create 1 in
try
Switch.top @@ fun sw ->
Fibre.both ~sw
(fun () -> take ~sw t)
(fun () -> Switch.turn_off sw Cancel);
Fibre.both
(fun () -> take t)
(fun () -> raise Cancel);
assert false;
with Cancel ->
traceln "Cancelled";
@ -162,10 +158,9 @@ Cancel writing to a stream:
# run @@ fun () ->
let t = S.create 1 in
try
Switch.top @@ fun sw ->
Fibre.both ~sw
(fun () -> add ~sw t 1; add ~sw t 2)
(fun () -> Switch.turn_off sw Cancel);
Fibre.both
(fun () -> add t 1; add t 2)
(fun () -> raise Cancel);
assert false;
with Cancel ->
traceln "Cancelled";
@ -191,17 +186,15 @@ Cancel writing to a zero-length stream:
# run @@ fun () ->
let t = S.create 0 in
try
Switch.top @@ fun sw ->
Fibre.both ~sw
(fun () -> add ~sw t 1)
(fun () -> Switch.turn_off sw Cancel);
Fibre.both
(fun () -> add t 1)
(fun () -> raise Cancel);
assert false;
with Cancel ->
traceln "Cancelled";
Switch.top @@ fun sw ->
Fibre.both ~sw
(fun () -> add ~sw t 2)
(fun () -> take ~sw t);;
Fibre.both
(fun () -> add t 2)
(fun () -> take t);;
+Adding 1 to stream
+Cancelled
+Adding 2 to stream
@ -211,20 +204,20 @@ Cancel writing to a zero-length stream:
- : unit = ()
```
Trying to use a stream with a turned-off switch:
Trying to use a stream with a cancelled context:
```ocaml
# run @@ fun () ->
let t = S.create 0 in
Switch.top @@ fun sw ->
Switch.turn_off sw Cancel;
begin try add ~sw t 1 with ex -> traceln "%a" Fmt.exn ex end;
begin try take ~sw t with ex -> traceln "%a" Fmt.exn ex end;;
Eio.Cancel.sub @@ fun c ->
Eio.Cancel.cancel c Cancel;
begin try add t 1 with ex -> traceln "%a" Fmt.exn ex end;
begin try take t with ex -> traceln "%a" Fmt.exn ex end;;
+Adding 1 to stream
+Cancelled: Cancel
+Reading from stream
+Cancelled: Cancel
Exception: Cancel.
Exception: Cancelled: Cancel
```
Readers queue up:
@ -232,7 +225,7 @@ Readers queue up:
```ocaml
# run @@ fun () ->
let t = S.create 0 in
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
Fibre.fork_ignore ~sw (fun () -> take t; traceln "a done");
Fibre.fork_ignore ~sw (fun () -> take t; traceln "b done");
Fibre.fork_ignore ~sw (fun () -> take t; traceln "c done");
@ -262,7 +255,7 @@ Writers queue up:
```ocaml
# run @@ fun () ->
let t = S.create 0 in
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
Fibre.fork_ignore ~sw (fun () -> add t 1);
Fibre.fork_ignore ~sw (fun () -> add t 2);
Fibre.fork_ignore ~sw (fun () -> add t 3);

159
tests/test_switch.md
View File

@ -9,7 +9,7 @@ open Eio.Std
let run (fn : Switch.t -> unit) =
Eio_main.run @@ fun _e ->
Switch.top fn
Switch.run fn
```
# Test cases
@ -40,8 +40,8 @@ Exception: Failure "Cancel".
`Fibre.both`, both fibres pass:
```ocaml
# run (fun sw ->
Fibre.both ~sw
# run (fun _sw ->
Fibre.both
(fun () -> for i = 1 to 2 do traceln "i = %d" i; Fibre.yield () done)
(fun () -> for j = 1 to 2 do traceln "j = %d" j; Fibre.yield () done)
);;
@ -56,7 +56,7 @@ Exception: Failure "Cancel".
```ocaml
# run (fun sw ->
Fibre.both ~sw
Fibre.both
(fun () -> for i = 1 to 5 do traceln "i = %d" i; Fibre.yield () done)
(fun () -> failwith "Failed")
);;
@ -68,7 +68,7 @@ Exception: Failure "Failed".
```ocaml
# run (fun sw ->
Fibre.both ~sw
Fibre.both
(fun () -> Fibre.yield (); failwith "Failed")
(fun () -> for i = 1 to 5 do traceln "i = %d" i; Fibre.yield () done)
);;
@ -80,7 +80,7 @@ Exception: Failure "Failed".
```ocaml
# run (fun sw ->
Fibre.both ~sw (fun () -> failwith "Failed") ignore;
Fibre.both (fun () -> failwith "Failed") ignore;
traceln "Not reached"
);;
Exception: Failure "Failed".
@ -90,7 +90,7 @@ Exception: Failure "Failed".
```ocaml
# run (fun sw ->
Fibre.both ~sw ignore (fun () -> failwith "Failed");
Fibre.both ignore (fun () -> failwith "Failed");
traceln "not reached"
);;
Exception: Failure "Failed".
@ -100,7 +100,7 @@ Exception: Failure "Failed".
```ocaml
# run (fun sw ->
Fibre.both ~sw
Fibre.both
(fun () -> failwith "Failed 1")
(fun () -> failwith "Failed 2")
);;
@ -141,12 +141,12 @@ Turning off a switch runs the cancel callbacks, unless they've been removed by t
let h1 = Switch.add_cancel_hook sw (fun _ -> traceln "Cancel 1") in
let h2 = Switch.add_cancel_hook sw (fun _ -> traceln "Cancel 2") in
let h3 = Switch.add_cancel_hook sw (fun _ -> traceln "Cancel 3") in
Switch.remove_hook h2;
Eio.Hook.remove h2;
Switch.turn_off sw (Failure "Cancelled");
let h4 = Switch.add_cancel_hook sw (fun _ -> traceln "Cancel 4") in
Switch.remove_hook h1;
Switch.remove_hook h3;
Switch.remove_hook h4
Eio.Hook.remove h1;
Eio.Hook.remove h3;
Eio.Hook.remove h4
);;
+Cancel 3
+Cancel 1
@ -154,15 +154,31 @@ Turning off a switch runs the cancel callbacks, unless they've been removed by t
Exception: Failure "Cancelled".
```
Wait for either a promise or a switch; switch cancelled first:
Cancellation callbacks do not run on success, but release ones do:
```ocaml
# run @@ fun sw ->
Switch.add_cancel_hook sw (fun _ -> traceln "Cance hook") |> ignore;
Switch.on_release sw (fun _ -> traceln "Release hook");;
+Release hook
- : unit = ()
```
Wait for either a promise or a cancellation; cancellation first:
```ocaml
# run (fun sw ->
let p, r = Promise.create () in
Fibre.fork_ignore ~sw (fun () -> traceln "Waiting"; Promise.await ~sw p; traceln "Resolved");
Switch.turn_off sw (Failure "Cancelled");
Promise.fulfill r ()
Fibre.fork_ignore ~sw (fun () ->
Fibre.both
(fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved")
(fun () -> failwith "Cancelled")
);
Fibre.yield ();
Promise.fulfill r ();
traceln "Main thread done";
);;
+Waiting
+Main thread done
Exception: Failure "Cancelled".
```
@ -171,7 +187,7 @@ Wait for either a promise or a switch; promise resolves first:
```ocaml
# run (fun sw ->
let p, r = Promise.create () in
Fibre.fork_ignore ~sw (fun () -> traceln "Waiting"; Promise.await ~sw p; traceln "Resolved");
Fibre.fork_ignore ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved");
Promise.fulfill r ();
Fibre.yield ();
traceln "Now cancelling...";
@ -188,7 +204,7 @@ Wait for either a promise or a switch; switch cancelled first. Result version.
```ocaml
# run (fun sw ->
let p, r = Promise.create () in
Fibre.fork_ignore ~sw (fun () -> traceln "Waiting"; ignore (Promise.await_result ~sw p); traceln "Resolved");
Fibre.fork_ignore ~sw (fun () -> traceln "Waiting"; ignore (Promise.await_result p); traceln "Resolved");
Switch.turn_off sw (Failure "Cancelled");
Promise.fulfill r ()
);;
@ -201,13 +217,14 @@ Wait for either a promise or a switch; promise resolves first but switch off wit
```ocaml
# run (fun sw ->
let p, r = Promise.create () in
Fibre.fork_ignore ~sw (fun () -> traceln "Waiting"; ignore (Promise.await_result ~sw p); traceln "Resolved");
Fibre.fork_ignore ~sw (fun () -> traceln "Waiting"; ignore (Promise.await_result p); traceln "Resolved");
Promise.fulfill r ();
traceln "Now cancelling...";
Switch.turn_off sw (Failure "Cancelled")
);;
+Waiting
+Now cancelling...
+Resolved
Exception: Failure "Cancelled".
```
@ -217,14 +234,14 @@ Child switches are cancelled when the parent is cancelled:
# run (fun sw ->
let p, _ = Promise.create () in
let on_error ex = traceln "child: %s" (Printexc.to_string ex) in
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await ~sw p);
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await ~sw p);
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await p);
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await p);
Switch.turn_off sw (Failure "Cancel parent")
);;
+Child 1
+Child 2
+child: Failure("Cancel parent")
+child: Failure("Cancel parent")
+child: Cancelled: Failure("Cancel parent")
+child: Cancelled: Failure("Cancel parent")
Exception: Failure "Cancel parent".
```
@ -235,8 +252,8 @@ A child can fail independently of the parent:
let p1, r1 = Promise.create () in
let p2, r2 = Promise.create () in
let on_error ex = traceln "child: %s" (Printexc.to_string ex) in
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await ~sw p1);
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await ~sw p2);
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await p1);
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await p2);
Promise.break r1 (Failure "Child error");
Promise.fulfill r2 ();
Fibre.yield ();
@ -271,13 +288,13 @@ A child can be cancelled independently of the parent:
- : unit = ()
```
A child error handle raises:
A child error handler raises:
```ocaml
# run (fun sw ->
let p, r = Promise.create () in
let on_error = raise in
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child"; Promise.await ~sw p);
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child"; Promise.await p);
Promise.break r (Failure "Child error escapes");
Fibre.yield ();
traceln "Not reached"
@ -290,12 +307,16 @@ A child error handler deals with the exception:
```ocaml
# run (fun sw ->
let print ex = traceln "%s" (Printexc.to_string ex); 0 in
let x = Switch.sub sw ~on_error:print (fun _sw -> failwith "Child error") in
traceln "x = %d" x
let p, r = Promise.create () in
let on_error = traceln "caught: %a" Fmt.exn in
Fibre.fork_sub_ignore ~sw ~on_error (fun sw -> traceln "Child"; Promise.await p);
Promise.break r (Failure "Child error is caught");
Fibre.yield ();
traceln "Still running"
);;
+Failure("Child error")
+x = 0
+Child
+caught: Failure("Child error is caught")
+Still running
- : unit = ()
```
@ -313,12 +334,16 @@ Failure
# Release handlers
```ocaml
let release label = Fibre.yield (); traceln "release %s" label
```
Release on success:
```ocaml
# run (fun sw ->
Switch.on_release sw (fun () -> traceln "release 1");
Switch.on_release sw (fun () -> traceln "release 2");
Switch.on_release sw (fun () -> release "1");
Switch.on_release sw (fun () -> release "2");
);;
+release 2
+release 1
@ -329,8 +354,8 @@ Release on error:
```ocaml
# run (fun sw ->
Switch.on_release sw (fun () -> traceln "release 1");
Switch.on_release sw (fun () -> traceln "release 2");
Switch.on_release sw (fun () -> release "1");
Switch.on_release sw (fun () -> release "2");
failwith "Test error"
);;
+release 2
@ -342,9 +367,9 @@ A release operation itself fails:
```ocaml
# run (fun sw ->
Switch.on_release sw (fun () -> traceln "release 1"; failwith "failure 1");
Switch.on_release sw (fun () -> traceln "release 2");
Switch.on_release sw (fun () -> traceln "release 3"; failwith "failure 3");
Switch.on_release sw (fun () -> release "1"; failwith "failure 1");
Switch.on_release sw (fun () -> release "2");
Switch.on_release sw (fun () -> release "3"; failwith "failure 3");
);;
+release 3
+release 2
@ -355,6 +380,21 @@ and
Failure("failure 1")
```
Attaching a release handler to a finished switch from a cancelled context:
```ocaml
# run @@ fun sw ->
let sub = Switch.run Fun.id in (* A finished switch *)
Switch.turn_off sw (Failure "Parent cancelled too!");
Switch.on_release sub (fun () -> release "1");;
+release 1
Exception:
Multiple exceptions:
Failure("Parent cancelled too!")
and
Invalid_argument("Switch finished!")
```
Using switch from inside release handler:
```ocaml
@ -389,9 +429,9 @@ Using switch from inside release handler:
```ocaml
let fork_sub_ignore_resource sw =
traceln "Allocate resource";
traceln "allocate resource";
Fibre.fork_sub_ignore ~sw ~on_error:raise
~on_release:(fun () -> traceln "Free resource")
~on_release:(fun () -> release "resource")
(fun _sw -> traceln "Child fibre running")
```
@ -401,9 +441,9 @@ We release when `fork_sub_ignore` returns:
# run (fun sw ->
fork_sub_ignore_resource sw
);;
+Allocate resource
+allocate resource
+Child fibre running
+Free resource
+release resource
- : unit = ()
```
@ -414,8 +454,8 @@ We release when `fork_sub_ignore` fails due to parent switch being already off:
Switch.turn_off sw (Failure "Switch already off");
fork_sub_ignore_resource sw
);;
+Allocate resource
+Free resource
+allocate resource
+release resource
Exception: Failure "Switch already off".
```
@ -423,12 +463,11 @@ We release when `fork_sub_ignore` fails due to parent switch being invalid:
```ocaml
# run (fun sw ->
let copy = ref sw in
Switch.sub sw ~on_error:raise (fun sub -> copy := sub);
fork_sub_ignore_resource !copy
let sub = Switch.run Fun.id in
fork_sub_ignore_resource sub
);;
+Allocate resource
+Free resource
+allocate resource
+release resource
Exception: Invalid_argument "Switch finished!".
```
@ -445,3 +484,23 @@ We release when `fork_sub_ignore`'s switch is turned off while running:
+Free resource
Exception: Failure "Simulated error".
```
# Error reporting
All cancel hooks run, even if some fail, and all errors are reported:
```ocaml
# run (fun sw ->
Switch.add_cancel_hook sw (fun _ -> failwith "cancel1 failed") |> ignore;
Switch.add_cancel_hook sw (fun _ -> failwith "cancel2 failed") |> ignore;
raise Exit
);;
Exception:
Multiple exceptions:
Stdlib.Exit
and
During cancellation:
Failure("cancel2 failed")
and
Failure("cancel1 failed")
```

12
tests/test_sync.md
View File

@ -21,7 +21,7 @@ Create a promise, fork a thread waiting for it, then fulfull it:
```ocaml
# let () =
Eio_main.run @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let p, r = Promise.create () in
traceln "Initial state: %a" (pp_promise Fmt.string) p;
let thread = Fibre.fork ~sw ~exn_turn_off:false (fun () -> Promise.await p) in
@ -42,7 +42,7 @@ Create a promise, fork a thread waiting for it, then break it:
```ocaml
# let () =
Eio_main.run @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let p, r = Promise.create () in
traceln "Initial state: %a" (pp_promise Fmt.string) p;
let thread = Fibre.fork ~sw ~exn_turn_off:false (fun () -> Promise.await p) in
@ -66,13 +66,13 @@ Some simple tests of `fork_ignore`:
# let () =
Eio_main.run @@ fun _stdenv ->
let i = ref 0 in
Switch.top (fun sw ->
Switch.run (fun sw ->
Fibre.fork_ignore ~sw (fun () -> incr i);
);
traceln "Forked code ran; i is now %d" !i;
let p1, r1 = Promise.create () in
try
Switch.top (fun sw ->
Switch.run (fun sw ->
Fibre.fork_ignore ~sw (fun () -> Promise.await p1; incr i; raise Exit);
traceln "Forked code waiting; i is still %d" !i;
Promise.fulfill r1 ()
@ -90,7 +90,7 @@ Basic semaphore tests:
# let () =
let module Semaphore = Eio.Semaphore in
Eio_main.run @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let running = ref 0 in
let sem = Semaphore.make 2 in
let fork = Fibre.fork ~sw ~exn_turn_off:false in
@ -126,7 +126,7 @@ Releasing a semaphore when no-one is waiting for it:
# let () =
let module Semaphore = Eio.Semaphore in
Eio_main.run @@ fun _stdenv ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
let sem = Semaphore.make 0 in
Semaphore.release sem; (* Release with free-counter *)
traceln "Initial config: %d" (Semaphore.get_value sem);

13
tests/test_time.md
View File

@ -41,8 +41,7 @@ Cancelling sleep:
```ocaml
# run @@ fun ~clock ->
Switch.top @@ fun sw ->
Fibre.both ~sw
Fibre.both
(fun () -> Eio.Time.sleep clock 1200.; assert false)
(fun () -> failwith "Simulated cancel");;
Exception: Failure "Simulated cancel".
@ -52,7 +51,7 @@ Switch is already off:
```ocaml
# run @@ fun ~clock ->
Switch.top @@ fun sw ->
Switch.run @@ fun sw ->
Switch.turn_off sw (Failure "Simulated failure");
Eio.Time.sleep clock 1200.0;
assert false;;
@ -63,8 +62,8 @@ Scheduling a timer that's already due:
```ocaml
# run @@ fun ~clock ->
Switch.top @@ fun sw ->
Fibre.both ~sw
Switch.run @@ fun sw ->
Fibre.both
(fun () -> traceln "First fibre runs"; Eio.Time.sleep clock (-1.0); traceln "Sleep done")
(fun () -> traceln "Second fibre runs");;
+First fibre runs
@ -77,8 +76,8 @@ Check ordering works:
```ocaml
# run @@ fun ~clock ->
Switch.top @@ fun sw ->
Fibre.both ~sw
Switch.run @@ fun sw ->
Fibre.both
(fun () ->
Eio.Time.sleep clock 1200.0;
assert false