├── src
    ├── affect.mllib
    ├── unix
    │   ├── affect_unix.mllib
    │   ├── netmsg.mli
    │   ├── netmsg.ml
    │   ├── funix.mli
    │   └── funix.ml
    ├── affect_top_init.ml
    ├── fiber.mli
    └── fiber.ml
├── BRZO
├── .gitignore
├── .merlin
├── CHANGES.md
├── _tags
├── pkg
    ├── pkg.ml
    └── META
├── LICENSE.md
├── attic
    ├── evloop_stubs.h
    ├── evloop_stubs_time.c
    ├── evloop.ml
    └── evloop.mli
├── opam
├── test
    ├── test_busy.ml
    ├── test_funix.ml
    ├── happy_eyeballs.ml
    ├── mouse.ml
    ├── ping.ml
    └── test_fiber.ml
├── README.md
├── B0.ml
└── doc
    ├── index.mld
    └── design.mld


/src/affect.mllib:
--------------------------------------------------------------------------------
1 | Fiber


--------------------------------------------------------------------------------
/BRZO:
--------------------------------------------------------------------------------
1 | (srcs-x test test-evloop pkg attic)


--------------------------------------------------------------------------------
/src/unix/affect_unix.mllib:
--------------------------------------------------------------------------------
1 | Funix
2 | Netmsg


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | _b0
2 | _build
3 | tmp
4 | *.install


--------------------------------------------------------------------------------
/.merlin:
--------------------------------------------------------------------------------
1 | PKG b0.kit unix tsdl
2 | S src
3 | S test
4 | B _b0/**


--------------------------------------------------------------------------------
/CHANGES.md:
--------------------------------------------------------------------------------
1 | v0.1.0 YYYY-MM-DD Loc
2 | ------------------------
3 | 
4 | First release.
5 | 


--------------------------------------------------------------------------------
/_tags:
--------------------------------------------------------------------------------
1 | true : bin_annot, safe_string
2 | <_b0> : -traverse
3 | <src> : include
4 | <src/unix> : include
5 | <src/unix/**> : package(unix)
6 | 


--------------------------------------------------------------------------------
/src/affect_top_init.ml:
--------------------------------------------------------------------------------
1 | (*---------------------------------------------------------------------------
2 |    Copyright (c) 2024 The affect programmers. All rights reserved.
3 |    SPDX-License-Identifier: ISC
4 |   ---------------------------------------------------------------------------*)
5 | 
6 | #install_printer Fiber.pp;;
7 | #install_printer Fiber.Handle.pp;;
8 | 


--------------------------------------------------------------------------------
/pkg/pkg.ml:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env ocaml
 2 | #use "topfind"
 3 | #require "topkg"
 4 | open Topkg
 5 | 
 6 | let () =
 7 |   Pkg.describe "affect" @@ fun c ->
 8 |   Ok [ Pkg.mllib "src/affect.mllib";
 9 |        Pkg.mllib "src/unix/affect_unix.mllib" ~dst_dir:"unix";
10 |        Pkg.lib "src/affect_top_init.ml";
11 |        Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"
12 |        Pkg.doc "doc/index.mld" ~dst:"odoc-pages/design.mld"]
13 | 


--------------------------------------------------------------------------------
/pkg/META:
--------------------------------------------------------------------------------
 1 | description = "Concurrency and parallelism for OCaml 5"
 2 | version = "%%VERSION_NUM%%"
 3 | requires = ""
 4 | archive(byte) = "affect.cma"
 5 | archive(native) = "affect.cmxa"
 6 | plugin(byte) = "affect.cma"
 7 | plugin(native) = "affect.cmxs"
 8 | exists_if = "affect.cma affect.cmxa"
 9 | 
10 | package "unix" (
11 |   directory = "unix"
12 |   description = "The affect.unix library"
13 |   version = "%%VERSION_NUM%%"
14 |   requires = "unix affect"
15 |   archive(byte) = "affect_unix.cma"
16 |   archive(native) = "affect_unix.cmxa"
17 |   plugin(byte) = "affect_unix.cma"
18 |   plugin(native) = "affect_unix.cmxs"
19 |   exists_if = "affect_unix.cma affect_unix.cmxa"
20 | )
21 | 


--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2021 The affect programmers
 2 | 
 3 | Permission to use, copy, modify, and/or distribute this software for any
 4 | purpose with or without fee is hereby granted, provided that the above
 5 | copyright notice and this permission notice appear in all copies.
 6 | 
 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 | 


--------------------------------------------------------------------------------
/attic/evloop_stubs.h:
--------------------------------------------------------------------------------
 1 | /*---------------------------------------------------------------------------
 2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
 3 |    SPDX-License-Identifier: ISC
 4 |   ---------------------------------------------------------------------------*/
 5 | 
 6 | #include <caml/mlvalues.h>
 7 | #include <caml/alloc.h>
 8 | #include <caml/memory.h>
 9 | #include <caml/fail.h>
10 | 
11 | #define OCAML_EVLOOP_RAISE_SYS_ERROR(ERR)                               \
12 |   do { caml_raise_sys_error (caml_copy_string("Evloop stubs: " ERR)); } \
13 |   while (0)
14 | 
15 | /* Detect platform */
16 | 
17 | #if defined(__APPLE__) && defined(__MACH__)
18 |   #define OCAML_EVLOOP_DARWIN
19 | 
20 | #elif defined(__unix__) || defined(__unix)
21 |  #include <unistd.h>
22 |  #if defined(_POSIX_VERSION)
23 |    #define OCAML_EVLOOP_POSIX
24 |  #endif
25 | 
26 | #elif defined (_WIN32)
27 | #define OCAML_EVLOOP_WINDOWS
28 | #define WIN32_LEAN_AND_MEAN
29 | 
30 | #endif
31 | 


--------------------------------------------------------------------------------
/opam:
--------------------------------------------------------------------------------
 1 | opam-version: "2.0"
 2 | name: "affect"
 3 | synopsis: "Concurrency and parallelism for OCaml 5"
 4 | description: """\
 5 | Affect is a streamlined and natural [concurrency model] for OCaml 5.
 6 | It just provides parallel asynchronous function calls with structured
 7 | cooperative concurrency and cancellation.
 8 | 
 9 | Affect is distributed under the ISC license. It has no dependencies.
10 | 
11 | Homepage: <https://erratique.ch/software/affect>  
12 | 
13 | [concurrency model]: https://erratique.ch/software/affect/doc/Fiber/index.html#concurrency_model"""
14 | maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>"
15 | authors: "The affect programmers"
16 | license: "ISC"
17 | tags: ["effects" "concurrency" "parallelism" "fibers" "org:erratique"]
18 | homepage: "https://erratique.ch/software/affect"
19 | doc: "https://erratique.ch/software/affect/doc"
20 | bug-reports: "https://github.com/dbuenzli/affect/issues"
21 | depends: [
22 |   "ocaml" {>= "5.3.0"}
23 |   "ocamlfind" {build}
24 |   "ocamlbuild" {build}
25 |   "topkg" {build & >= "1.0.3"}
26 | ]
27 | build: ["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"]
28 | dev-repo: "git+https://erratique.ch/repos/affect.git"
29 | 


--------------------------------------------------------------------------------
/test/test_busy.ml:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2024 The affect programmers. All rights reserved.
 3 |    SPDX-License-Identifier: ISC
 4 |   ---------------------------------------------------------------------------*)
 5 | 
 6 | (* Tests that a blocked fiber does not busy wait.
 7 | 
 8 |    b0 -- test_busy
 9 |    top -pid $(pgrep test_busy)
10 |    nc localhost 10101 *)
11 | 
12 | let ( let* ) = Result.bind
13 | let log fmt = Format.printf (fmt ^^ "@.")
14 | 
15 | let serve_client ~endpoint =
16 |   Result.join @@ Funix.Signal.with' Sys.sigpipe Sys.Signal_ignore @@ fun () ->
17 |   let* l = Netmsg.listener ~endpoint () in
18 |   let finally () = Netmsg.close_listener l in
19 |   Fun.protect ~finally @@ fun () ->
20 |   log "Waiting for a client…";
21 |   let* conn = Netmsg.listen l in
22 |   log "Got a client! But we have nothing to say, closing.";
23 |   Netmsg.close conn;
24 |   Ok ()
25 | 
26 | let rec main () =
27 |   Fiber.main ~unblock:Funix.unblock @@ fun () ->
28 |   let endpoint = `Host ("localhost", 10101) in
29 |   let serve = Fiber.async @@ fun () -> serve_client ~endpoint in
30 |   match Fiber.await serve (* This must not busy wait *) with
31 |   | Ok () -> 0
32 |   | Error e -> log "Error: %s" e; 1
33 | 
34 | let () = if !Sys.interactive then () else exit (main ())
35 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | Affect — Concurrency and parallelism for OCaml 5
 2 | ================================================
 3 | 
 4 | Affect is a streamlined and natural [concurrency model] for OCaml 5.
 5 | It just provides parallel asynchronous function calls with structured
 6 | cooperative concurrency and cancellation.
 7 | 
 8 | Affect is distributed under the ISC license. It has no dependencies.
 9 | 
10 | Homepage: <https://erratique.ch/software/affect>  
11 | 
12 | [concurrency model]: https://erratique.ch/software/affect/doc/Fiber/index.html#concurrency_model
13 | 
14 | ## Installation
15 | 
16 | Affect can be installed with `opam`: 
17 | 
18 |     opam pin add affect https://erratique.ch/repos/affect.git
19 | 
20 | If you don't use `opam` consult the [`opam`](opam) file for build
21 | instructions.
22 | 
23 | ## Documentation
24 | 
25 | The documentation can be consulted [online][doc] or via `odig doc affect`.
26 | 
27 | Questions are welcome but better asked on the [OCaml forum][ocaml-forum] 
28 | than on the issue tracker.
29 | 
30 | [doc]: https://erratique.ch/software/affect/doc/
31 | [ocaml-forum]: https://discuss.ocaml.org/
32 | 
33 | ## Sample code
34 | 
35 | A few basic sample programs can be found in the [test](test/)
36 | directory.
37 | 
38 | * [`ping.ml`](test/ping.ml), client and server using `Funix` to 
39 |   do useless networking on your machine.
40 | * [`mouse.ml`](test/mouse.ml), proof of concept interfacing 
41 |   with the SDL event loop.
42 | * [`happy_eyeballs.ml`](test/happy_eyeballs.ml), an implementation
43 |   of a happy eyeballs 
44 | 
45 | You can run them with `b0 -- ping` or `b0 -- mouse`.
46 | 


--------------------------------------------------------------------------------
/test/test_funix.ml:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
 3 |    SPDX-License-Identifier: ISC
 4 |   ---------------------------------------------------------------------------*)
 5 | 
 6 | open B0_testing
 7 | 
 8 | let log fmt = Test.log ("%a " ^^ fmt) Fiber.Handle.pp (Fiber.Handle.self ())
 9 | let unblock = Funix.unblock
10 | 
11 | let rand = Test.Rand.state ()
12 | let flip () = Random.State.bool rand
13 | let now_s () = Unix.gettimeofday ()
14 | let test_sleeps () =
15 |   Test.test "simple sleep" @@ fun () ->
16 |   Fiber.main ~unblock @@ fun () ->
17 |   let rec f start n =
18 |     if n = 0 then () else
19 |     let dur_s = 0.25 in
20 |     log " Sleeping for %.02fs" dur_s;
21 |     Funix.sleep_s dur_s;
22 |     f start (n - 1)
23 |   in
24 |   let start = now_s () in
25 |   f start 4;
26 |   log " Took %02fs" (now_s () -. start)
27 | 
28 | let test_either_sleep () =
29 |   Test.test "Fiber.pick_either shortest sleep" @@ fun () ->
30 |   Fiber.main ~unblock @@ fun () ->
31 |   let left_returns = ref false in
32 |   let right_cancel = ref false in
33 |   let left () = Funix.sleep_s 0.5; left_returns := true in
34 |   let right () = try Funix.sleep_s 1.0; Test.fail "Unexpected" ~__POS__ with
35 |   | Fiber.Cancelled -> right_cancel := true
36 |   in
37 |   let left = Fiber.async left in
38 |   let right = Fiber.async right in
39 |   begin match Fiber.pick_either left right with
40 |   | Either.Left () -> ()
41 |   | Either.Right () -> Test.fail "Unexpected" ~__POS__
42 |   end;
43 |   Test.holds !left_returns ~__POS__;
44 |   Fiber.await right;
45 |   Test.holds !right_cancel ~__POS__;
46 |   ()
47 | 
48 | let main () =
49 |   Test.main @@ fun () ->
50 |   test_sleeps ();
51 |   test_either_sleep ();
52 |   ()
53 | 
54 | let () = if !Sys.interactive then () else exit (main ())
55 | 


--------------------------------------------------------------------------------
/src/unix/netmsg.mli:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
 3 |    SPDX-License-Identifier: ISC
 4 |   ---------------------------------------------------------------------------*)
 5 | 
 6 | (** Send messages over stream sockets. *)
 7 | 
 8 | (** {1:connection Connection} *)
 9 | 
10 | type t
11 | (** The type for connections. *)
12 | 
13 | val connect : endpoint:Funix.endpoint -> (t option, string) result
14 | (** [connect ~endpoint] connects to a server offered on endpoint
15 |     [endpoint]. [None] is returned if no server could be found. *)
16 | 
17 | val close : t -> unit
18 | (** [close c] closes a connection. This never errors. *)
19 | 
20 | val fd : t -> Unix.file_descr
21 | (** [fd c] is the file descriptor of [c]. *)
22 | 
23 | (** {2:communication Communication} *)
24 | 
25 | val send : t -> string -> (bool, string) result
26 | (** [send c s] sends bytes [s] on [c]. The result is [Ok false] if
27 |     the peer ends the connection, no guarantees that the message went
28 |     through.  *)
29 | 
30 | val recv : t -> (string option, string) result
31 | (** [recv c] receives bytes from [c] and is [Ok None] if the peer
32 |     ends the connection. *)
33 | 
34 | (** {1:listener Connection listeners} *)
35 | 
36 | type listener
37 | (** The type for connection listeners. *)
38 | 
39 | val listener :
40 |   ?backlog:int -> endpoint:Funix.endpoint -> unit -> (listener, string) result
41 | (** [listener ~backlog ~endpoint ()] is a connection listener on [endpoint].
42 |     [backlog] is the argument for {!Unix.listen} (defaults to [128]). *)
43 | 
44 | val listen : listener -> (t, string) result
45 | (** [listen ~endpoint] offers a connection on [endpoint].  Blocks
46 |     until a client connects. The caller must eventually {!close} the
47 |     connection. *)
48 | 
49 | val close_listener : listener -> unit
50 | (** [close_listener l] closes listener [l].  *)
51 | 


--------------------------------------------------------------------------------
/test/happy_eyeballs.ml:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2024 The affect programmers. All rights reserved.
 3 |    SPDX-License-Identifier: CC0-1.0
 4 |   ---------------------------------------------------------------------------*)
 5 | 
 6 | (* This implements the following fiber structure
 7 | 
 8 |   x = tries is None
 9 | 
10 |   t----x----x------x------x----x--------- …
11 |   |
12 | --seqs----------------------------------- …
13 |   |
14 |   |           t---x--x---x----x------x--- …
15 |   |  delay_s  |
16 |   ts----------seqs----------------------- …
17 |               |
18 |               |            t-------x----- …
19 |               |  delay_s   |
20 |               ts--------- seqs----------- …
21 |                            |
22 |                            …  *)
23 | 
24 | (* TODO check in ts depends on semantics of sleep_s
25 |    TODO is Fiber.pick_either really enlighting ? Its more to remember.
26 |    We could also have only  Fiber.either and a cancel_and_await. *)
27 | 
28 | 
29 | let queue l = (* Need to make that Queue thread safe *)
30 |   let q = Queue.of_seq (List.to_seq l) in
31 |   let m = Mutex.create () in
32 |   let is_empty () = Mutex.protect m @@ fun () -> Queue.is_empty q in
33 |   let next () = Mutex.protect m @@ fun () -> Queue.take_opt q in
34 |   is_empty, next
35 | 
36 | let happy_eyeballs :
37 |     delay_s:float -> tries:(unit -> 'a option) list -> discard:('a -> unit) ->
38 |     'a option
39 | =
40 | fun ~delay_s ~tries ~discard ->
41 |   let is_empty, next = queue tries in
42 |   let rec seq () =
43 |     if Fiber.self_is_cancelled () then None else match next () with
44 |     | None -> None
45 |     | Some trial -> match trial () with None -> seq () | Some _ as v -> v
46 |   in
47 |   let rec seqs () =
48 |     if is_empty () || Fiber.self_is_cancelled () then None else
49 |     let t = Fiber.async seq in
50 |     let ts = Fiber.async @@ fun () -> match Funix.sleep_s delay_s with
51 |       | exception Fiber.Cancelled -> None
52 |       | () -> seqs ()
53 |     in
54 |     match Fiber.pick_either t ts with
55 |     | Either.Left t -> Option.iter discard (Fiber.await ts); t
56 |     | Either.Right ts -> Option.iter discard (Fiber.await t); ts
57 |   in
58 |   seqs ()
59 | 


--------------------------------------------------------------------------------
/attic/evloop_stubs_time.c:
--------------------------------------------------------------------------------
 1 | /*---------------------------------------------------------------------------
 2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
 3 |    SPDX-License-Identifier: ISC
 4 |   ---------------------------------------------------------------------------*/
 5 | 
 6 | #include "evloop_stubs.h"
 7 | #include <stdint.h>
 8 | 
 9 | /* Darwin */
10 | 
11 | #if defined(OCAML_EVLOOP_DARWIN)
12 | 
13 | #include <mach/mach_time.h>
14 | 
15 | static mach_timebase_info_data_t scale = {0};
16 | static void _ocaml_evloop_clock_init_scale (void)
17 | {
18 |   if (mach_timebase_info (&scale) != KERN_SUCCESS)
19 |     OCAML_EVLOOP_RAISE_SYS_ERROR ("mach_timebase_info () failed");
20 | 
21 |   if (scale.denom == 0)
22 |     OCAML_EVLOOP_RAISE_SYS_ERROR ("mach_timebase_info_data.denom is 0");
23 | }
24 | 
25 | CAMLprim value ocaml_evloop_monotonic_now_ns (value unit)
26 | {
27 |   if (scale.denom == 0) { _ocaml_evloop_clock_init_scale (); }
28 |   uint64_t now = mach_absolute_time ();
29 |   return caml_copy_int64 ((now * scale.numer) / scale.denom);
30 | }
31 | 
32 | /* POSIX */
33 | 
34 | #elif defined(OCAML_EVLOOP_POSIX)
35 | 
36 | #include <time.h>
37 | 
38 | CAMLprim value ocaml_evloop_monotonic_now_ns (value unit)
39 | {
40 |   struct timespec now;
41 | 
42 |   if (clock_gettime (CLOCK_MONOTONIC, &now))
43 |     OCAML_EVLOOP_RAISE_SYS_ERROR ("clock_gettime () failed");
44 | 
45 |   return caml_copy_int64 ((uint64_t)(now.tv_sec) *
46 |                           (uint64_t)1000000000 +
47 |                           (uint64_t)(now.tv_nsec));
48 | }
49 | 
50 | /* Windows */
51 | 
52 | #elif defined(OCAML_EVLOOP_WINDOWS)
53 | 
54 | #include <windows.h>
55 | 
56 | static double freq = 0;
57 | static void _ocaml_evloop_clock_init_freq (void)
58 | {
59 |   LARGE_INTEGER f;
60 |   if (!QueryPerformanceFrequency(&f))
61 |     OCAML_EVLOOP_RAISE_SYS_ERROR ("QueryPerformanceFrequency () failed");
62 |   freq = (1000000000.0 / f.QuadPart);
63 | }
64 | 
65 | CAMLprim value ocaml_evloop_monotonic_now_ns (value unit)
66 | {
67 |   static LARGE_INTEGER now;
68 |   if (freq == 0) _ocaml_evloop_clock_init_freq ();
69 |   if (!QueryPerformanceCounter(&now))
70 |     OCAML_EVLOOP_RAISE_SYS_ERROR ("QueryPerformanceCounter () failed");
71 |   return caml_copy_int64 ((uint64_t)(now.QuadPart * freq));
72 | }
73 | 
74 | /* Unsupported */
75 | 
76 | #else
77 | 
78 | #warning OCaml Nandi library: unsupported platform, monotonic timings will be wrong
79 | 
80 | CAMLprim value ocaml_evloop_monotonic_now_ns (value unit)
81 | {
82 |   return caml_copy_int64 ((uint64_t)0);
83 | }
84 | 
85 | #endif
86 | 


--------------------------------------------------------------------------------
/B0.ml:
--------------------------------------------------------------------------------
 1 | open B0_kit.V000
 2 | open Result.Syntax
 3 | 
 4 | (* OCaml library names *)
 5 | 
 6 | let b0_std = B0_ocaml.libname "b0.std"
 7 | let unix = B0_ocaml.libname "unix"
 8 | 
 9 | let affect = B0_ocaml.libname "affect"
10 | let affect_unix = B0_ocaml.libname "affect.unix"
11 | 
12 | (* Libraries *)
13 | 
14 | let affect_lib =
15 |   let srcs = [ `Dir ~/"src"; `X ~/"src/affect_top_init.ml" ] in
16 |   B0_ocaml.lib affect ~srcs
17 | 
18 | let affect_unix_lib =
19 |   let srcs = [ `Dir ~/"src/unix" ] in
20 |   B0_ocaml.lib affect_unix ~srcs ~requires:[unix; affect]
21 | 
22 | (* Tests *)
23 | 
24 | let test ?(requires = []) = B0_ocaml.test ~requires:(affect :: requires)
25 | 
26 | let test_affect =
27 |   let doc = "Fiber tests" in
28 |   test ~/"test/test_fiber.ml" ~doc ~requires:[b0_std; affect]
29 | 
30 | let test_unix =
31 |   let requires = [b0_std; unix; affect_unix] in
32 |   test ~/"test/test_funix.ml" ~doc:"affect.unix tests" ~requires
33 | 
34 | let test_busy =
35 |   let requires = [unix; affect_unix] in
36 |   test ~/"test/test_busy.ml" ~doc:"No CPU used!" ~requires ~run:false
37 | 
38 | let ping =
39 |   let requires = [unix; affect_unix] in
40 |   test ~/"test/ping.ml" ~doc:"Ping-pong test" ~requires ~run:false
41 | 
42 | let mouse =
43 |   let tsdl = B0_ocaml.libname "tsdl" in
44 |   test ~/"test/mouse.ml" ~doc:"Mouse test" ~requires:[tsdl; affect] ~run:false
45 | 
46 | let happy_eyeballs =
47 |   let doc = "Happy eyeballs" in
48 |   test ~/"test/happy_eyeballs.ml" ~doc ~requires:[unix; affect_unix] ~run:false
49 | 
50 | (* Packs *)
51 | 
52 | let default =
53 |   let meta =
54 |     B0_meta.empty
55 |     |> ~~ B0_meta.authors ["The affect programmers"]
56 |     |> ~~ B0_meta.maintainers ["Daniel Bünzli <daniel.buenzl i@erratique.ch>"]
57 |     |> ~~ B0_meta.homepage "https://erratique.ch/software/affect"
58 |     |> ~~ B0_meta.online_doc "https://erratique.ch/software/affect/doc"
59 |     |> ~~ B0_meta.licenses ["ISC"]
60 |     |> ~~ B0_meta.repo "git+https://erratique.ch/repos/affect.git"
61 |     |> ~~ B0_meta.issues "https://github.com/dbuenzli/affect/issues"
62 |     |> ~~ B0_meta.description_tags
63 |       ["effects"; "concurrency"; "parallelism"; "fibers"; "org:erratique"; ]
64 |     |> ~~ B0_opam.build
65 |       {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"]]|}
66 |     |> ~~ B0_opam.depends
67 |       [ "ocaml", {|>= "5.3.0"|};
68 |         "ocamlfind", {|build|};
69 |         "ocamlbuild", {|build|};
70 |         "topkg", {|build & >= "1.0.3"|}; ]
71 |     |> B0_meta.tag B0_opam.tag
72 |   in
73 |   B0_pack.make "default" ~doc:"affect" ~meta ~locked:true @@
74 |   B0_unit.list ()
75 | 


--------------------------------------------------------------------------------
/doc/index.mld:
--------------------------------------------------------------------------------
 1 | {0 Affect {%html: <span class="version">%%VERSION%%</span>%}}
 2 | 
 3 | Affect is a streamlined and natural
 4 | {{!Fiber.concurrency_model}concurrency model} for OCaml 5. It just
 5 | provides parallel asynchronous function calls with structured
 6 | cooperative concurrency and cancellation.
 7 | 
 8 | {!modules: Fiber}
 9 | 
10 | {1:sample Sample IO interaction}
11 | 
12 | These modules are just provided to show how one can compose fibers with
13 | the functionality of the {!Unix} module.
14 | 
15 | {!modules: Funix Netmsg}
16 | 
17 | {1:todo TODO}
18 | 
19 | See also the {{!page-design}design notes}.
20 | 
21 | {ul
22 | {- More {e scheduling} extensibility ? E.g. we could have
23 |    an heterogenous dict on fibers in which more hints can be tucked.}
24 | {- Expose the internals for allowing other schedulers. We have
25 |    a problem with the unboxed of {!Handle.t}, see
26 |    {{:https://discuss.ocaml.org/t/this-type-cannot-be-unboxed}here}.
27 |    We may need to go back to boxed existentials and store one
28 |    in the fiber as we used to do.}
29 | {- Client defined blocks and their associated [unblock] are very
30 |    general and they don't compose well. We should not allow
31 |    them to block on [poll:false]: we should give them a function
32 |    to unblock the scheduler. Also more should be said about how
33 |    unblock functions are called by schedulers. Another strategy would
34 |    be for the scheduler to give a function to call to unblock on
35 |    {!Fiber.block} creations. That would in turn render [unblock] functions
36 |    useless but the scheduler losses the global view on "unblocker" execution.}
37 | {- Not sold on the design of {!Fiber.block} yet. Maybe the narrative
38 |    should be on on an asynchronous "primitive", in the same way
39 |    we have C primitives. It would also nice to have a compositional await
40 |    à la CML {!Event}, having the trapping combinators is nice but it's also
41 |    a bit wasteful (depends on how lightweight we can make the fibers). It's
42 |    should be a unification of blocking, e.g. it should be possible to
43 |    conjunct and disjunct on a blocking operation and an await. Look again
44 |    the waiter sets we had in Fut. In fact it's likely that {!block}
45 |    is just a form of event in which you can indicate it will never happen.
46 |    The whole narrative becomes that we have fibers and (composable) events
47 |    they can block on until they occur, the return of a fiber/system function
48 |    call is a particular event. We end up inventing nothing which is a good
49 |    sign.}
50 | {- Cancellation of {!block} still needs more work. The problem with
51 |    the current suggestion on {!block} is that users may rely on
52 |    raising {!block} for their own cancellation. But that's
53 |    racy. Perhaps we should always raise on a block by a cancelled ops
54 |    except in {!Fiber.non_cancelling_block} scopes. And {!async}'s in
55 |    these blocks should not start cancelled. But the nesting may be
56 |    difficult to comprehend. This needs to be pinned against concrete
57 |    code.}
58 | {- {!Fiber.poll} is smelly. Tempts users into scheduling. If that
59 |    is the case it may mean that we don't have good enough synchronsation
60 |    tools.}
61 | {- Add an {!Fiber.await_cancellation} function.}
62 | {- Old note. [Funix] shows how to use [Fiber.block] with [Unix.select].
63 |    It would be interesting to be able to use a fixed API but switch backends.
64 |    One way would be to use effects in the [Fiber.block] argument and let
65 |    backend interprets them. This would lead to the following code
66 |    structure:
67 |    {[Evloop.run (fun () -> Fiber.run ~unblock:Evloop.unblock main)]}}}
68 | 


--------------------------------------------------------------------------------
/src/unix/netmsg.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | let fmt_error fmt = Format.kasprintf (fun s -> Error s) fmt
  7 | let uerror = Unix.error_message
  8 | let connection_error ep e = fmt_error "connection %a: %s" Funix.pp_endpoint ep e
  9 | let listener_error ep e = fmt_error "listener %a: %s" Funix.pp_endpoint ep e
 10 | 
 11 | (* Connection *)
 12 | 
 13 | type t =
 14 |   { ep : Funix.endpoint;
 15 |     fd : Unix.file_descr;
 16 |     len_buf : Bytes.t; (* 8 bytes for encoding an int64 *)
 17 |     close : bool (* true if [fd] must be closed at the end. *); }
 18 | 
 19 | let make ep fd ~close = { ep; fd; len_buf = Bytes.create 8; close  }
 20 | 
 21 | let connect ~endpoint:ep =
 22 |   match Funix.socket_of_endpoint ep Unix.SOCK_STREAM with
 23 |   | Error e -> connection_error ep e
 24 |   | Ok (None, sock, close) -> Ok (Some (make ep sock ~close))
 25 |   | Ok (Some addr, sock, close) ->
 26 |       match Funix.connect sock addr with
 27 |       | () -> Ok (Some (make ep sock ~close))
 28 |       | exception exn ->
 29 |           let bt = Printexc.get_raw_backtrace () in
 30 |           if close then Funix.close_noerr sock;
 31 |           match exn with
 32 |           | Unix.(Unix_error ((ENOENT | ECONNREFUSED), _, _)) -> Ok None
 33 |           | Unix.Unix_error (e,_,_) -> connection_error ep (uerror e)
 34 |           | exn -> Printexc.raise_with_backtrace exn bt
 35 | 
 36 | let close c =
 37 |   if c.close then begin
 38 |     (try Unix.shutdown c.fd Unix.SHUTDOWN_ALL with Unix.Unix_error _ -> ());
 39 |     Funix.close_noerr c.fd
 40 |   end
 41 | 
 42 | let fd c = c.fd
 43 | 
 44 | (* Communication *)
 45 | 
 46 | let send c s =
 47 |   try
 48 |     let len = String.length s in
 49 |     Bytes.set_int64_be c.len_buf 0 (Int64.of_int len);
 50 |     Funix.write c.fd c.len_buf ~start:0 ~len:(Bytes.length c.len_buf);
 51 |     Funix.write c.fd (Bytes.unsafe_of_string s) ~start:0 ~len;
 52 |     Ok true
 53 |   with
 54 |   | Unix.(Unix_error (EPIPE, _, _)) -> Ok false
 55 |   | Unix.Unix_error (e, _, _) -> connection_error c.ep (Unix.error_message e)
 56 | 
 57 | let recv c =
 58 |   try
 59 |     let len = Bytes.length c.len_buf in
 60 |     match Funix.read c.fd c.len_buf ~start:0 ~len with
 61 |     | false -> Ok None
 62 |     | true ->
 63 |         let len = Int64.to_int (Bytes.get_int64_be c.len_buf 0) in
 64 |         let b = Bytes.create len in
 65 |         match Funix.read c.fd b ~start:0 ~len with
 66 |         | true -> Ok (Some (Bytes.unsafe_to_string b))
 67 |         | false -> connection_error c.ep "Unexpected end of connection."
 68 |   with
 69 |   | Unix.Unix_error (e, _, _) -> connection_error c.ep (Unix.error_message e)
 70 | 
 71 | (* Listener *)
 72 | 
 73 | let unlink_noerr file = try Unix.unlink file with Unix.Unix_error _ -> ()
 74 | let cleanup_sockaddr_noerr addr = match addr with
 75 | | Some Unix.ADDR_UNIX file -> unlink_noerr file  | _ -> ()
 76 | 
 77 | type listener =
 78 |   { ep : Funix.endpoint;
 79 |     fd : Unix.file_descr;
 80 |     addr : Unix.sockaddr option;
 81 |     close : bool (* true if [fd] must be closed at the end. *) }
 82 | 
 83 | let close_listener l =
 84 |   cleanup_sockaddr_noerr l.addr;
 85 |   if l.close then Funix.close_noerr l.fd
 86 | 
 87 | let listener ?(backlog = 128) ~endpoint:ep () =
 88 |   match Funix.socket_of_endpoint ep Unix.SOCK_STREAM with
 89 |   | Error e -> connection_error ep e
 90 |   | Ok (addr, sock, close) ->
 91 |       let l = { ep; fd = sock; addr; close } in
 92 |       try
 93 |         begin match addr with
 94 |         | None -> ()
 95 |         | Some (Unix.ADDR_UNIX _ as addr) -> Unix.bind sock addr
 96 |         | Some (Unix.ADDR_INET _ as addr) ->
 97 |             Unix.setsockopt sock Unix.SO_REUSEADDR true;
 98 |             Unix.bind sock addr
 99 |         end;
100 |         Unix.listen sock backlog;
101 |         Ok l
102 |       with
103 |       | exn ->
104 |           let bt = Printexc.get_raw_backtrace () in
105 |           close_listener l;
106 |           match exn with
107 |           | Unix.Unix_error (e, _, _) ->
108 |               listener_error ep (Unix.error_message e)
109 |           | exn -> Printexc.raise_with_backtrace exn bt
110 | 
111 | let listen l = match Funix.accept l.fd with
112 | | fd, addr -> Ok (make (`Sockaddr addr) fd ~close:true)
113 | | exception Unix.Unix_error (e, _, _) ->
114 |     listener_error l.ep (Unix.error_message e)
115 | 


--------------------------------------------------------------------------------
/test/mouse.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | (* Compile and run with:
  7 | 
  8 |    ocamlfind ocamlopt -package tsdl,affect -linkpkg -thread -o mouse mouse.ml
  9 |    ./mouse
 10 | 
 11 |    mouse runs two fiber. One asks for the next click, the other one for the
 12 |    two next clicks. Everyone will be served. *)
 13 | 
 14 | let strf = Format.asprintf
 15 | 
 16 | open Tsdl
 17 | 
 18 | (** Fiber friendly SDL functions *)
 19 | module Fsdl : sig
 20 | 
 21 |   val with_window : (Sdl.window -> 'a) -> ('a, string) result
 22 |   (** [with_window work] runs [work] with a window setup. *)
 23 | 
 24 |   (** {1:unblock Fiber unblocking} *)
 25 | 
 26 |   val unblock : Fiber.unblock
 27 |   (** [unblock] is the function to unblock fibers blocked by the function
 28 |       of this module. You must use this function with {!Fiber.val-run}. *)
 29 | 
 30 |   (** {1:wait Events} *)
 31 | 
 32 |   val mouse_button_up : unit -> (int * int)
 33 |   (** [mouse_button_up ()] are the coordinates of the next mouse button
 34 |       up event. *)
 35 | end = struct
 36 | 
 37 |   let with_window work = match Sdl.init Sdl.Init.video with
 38 |   | Error (`Msg e) -> Error (strf "Init error: %s" e)
 39 |   | Ok () ->
 40 |       let flags = Sdl.Window.(shown + mouse_focus + resizable) in
 41 |       match Sdl.create_window ~w:640 ~h:480 "Mouse" flags with
 42 |       | Error (`Msg e) -> Error (strf "Create window error: %s" e)
 43 |       | Ok w ->
 44 |           Sdl.start_text_input ();
 45 |           let finally () = Sdl.destroy_window w; Sdl.quit () in
 46 |           Ok (Fun.protect ~finally (fun () -> work w))
 47 | 
 48 |   (* Per domain blocking data structure.
 49 | 
 50 |      The domain local storage is likely useless here. I bet you can't access
 51 |      SDL except from the main domain.
 52 | 
 53 |      This could easily be generalized to block on any event, we just
 54 |      use mouse up for demonstration purposes. *)
 55 | 
 56 |   module Fmap = Map.Make (Fiber.Handle)
 57 |   type blocked =
 58 |     { mutable mouse_button_up : (int * int) ref Fmap.t;
 59 |       ready : Fiber.Handle.t Queue.t; }
 60 | 
 61 |   let blocked =
 62 |     let blocked_make () =
 63 |       { mouse_button_up = Fmap.empty; ready = Queue.create () }
 64 |     in
 65 |     let blocked = Domain.DLS.new_key blocked_make in
 66 |     fun () -> Domain.DLS.get blocked
 67 | 
 68 |   let mouse_button_up () =
 69 |     let b = blocked () in
 70 |     let cell = ref (0, 0) in
 71 |     let block f = b.mouse_button_up <- Fmap.add f cell b.mouse_button_up in
 72 |     let cancel f = b.mouse_button_up <- Fmap.remove f b.mouse_button_up; true in
 73 |     let return _ = !cell in
 74 |     Fiber.block ~block ~cancel ~return
 75 | 
 76 |   let e = Sdl.Event.create ()
 77 |   let wait ~poll b =
 78 |     let handle_event b e = match Sdl.Event.(enum (get e typ)) with
 79 |     | `Mouse_button_up ->
 80 |         let loc = Sdl.Event.(get e mouse_button_x, get e mouse_button_y) in
 81 |         let unblock f cell = cell := loc; Queue.add f b.ready in
 82 |         Fmap.iter unblock b.mouse_button_up; b.mouse_button_up <- Fmap.empty;
 83 |         Queue.take_opt b.ready
 84 |     | _ -> None
 85 |     in
 86 |     match poll with
 87 |     | true -> if Sdl.poll_event (Some e) then handle_event b e else None
 88 |     | false ->
 89 |         match Sdl.wait_event (Some e) with
 90 |         | Ok () -> handle_event b e
 91 |         | Error (`Msg e) -> Sdl.log "Could not wait event: %s" e; None
 92 | 
 93 |   let unblock ~poll =
 94 |     let b = blocked () in
 95 |     match Queue.take_opt b.ready with
 96 |     | Some _ as f -> f
 97 |     | None -> wait ~poll b
 98 | end
 99 | 
100 | let pp_point ppf (x, y) = Format.fprintf ppf "(%d,%d)" x y
101 | 
102 | let of_mice_and_men () =
103 |   let wait_click () =
104 |     let loc = Fsdl.mouse_button_up () in
105 |     Sdl.log "Click: %a\n" pp_point loc
106 |   in
107 |   let twice () = wait_click (); Sdl.log "One more please!"; wait_click () in
108 |   Sdl.log "Please have a click!";
109 |   ignore (Fiber.async wait_click);
110 |   ignore (Fiber.async twice);
111 |   ()
112 | 
113 | let main () =
114 |   let run _w = Fiber.main ~unblock:Fsdl.unblock of_mice_and_men in
115 |   match Fsdl.with_window run with
116 |   | Error e -> Sdl.log "%s" e; exit 1
117 |   | Ok () -> exit 0
118 |   | exception Fiber.Cancelled  ->
119 |       Sdl.log "Of mice and men fiber cancelled"; exit 1
120 | 
121 | let () = if !Sys.interactive then () else main ()
122 | 


--------------------------------------------------------------------------------
/doc/design.mld:
--------------------------------------------------------------------------------
 1 | {0 Affect design notes}
 2 | 
 3 | {1 New design (october 2024)}
 4 | 
 5 | {ol
 6 | {- Only expose parallel asynchronous function calls with built-in
 7 |    priority hints and structured cooperative concurrency and cancellation.
 8 |    A {e fiber} is just a handle on such a call.}
 9 | 
10 | {- Negations.
11 | 
12 |    {ol
13 |    {- No distinction between parallelism and concurrency. That's not
14 |       something one wants to ponder at every asynchronous call. Doing so
15 |       is fine control over scheduling (see next point).}
16 | 
17 |    {- No fine grained control on scheduling. It's not
18 |       compositional. Just asynchronous function calls with three
19 |       priority hints and request for execution on the main (UI) thread.}
20 | 
21 |    {- No fiddling with domain/threads or pools thereof at the user level.
22 |       It's not compositional and you don't want to thread these arguments
23 |       in your libraries. Only the program's [main] function setups that.}
24 | 
25 |    {- No fiddling with fancy concurrency primitives or models. Only
26 |       a simple, fixed model, allows to reasonably think about how it
27 |       can be exploited compositionally. It becomes possible to understand
28 |       the exact consequences of using an asynchronous function call in
29 |       your library.}
30 |    {- No fancy dynamic ressource tracking in the fiber's scope. This
31 |       belongs to my type system and [Fun.protect]. It also keeps the
32 |       difference between synchronous and asynchronous function call
33 |       small, which in turn allows to sprinkle or retract asynchronous
34 |       calls in your code more easily.}}}
35 | 
36 | {- The model still leaves a lot of freedom to implement {e schedulers}
37 |    for it. A fixed model implies that it becomes possible for the
38 |    runtime and schedulers to optimize for it and for library authors
39 |    to correctly design with it.}
40 | 
41 | {- Cooperative structured cancellation. More natural [await]
42 |    (previously [join]) than the previous 2022 iteration of [Affect] which
43 |    only had structured cancellation topped with a franken-semi-cooperative
44 |    cancellation. Notably:
45 |    {ol
46 |    {-  A cancelled asynchronous function call can return partial results.}
47 |    {- No need to deal with {e maybe this was cancelled} when [await]ing.
48 |       Fibers no longer return [option]s.}
49 |    {- No need for the [finally] handler on fiber calls. This was needed because
50 |       if a fiber was cancelled before executing it would be denied any
51 |       execution. This is no longer the case. This alone show in my opinion
52 |       that the previous model was broken.}
53 |    {- Function calls in OCaml raise, thus it's natural for a parallel
54 |       asynchronous function call to raise too.}}}
55 | {- The {{!Fiber.concurrency_model}final model} feels just like a
56 |    rather natural extension of OCaml's functions calls. This is rather
57 |    pleasing in our functional programmer eyes.}}
58 | 
59 | The cooperative cancellation design was taken from the
60 | {{:https://docs.swift.org/swift-book/documentation/the-swift-programming-language/concurrency/}Swift concurrency model}. So was aswell the notion of
61 | priority (they have one more level though). The whole result is not far
62 | from what Swift
63 | propose except: we don't have [TaskGroup]s, it feels unecessary; we
64 | don't have detached tasks (this could easily be added); we don't have
65 | their "actors" which looks like their terminology for
66 | {{:https://en.wikipedia.org/wiki/Monitor_(synchronization)}monitors}.
67 | 
68 | One question that remains is if that model is not too costly for the
69 | OCaml runtime system for say mainly IO bound programs. Though
70 | given the flexibility of effects you could still elect to run for
71 | example one concurrency model per domain or simply on a single domain.
72 | 
73 | 
74 | {1:choices Choices}
75 | 
76 | {ol
77 |   {- Except forcing an await in the scheduler that throws out the results in
78 |      order to implement structured concurrency we don't do anything with
79 |      fibers that are not awaited when a fiber returns. We could:
80 |    {ol
81 |       {- Report errors, that is enforce an await all your asynchrounous calls
82 |          discipline.}
83 |       {- Do nothing on values but trap exceptions.}}
84 |    The first idea may make some pattern for speculative computing
85 |    more involved that they could be: just cancel
86 |    and forget, no need to await. The second idea it feels a bit
87 |    odd to make a difference between values and exceptions, I think
88 |    the stance should rather be either we disallow it or we don't care.
89 |    We could have a scheduler tracing mode that reports them but if
90 |    people start using as a design property (e.g. the forget mentioned)
91 |    it would a noisy signal.}}


--------------------------------------------------------------------------------
/src/unix/funix.mli:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | (** Fiber friendly {!Unix} functions.
  7 | 
  8 |     Clients of these functions need to be run in a {!Fiber.val-run}
  9 |     function called with {!Funix.val-unblock}. *)
 10 | 
 11 | (** {1:unblock Fiber unblocking} *)
 12 | 
 13 | val unblock : Fiber.unblock
 14 | (** [unblock] is the function to unblock fibers blocked by the function
 15 |     of this module. You must use this function with {!Fiber.val-run}. *)
 16 | 
 17 | (** {1:signals Signals} *)
 18 | 
 19 | (** Signals
 20 | 
 21 |     {b XXX.} Just providing a bracket for now. Do direct style waiting. *)
 22 | module Signal : sig
 23 |   type t = int
 24 |   (** The type for signal numbers. *)
 25 | 
 26 |   val set : t -> Sys.signal_behavior -> (Sys.signal_behavior, string) result
 27 |   (** [set s b] is like {!Sys.signal} but does not raise exceptions. *)
 28 | 
 29 |   val set_noerr : t -> Sys.signal_behavior -> unit
 30 |   (** [set_noerr s b] is like {!Sys.set_signal} but ignores any error.. *)
 31 | 
 32 |   val with' :
 33 |     t -> Sys.signal_behavior -> (unit -> 'a) -> ('a, string) result
 34 |   (** [with' s b f] sets [s] to [b], calls [f] and restore
 35 |       the signal to its initial behaviour, however [f] returns. This
 36 |       is [Error msg] if setting up the signal failed. *)
 37 | end
 38 | 
 39 | (** {1:sleep Sleeping} *)
 40 | 
 41 | val sleep_s : float -> unit
 42 | (** [sleep_s dur] suspends the fiber for [dur] seconds. *)
 43 | 
 44 | (** {1:io File descriptors operations}
 45 | 
 46 |     If the file descriptor is in {{!Unix.set_nonblock}non-blocking mode},
 47 |     these functions block the fiber, not the domain thread.  *)
 48 | 
 49 | val read : Unix.file_descr -> bytes -> start:int -> len:int -> bool
 50 | (** [read fd b ~start ~len] reads [len] bytes from [fd] into [b]
 51 |     starting at [start] and returns [true]. Returns [false] if
 52 |     [len] bytes could not be read (i.e. end of file/stream was
 53 |     hit). The function handles signal interruptions ([EINTR]) by
 54 |     retrying. *)
 55 | 
 56 | val write : Unix.file_descr -> bytes -> start:int -> len:int -> unit
 57 | (** [write fd b ~start ~len] writes [len] bytes starting at [start]
 58 |     from [b] on [fd]. The function handles signal interruptions
 59 |     ([EINTR]) by retrying. *)
 60 | 
 61 | val accept :
 62 |   ?cloexec:bool -> Unix.file_descr -> Unix.file_descr * Unix.sockaddr
 63 | (** [accept fd] is a fiber friendly {!Unix.accept} which returns file
 64 |     descriptors is in non-blocking mode. The function handles signal
 65 |     interruptions ([EINTR]) by retrying. *)
 66 | 
 67 | val connect : Unix.file_descr -> Unix.sockaddr -> unit
 68 | (** [connect fd addr] is a fiber friendly {!Unix.connect}. The function
 69 |     handles signal interruptions ([EINTR]) by retrying. *)
 70 | 
 71 | val close_noerr : Unix.file_descr -> unit
 72 | (** [close_noerr fd] closes [fd] and ignores any error. Useful for
 73 |     {!Fun.protect} [finally] functions which must not raise. *)
 74 | 
 75 | (** {1:endpoint Socket endpoints} *)
 76 | 
 77 | type endpoint =
 78 | [ `Host of string * int (** Hostname and port. *)
 79 | | `Sockaddr of Unix.sockaddr (** Given socket address. *)
 80 | | `Fd of Unix.file_descr (** Direct file descriptor. *) ]
 81 | (** The type for specifying a socket endpoint to connect to
 82 |     or to listen to on. *)
 83 | 
 84 | val endpoint_of_string :
 85 |   default_port:int -> string -> (endpoint, string) result
 86 | (** [connection_of_string ~default_port s] parses a connection
 87 |     specification from [s].  The format is [ADDR[:PORT]] or [PATH]
 88 |     for a Unix domain socket (detected by the the presence of
 89 |     a {{!Stdlib.Filename.dir_sep}directory separator}).
 90 |     [default_port] port is used if no [PORT] is specified. *)
 91 | 
 92 | val pp_endpoint : Format.formatter -> endpoint -> unit
 93 | (** [pp_socket_endpoint] formats an unspecified representation of endpoint
 94 |     values. *)
 95 | 
 96 | val socket_of_endpoint :
 97 |   endpoint -> Unix.socket_type ->
 98 |   (Unix.sockaddr option * Unix.file_descr * bool, string) result
 99 |   (** [socket_of_endpoint c] is [Ok (addr, fd, close)] with:
100 |       {ul
101 |       {- [addr], the address for the socket, if any.}
102 |       {- [fd], the file descriptor for the socket. If [c] is [`Fd fd]
103 |          this [fd] untouched. Otherwise [fd] is a new file descriptor set to
104 |          {{!Unix.set_nonblock}non-blocking mode} and has
105 |          {{!Unix.set_close_on_exec}close on exec} set to [true].}
106 |       {- [close] is [true] if the caller is in charge of closing it. This
107 |          is [false] iff [c] is [`Fd _].}} *)
108 | 


--------------------------------------------------------------------------------
/test/ping.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | (* Compile and run with:
  7 | 
  8 |    ocamlfind ocamlopt -package affect.unix -linkpkg -o ping ping.ml
  9 |    ./ping & ./ping & ./ping
 10 | 
 11 |    ping tries to connect to a pong server to ping it. If none exist it
 12 |    turns into a pong server.
 13 | 
 14 |    Both pings and the pong server do cancel fibers randomly to exercice
 15 |    a bit the cancel paths. They always restart on errors, so a ping may
 16 |    become a pong server if the latter dies. *)
 17 | 
 18 | let ( let* ) = Result.bind
 19 | 
 20 | let () = Random.self_init ()
 21 | let random_ansi_color () = (if Random.bool () then 40 else 100) + Random.int 8
 22 | let random_elt l = let n = List.length l in List.nth l (Random.int n)
 23 | let random_sleep_s ~min ~max = Funix.sleep_s (min +. Random.float (max -. min))
 24 | let random_true ~pct = Random.int 101 <= pct
 25 | 
 26 | let this_peer_uid = Printf.sprintf "\x1b[%dm \x1b[0m" (random_ansi_color ())
 27 | let log fmt = Format.printf ("%s " ^^ fmt ^^ "@.") this_peer_uid
 28 | 
 29 | (* Ping client *)
 30 | 
 31 | let random_self_cancel ~pct =
 32 |   if not (random_true ~pct) then () else
 33 |   (log "Randomly self cancelling"; Fiber.self_cancel (); raise Fiber.Cancelled)
 34 | 
 35 | let ping_self_cancel_pct = 2
 36 | 
 37 | let ping endpoint ~max_ping_period =
 38 |   let closed ~peer_uid = log "          %s closed by pong server" peer_uid in
 39 |   let rec ping_loop ~peer_uid peer =
 40 |     let* sent = Netmsg.send peer this_peer_uid in
 41 |     if not sent then Ok (closed ~peer_uid) else
 42 |     let () = random_self_cancel ~pct:ping_self_cancel_pct in
 43 |     let* msg = Netmsg.recv peer in
 44 |     match msg with
 45 |     | None -> Ok (closed ~peer_uid)
 46 |     | Some peer_uid ->
 47 |         let () = random_self_cancel ~pct:ping_self_cancel_pct in
 48 |         let d = Random.float max_ping_period in
 49 |         log "pong from %s next ping in %.02fs" peer_uid d;
 50 |         Funix.sleep_s d;
 51 |         ping_loop ~peer_uid peer
 52 |   in
 53 |   let* peer = Netmsg.connect ~endpoint in
 54 |   match peer with
 55 |   | None -> Ok false (* did not ping *)
 56 |   | Some peer ->
 57 |       let finally () = Netmsg.close peer in
 58 |       Fun.protect ~finally @@ fun () ->
 59 |       log "Connected to pong server";
 60 |       let* () = try ping_loop ~peer_uid:"" (* none *) peer with
 61 |       | Fiber.Cancelled -> Ok ()
 62 |       in
 63 |       Ok true (* did ping *)
 64 | 
 65 | (* Pong server *)
 66 | 
 67 | let pong peer =
 68 |   let finally () = Netmsg.close peer in
 69 |   Fun.protect ~finally @@ fun () ->
 70 |   let plog peer_uid fmt = log ("ping      %s " ^^ fmt) peer_uid in
 71 |   let peer_closed ~peer_uid = plog peer_uid "closed" in
 72 |   let peer_error ~peer_uid e = plog peer_uid "error: %s" e in
 73 |   let jitter_response () = Funix.sleep_s (Random.float 0.3) in
 74 |   let rec pong_loop ~peer_uid peer =
 75 |     Fiber.self_check_cancellation ();
 76 |     match Netmsg.recv peer with
 77 |     | Error e -> peer_error ~peer_uid e
 78 |     | Ok None -> peer_closed ~peer_uid
 79 |     | Ok Some peer_uid ->
 80 |         log "ping from %s" peer_uid;
 81 |         jitter_response ();
 82 |         match Netmsg.send peer this_peer_uid with
 83 |         | Error e -> peer_error ~peer_uid e
 84 |         | Ok false -> peer_closed ~peer_uid
 85 |         | Ok true -> pong_loop ~peer_uid peer
 86 |   in
 87 |   try pong_loop ~peer_uid:"?" peer with
 88 |   | Fiber.Cancelled -> ()
 89 | 
 90 | let pong_server endpoint =
 91 |   let reap_terminated f = match Fiber.poll f with
 92 |   | None -> Some f | Some _ -> None
 93 |   in
 94 |   let rec random_close_peer peers =
 95 |     (* if fs = [] then Fiber.await_cancelled ();  TODO *)
 96 |     random_sleep_s ~min:3. ~max:5.;
 97 |     if peers = [] || random_true ~pct:40
 98 |     then random_close_peer peers else
 99 |     (log "Randomly closing a peer"; Fiber.cancel (random_elt peers))
100 |   in
101 |   let new_listen l =
102 |     let* peer = Netmsg.listen l in
103 |     if Fiber.self_is_cancelled ()
104 |     then (Netmsg.close peer; raise Fiber.Cancelled)
105 |     else Ok peer
106 |   in
107 |   let rec server_loop l peers =
108 |     let peers = List.filter_map reap_terminated peers in
109 |     let random_abort = Fiber.async @@ fun () -> random_close_peer peers in
110 |     let new_ping = Fiber.async @@ fun () -> new_listen l in
111 |     match Fiber.pick_either random_abort new_ping with
112 |     | exception Fiber.Cancelled -> server_loop l peers
113 |     | Either.Left () -> server_loop l peers
114 |     | Either.Right (Error _ as e) -> e
115 |     | Either.Right (Ok peer) ->
116 |         log "New ping";
117 |         server_loop l (Fiber.async (fun () -> pong peer) :: peers)
118 |   in
119 |   let* l = Netmsg.listener ~endpoint () in
120 |   let finally () = Netmsg.close_listener l in
121 |   Fun.protect ~finally @@ fun () ->
122 |   log "Waiting for pings…";
123 |   server_loop l []
124 | 
125 | (* Ping pong *)
126 | 
127 | let rec ping_or_pong endpoint ~max_ping_period =
128 |   Result.join @@ Funix.Signal.with' Sys.sigpipe Sys.Signal_ignore @@ fun () ->
129 |   log "Contacting pong server on %a" Funix.pp_endpoint endpoint;
130 |   let* did_ping = ping endpoint ~max_ping_period in
131 |   if did_ping then Ok () else
132 |   (log "Could not connect, will pong instead."; pong_server endpoint)
133 | 
134 | let main () =
135 |   Fiber.main ~unblock:Funix.unblock @@ fun () ->
136 |   let endpoint = `Host ("localhost", 10101) in
137 |   let relax () = random_sleep_s ~min:0.1 ~max:0.5 in
138 |   let rec loop () = match ping_or_pong endpoint ~max_ping_period:1.5 with
139 |   | Ok () -> relax (); loop ()
140 |   | Error e -> log "Error: %s" e; relax (); loop ()
141 |   in
142 |   loop ()
143 | 
144 | let () = if !Sys.interactive then () else exit (main ())
145 | 


--------------------------------------------------------------------------------
/test/test_fiber.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | open B0_testing
  7 | 
  8 | let log fmt = Test.log ("%a " ^^ fmt) Fiber.Handle.pp (Fiber.Handle.self ())
  9 | let unblock = Fiber.never_unblock
 10 | 
 11 | let fail_may_hang f = f () (* TODO timeout these *)
 12 | 
 13 | let rand = Test.Rand.state ()
 14 | let flip () = Random.State.bool rand
 15 | 
 16 | (* Functions with yield jitter and tracing *)
 17 | 
 18 | let may_yield () = if flip () then Fiber.yield ()
 19 | let async_val v = (* asyncs value [v] with yield jitter *)
 20 |   let f = Fiber.async @@ fun () -> may_yield (); v in
 21 |   may_yield (); f
 22 | 
 23 | let traced_may_yield () = if flip () then (log "Yielding"; Fiber.yield ())
 24 | let traced_async_val v =
 25 |   let f = Fiber.async @@ fun () -> traced_may_yield (); log "Done!"; v in
 26 |   log "Called %a" Fiber.pp f; traced_may_yield (); f
 27 | 
 28 | let traced_await pp f =
 29 |   log "Awaiting %a" (Fiber.pp' Test.Fmt.text_string) f;
 30 |   let v = Fiber.await f in
 31 |   log "Got %a" (Fiber.pp' pp) f; v
 32 | 
 33 | (* Tests *)
 34 | 
 35 | let test_basic_scheduling () =
 36 |   Test.test "basic scheduling" @@ fun () ->
 37 |   Fiber.main ~unblock @@ fun () ->
 38 |   log "I'm the main here";
 39 |   let msgs = ["Hey"; "ho,"; "let's go!"] in
 40 |   let fs = List.map traced_async_val msgs in
 41 |   let vs = List.map (traced_await Test.Fmt.text_string) fs in
 42 |   Test.(list ~elt:Eq.string) msgs vs ~__POS__;
 43 |   ()
 44 | 
 45 | let test_async_await () =
 46 |   Test.test "Fiber.{async,await}" @@ fun () ->
 47 |   Fiber.main ~unblock @@ fun () ->
 48 |   let f0 () = true in
 49 |   let f1 () = raise Exit in
 50 |   Test.bool (Fiber.await (Fiber.async f0)) true ~__POS__;
 51 |   Test.raises Exit (fun () -> Fiber.await (Fiber.async f1)) ~__POS__;
 52 |   ()
 53 | 
 54 | let test_fibers_are_structured () =
 55 |   Test.test "fibers are structured, wait for fibers" @@ fun () ->
 56 |   Fiber.main ~unblock @@ fun () ->
 57 |   let f0_returned = ref false in
 58 |   let f1_returned = ref false in
 59 |   let f0 () = Fiber.yield (); f0_returned := true in
 60 |   let f1 () = Fiber.yield (); f1_returned := true; raise Exit in
 61 |   let f2 () =
 62 |     let a, b = if flip () then f0, f1 else f1, f0 in
 63 |     ignore (Fiber.async a); ignore (Fiber.async b);
 64 |   in
 65 |   Fiber.await (Fiber.async f2);
 66 |   Test.holds !f0_returned ~__POS__;
 67 |   Test.holds !f1_returned ~__POS__;
 68 |   ()
 69 | 
 70 | let test_fiber_cancellation_is_structured () =
 71 |   Test.test "fibers cancellation is structured" @@
 72 |   fail_may_hang @@ fun () ->
 73 |   fun () ->
 74 |   Fiber.main ~unblock @@ fun () ->
 75 |   let f0 () = while not (Fiber.self_is_cancelled ()) do Fiber.yield () done in
 76 |   let f1 () = Fiber.await (Fiber.async f0) in
 77 |   let f2 () =
 78 |     let a0 = Fiber.async f1 in
 79 |     Fiber.self_cancel ();
 80 |     let a1 = Fiber.async f1 (* New fibers should be cancelled *) in
 81 |     ignore (Fiber.await a0);
 82 |     ignore (Fiber.await a1);
 83 |   in
 84 |   Fiber.await (Fiber.async f2);
 85 |   ()
 86 | 
 87 | let test_main_is_structured () =
 88 |   Test.test "main is structured, waits for fibers" @@ fun () ->
 89 |   let f0_returned = ref false in
 90 |   let f1_returned = ref false in
 91 |   begin Fiber.main ~unblock @@ fun () ->
 92 |     let f0 () = Fiber.yield (); f0_returned := true in
 93 |     let f1 () = Fiber.yield (); f1_returned := true; raise Exit in
 94 |     let a, b = if flip () then f0, f1 else f1, f0 in
 95 |     ignore (Fiber.async a); ignore (Fiber.async b);
 96 |   end;
 97 |   Test.holds !f0_returned ~__POS__;
 98 |   Test.holds !f1_returned ~__POS__;
 99 |   ()
100 | 
101 | let test_main_cancellation_is_structured () =
102 |   Test.test "main cancellation is structured" @@ fun () ->
103 |   fail_may_hang @@ fun () ->
104 |   Fiber.main ~unblock @@ fun () ->
105 |   let f0 () = while not (Fiber.self_is_cancelled ()) do Fiber.yield () done in
106 |   let f1 () = Fiber.await (Fiber.async f0) in
107 |   let a0 = Fiber.async f1 in
108 |   Fiber.self_cancel ();
109 |   let a1 = Fiber.async f1 (* New fibers should be cancelled *) in
110 |   ignore (Fiber.await a0);
111 |   ignore (Fiber.await a1);
112 |   ()
113 | 
114 | let test_main_no_async_calls () =
115 |   Test.test "main makes no async calls" @@ fun () ->
116 |   Test.holds (Fiber.main ~unblock @@ fun () -> true) ~__POS__;
117 |   Test.holds (Fiber.main ~unblock @@ fun () -> Fiber.yield (); true) ~__POS__;
118 |   ()
119 | 
120 | let test_await_all () =
121 |   Test.test "Fiber.await_all" @@ fun () ->
122 |   Fiber.main ~unblock @@ fun () ->
123 |   let async v =
124 |     let af = Fiber.async @@ fun () -> if flip () then Fiber.yield (); v in
125 |     if flip () then Fiber.yield (); af
126 |   in
127 |   let is = [1; 2; 3; 4] in
128 |   let fs = List.map async is in
129 |   let vs = Fiber.await_all fs in
130 |   Test.(list ~elt:Eq.int) is vs ~__POS__;
131 |   ()
132 | 
133 | let test_await_first () =
134 |   Test.test "Fiber.await_first" @@ fun () ->
135 |   Fiber.main ~unblock @@ fun () ->
136 |   let is = [1; 2; 3; 4] in
137 |   let fs = List.map async_val is in
138 |   let rec collect acc = function
139 |   | [] -> List.sort Int.compare acc
140 |   | fs ->
141 |       let v, fs = Fiber.await_first fs in
142 |       collect (v :: acc) fs
143 |   in
144 |   let vs = collect [] fs in
145 |   Test.(list ~elt:Eq.int) is vs ~__POS__;
146 |   ()
147 | 
148 | let test_pick_either () =
149 |   Test.test "Fiber.pick_either" @@ fun () ->
150 |   fail_may_hang @@ fun () ->
151 |   Fiber.main ~unblock @@ fun () ->
152 |   begin
153 |     let f () = for i = 0 to 4 do Fiber.yield () done in
154 |     let g () = while not (Fiber.self_is_cancelled ()) do Fiber.yield () done in
155 |     let f = Fiber.async f in
156 |     let g = Fiber.async g in
157 |     let a, b = if flip () then f, g else g, f in
158 |     match Fiber.pick_either a b with
159 |     | Either.Left () -> Test.holds (Fiber.cancelled b) ~__POS__
160 |     | Either.Right () -> Test.holds (Fiber.cancelled a) ~__POS__
161 |   end;
162 |   begin
163 |     (* Ignore Fiber.Cancelled *)
164 |     let f () = raise Fiber.Cancelled in
165 |     let g () = for i = 0 to 4 do Fiber.yield () done; true in
166 |     let f = Fiber.async f in
167 |     let g = Fiber.async g in
168 |     let a, b = if flip () then f, g else g, f in
169 |     match Fiber.pick_either a b with
170 |     | Either.Left v -> Test.holds v ~__POS__
171 |     | Either.Right v -> Test.holds v ~__POS__
172 |   end;
173 |   ()
174 | 
175 | let test_block () =
176 |   Test.test "block" @@ fun () ->
177 |   let unblock, block =
178 |     let q = Queue.create () in
179 |     let m = Mutex.create () in
180 |     let unblock ~poll = Mutex.protect m @@ fun () -> Queue.take_opt q in
181 |     let add_block f = Mutex.protect m @@ fun () -> Queue.add f q in
182 |     unblock, add_block
183 |   in
184 |   let my_yield () =
185 |     let block = block and cancel _ = false and return _ = () in
186 |     Fiber.block ~block ~cancel ~return
187 |   in
188 |   Fiber.main ~unblock @@ fun () ->
189 |   let f () = my_yield () in
190 |   let f0 = Fiber.async f in
191 |   let f1 = Fiber.async f in
192 |   my_yield ();
193 |   Fiber.await f0;
194 |   Fiber.await f1;
195 |   ()
196 | 
197 | let main () =
198 |   Test.main @@ fun () ->
199 |   test_basic_scheduling ();
200 |   test_async_await ();
201 |   test_fibers_are_structured ();
202 |   test_fiber_cancellation_is_structured ();
203 |   test_main_is_structured ();
204 |   test_main_cancellation_is_structured ();
205 |   test_main_no_async_calls ();
206 |   test_await_all ();
207 |   test_await_first ();
208 |   test_pick_either ();
209 |   test_block ();
210 |   ()
211 | 
212 | let () = if !Sys.interactive then () else exit (main ())
213 | 


--------------------------------------------------------------------------------
/src/unix/funix.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | let uerror e = Unix.error_message e
  7 | let pp_fd ppf fd = Format.pp_print_int ppf (Obj.magic fd : int)
  8 | let debug fmt = Format.eprintf (fmt ^^ "@.")
  9 | let errorf fmt = Format.kasprintf (fun s -> Error s) fmt
 10 | let string_subrange ?(first = 0) ?last s =
 11 |   let max = String.length s - 1 in
 12 |   let last = match last with
 13 |   | None -> max
 14 |   | Some l when l > max -> max
 15 |   | Some l -> l
 16 |   in
 17 |   let first = if first < 0 then 0 else first in
 18 |   if first > last then "" else
 19 |   String.sub s first (last - first + 1)
 20 | 
 21 | module Signal = struct
 22 |   type t = int
 23 | 
 24 |   let set s b = match Sys.signal s b with
 25 |   | b -> Ok b | exception Sys_error e -> Error e
 26 | 
 27 |   let set_noerr s b = try Sys.set_signal s b with Sys_error _ -> ()
 28 | 
 29 |   let with' s b f = match set s b with
 30 |   | Error _ as e -> e
 31 |   | Ok old_b ->
 32 |       let finally () = set_noerr s old_b in
 33 |       Ok (Fun.protect ~finally f)
 34 | end
 35 | 
 36 | (* Sleeping *)
 37 | 
 38 | module Sleep = struct
 39 | 
 40 |   (* Time, using monotonic time would be better here but let's just
 41 |      rely on Unix. Mtime_clock.now should be added to Unix. *)
 42 | 
 43 |   type time_s = float (* absolute time *)
 44 |   let time_now_s () = Unix.gettimeofday ()
 45 |   let is_earlier t ~than = Float.compare t than < 0
 46 | 
 47 |   (* Sleeps *)
 48 | 
 49 |   type t = { until : time_s; mutable fiber : Fiber.Handle.t option }
 50 |   let forever = { until = max_float; fiber = None }
 51 |   let for' ~dur_s fiber = { until = time_now_s () +. dur_s; fiber}
 52 | 
 53 |   (* Heap priority queue, classical imperative implementation. *)
 54 | 
 55 |   let heap_compare h i i' = Float.compare h.(i).until h.(i').until
 56 |   let heap_swap h i i' = let v = h.(i) in h.(i) <- h.(i'); h.(i') <- v
 57 | 
 58 |   let rec heap_up h i =
 59 |     if i = 0 then () else
 60 |     let p = (i - 1) / 2 in (* parent index. *)
 61 |     if heap_compare h i p < 0 then (heap_swap h i p; heap_up h p)
 62 | 
 63 |   let rec heap_down h max i =
 64 |     let start = 2 * i in
 65 |     let l = start + 1 in (* left child index. *)
 66 |     let r = start + 2 in (* right child index. *)
 67 |     if l > max then () (* no child, stop *) else (* find smallest child k. *)
 68 |     let k = if r > max then l else (if heap_compare h l r < 0 then l else r) in
 69 |     if heap_compare h i k > 0 then (heap_swap h i k; heap_down h max k)
 70 | 
 71 |   type heap =
 72 |     { mutable sleeps : t array; (* Heap priority queue for sleeps. *)
 73 |       mutable max : int (* Index of last element of [sleeps]. *) }
 74 | 
 75 |   let heap_array () = Array.make 256 forever
 76 |   let heap () = { sleeps = heap_array (); max = -1 }
 77 |   let shrink_threshold = 262144
 78 |   let shrink h = (* assert (s.max < 0). *)
 79 |     if Array.length h.sleeps < shrink_threshold then () else
 80 |     h.sleeps <- heap_array ()
 81 | 
 82 |   let grow h =
 83 |     let len = h.max + 1 in
 84 |     let els' = Array.make (2 * len) forever in
 85 |     Array.blit h.sleeps 0 els' 0 len; h.sleeps <- els'
 86 | 
 87 |   let add h s =
 88 |     let max = h.max + 1 in
 89 |     if max = Array.length h.sleeps then grow h;
 90 |     h.max <- max;
 91 |     h.sleeps.(h.max) <- s; heap_up h.sleeps h.max
 92 | 
 93 |   let pop h =
 94 |     let last = h.sleeps.(h.max) in
 95 |     h.sleeps.(h.max) <- forever;
 96 |     h.max <- h.max - 1;
 97 |     if h.max < 0 then shrink h else
 98 |     (h.sleeps.(0) <- last; heap_down h.sleeps h.max 0)
 99 | 
100 |   let dur_s_to_next_wakeup h =
101 |     let rec loop h now =
102 |       if h.max < 0 then None else
103 |       if h.sleeps.(0).fiber = None then (pop h; loop h now) else
104 |       let until = h.sleeps.(0).until in
105 |       let late = is_earlier until ~than:now in
106 |       Some (if late then 0. else (until -. now))
107 |     in
108 |     loop h (time_now_s ())
109 | 
110 |   let wakeup h =
111 |     let rec loop h now =
112 |       if h.max < 0 then None else
113 |       if h.sleeps.(0).fiber = None then (pop h; loop h now) else
114 |       let until = h.sleeps.(0).until in
115 |       if not (is_earlier until ~than:now) then None else
116 |       let fiber = h.sleeps.(0).fiber in
117 |       pop h; fiber
118 |     in
119 |     loop h (time_now_s ())
120 | end
121 | 
122 | (* Per domain blocking data structure
123 | 
124 |    TODO this was done for the previous affect design
125 |    it will need to be rethought for a multicore scheduler.
126 | *)
127 | 
128 | module Fmap = Map.Make (Fiber.Handle)
129 | type blocked =
130 |   { mutable read : Unix.file_descr Fmap.t;
131 |     mutable write : Unix.file_descr Fmap.t;
132 |     unblocked : Fiber.Handle.t Queue.t;
133 |     sleeps : Sleep.heap; }
134 | 
135 | let blocked =
136 |   let blocked_make () =
137 |     { read = Fmap.empty; write = Fmap.empty;
138 |       unblocked = Queue.create (); sleeps = Sleep.heap ();  }
139 |   in
140 |   let blocked = Domain.DLS.new_key blocked_make in
141 |   fun () -> Domain.DLS.get blocked
142 | 
143 | (* Blocking and unblocking *)
144 | 
145 | let block_read fd =
146 |   let b = blocked () in
147 |   let block fd f = b.read <- Fmap.add f fd b.read in
148 |   let cancel f =
149 |     if Fmap.mem f b.read then (b.read <- Fmap.remove f b.read; true) else
150 |     false (* TODO read done, we would have to remove it from queue. *)
151 |   in
152 |   let return _ = () in
153 |   Fiber.block ~block:(block fd) ~cancel ~return
154 | 
155 | let block_write fd =
156 |   let b = blocked () in
157 |   let block fd f = b.write <- Fmap.add f fd b.write in
158 |   let cancel f =
159 |     if Fmap.mem f b.write then (b.write <- Fmap.remove f b.write; true) else
160 |     false (* TODO write done, we would have to remove it from unblocked. *)
161 |   in
162 |   let return _ = () in
163 |   Fiber.block ~block:(block fd) ~cancel ~return
164 | 
165 | let sleep_s dur_s =
166 |   (*  TODO a bit ugly *)
167 |   let b = blocked () in
168 |   let s = Sleep.for' ~dur_s None in
169 |   let block f = s.Sleep.fiber <- Some f; Sleep.add b.sleeps s in
170 |   let cancel f = s.Sleep.fiber <- None; true in
171 |   let return _ = ()  in
172 |   Fiber.block ~block ~cancel ~return
173 | 
174 | let wait ~poll b =
175 |   let timeout =
176 |     if poll then 0. else match Sleep.dur_s_to_next_wakeup b.sleeps with
177 |     | None -> -1.
178 |     | Some dur_s -> dur_s
179 |   in
180 |   let add_fd f fd acc = fd :: acc in
181 |   let rset = Fmap.fold add_fd b.read [] in
182 |   let wset = Fmap.fold add_fd b.write [] in
183 |   if rset = [] && wset = [] && timeout <= 0. then Sleep.wakeup b.sleeps else
184 |   match Unix.select rset wset [] timeout with
185 |   | exception Unix.(Unix_error (EINTR, _, _)) -> None
186 |   | rset, wset, _ ->
187 |       if rset = [] && wset = [] then Sleep.wakeup b.sleeps else
188 |       let upd xset f fd = match List.mem fd xset with
189 |       | true -> Queue.add f b.unblocked; None | false -> Some fd
190 |       in
191 |       (if rset <> [] then b.read <- Fmap.filter_map (upd rset) b.read);
192 |       (if wset <> [] then b.write <- Fmap.filter_map (upd wset) b.write);
193 |       Queue.take_opt b.unblocked
194 | 
195 | let unblock ~poll =
196 |   let b = blocked () in
197 |   match Queue.take_opt b.unblocked with
198 |   | Some _ as f -> f
199 |   | None ->
200 |       match Sleep.wakeup b.sleeps with
201 |       | Some _ as f -> f
202 |       | None -> wait ~poll b
203 | 
204 | (* File descriptor operations *)
205 | 
206 | let rec read fd b ~start ~len = match Unix.read fd b start len with
207 | | exception Unix.(Unix_error (EINTR, _, _)) -> read fd b ~start ~len
208 | | exception Unix.(Unix_error ((EWOULDBLOCK | EAGAIN), _, _)) ->
209 |     block_read fd; read fd b ~start ~len
210 | | 0 when len <> 0 -> false
211 | | c when c < len -> read fd b ~start:(start + c) ~len:(len - c)
212 | | _ -> true
213 | 
214 | let rec write fd b ~start ~len = match Unix.single_write fd b start len with
215 | | exception Unix.(Unix_error (EINTR, _, _)) -> write fd b ~start ~len
216 | | exception Unix.(Unix_error ((EWOULDBLOCK | EAGAIN), _, _)) ->
217 |     block_write fd; write fd b ~start ~len
218 | | c when c < len -> write fd b ~start:(start + c) ~len:(len - c)
219 | | _ -> ()
220 | 
221 | let rec accept ?cloexec fd = match Unix.accept ?cloexec fd with
222 | | (fd, _ as ret) -> Unix.set_nonblock fd; ret
223 | | exception Unix.(Unix_error (EINTR, _, _)) -> accept ?cloexec fd
224 | | exception Unix.(Unix_error ((EWOULDBLOCK | EAGAIN), _, _)) ->
225 |     block_read fd; accept ?cloexec fd
226 | 
227 | let rec connect fd addr = match Unix.connect fd addr with
228 | | () -> ()
229 | | exception Unix.(Unix_error (EINTR, _, _)) -> connect fd addr
230 | | exception Unix.(Unix_error (EINPROGRESS, _, _)) ->
231 |     block_write fd;
232 |     match Unix.getsockopt_error fd with
233 |     | None -> ()
234 |     | Some error -> raise (Unix.Unix_error (error, "connect", ""))
235 | 
236 | let close_noerr fd =
237 |   (* XXX should we remove the fd from reads and writes ?
238 |      It can gives obscure EBADF on select but then it means you
239 |      are still operating on the fd. So it will result in infinite block
240 |      somewhere *)
241 |   try Unix.close fd with Unix.Unix_error _ -> ()
242 | 
243 | (* Socket endpoints *)
244 | 
245 | type endpoint =
246 | [ `Host of string * int
247 | | `Sockaddr of Unix.sockaddr
248 | | `Fd of Unix.file_descr ]
249 | 
250 | let endpoint_of_string ~default_port s =
251 |   match String.contains s Filename.dir_sep.[0] with
252 |   | true -> Ok (`Sockaddr (Unix.ADDR_UNIX s))
253 |   | false ->
254 |       match String.rindex_opt s ':' with
255 |       | None -> Ok (`Host (s, default_port))
256 |       | Some i ->
257 |           match String.index_from_opt s i ']' with (* beware IPv6 *)
258 |           | Some _ -> Ok (`Host (s, default_port))
259 |           | None ->
260 |               let h = string_subrange ~last:(i - 1) s in
261 |               let p = string_subrange ~first:(i + 1) s in
262 |               match int_of_string_opt p with
263 |               | None -> errorf "port %S not an integer" p
264 |               | Some p -> Ok (`Host (h, p))
265 | 
266 | let pp_endpoint ppf ep =
267 |   let pp_name_port ppf (n, p) = Format.fprintf ppf "%s:%d" n p in
268 |   match ep with
269 |   | `Host (n, p) -> pp_name_port ppf (n, p)
270 |   | `Fd _fd -> Format.fprintf ppf "<fd>"
271 |   | `Sockaddr (Unix.ADDR_UNIX s) -> Format.pp_print_string ppf s
272 |   | `Sockaddr (Unix.ADDR_INET (a, p)) ->
273 |       pp_name_port ppf (Unix.string_of_inet_addr a, p)
274 | 
275 | let rec socket_of_endpoint ep stype = match ep with
276 | | `Fd fd -> Ok (None, fd, false)
277 | | `Host (name, port) ->
278 |     begin match Unix.gethostbyname name with
279 |     | exception Not_found -> errorf "%s: host not found" name
280 |     | h ->
281 |         let c = `Sockaddr (Unix.ADDR_INET (h.h_addr_list.(0), port)) in
282 |         socket_of_endpoint c stype
283 |     end
284 | | `Sockaddr addr ->
285 |     let domain = Unix.domain_of_sockaddr addr in
286 |     match Unix.socket ~cloexec:true domain stype 0 with
287 |     | exception Unix.Unix_error (e, _, _) -> Error (uerror e)
288 |     | fd ->
289 |         match Unix.set_nonblock fd with
290 |         | exception Unix.Unix_error (e, _, _) ->
291 |             close_noerr fd; Error (uerror e)
292 |         | () -> Ok (Some addr, fd, true)
293 | 


--------------------------------------------------------------------------------
/src/fiber.mli:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2024 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | (** Parallel asynchronous function calls.
  7 | 
  8 |     Read the short {{!concurrency_model}concurrency model}. *)
  9 | 
 10 | (** {1:fibers Fibers} *)
 11 | 
 12 | (** Fiber unique identifiers. *)
 13 | module Id : sig
 14 |   type t = int
 15 |   (** The type for fiber unique identifiers. *)
 16 | 
 17 |   val nil : t
 18 |   (** [nil] is an identifier that will never be attributed to a fiber. *)
 19 | 
 20 |   val equal : t -> t -> bool
 21 |   (** [equal] tests identifiers for equality. *)
 22 | 
 23 |   val compare : t -> t -> int
 24 |   (** [compare] is a total order on identifiers compatible with
 25 |       {!equal}.  *)
 26 | 
 27 |   val pp : Format.formatter -> t -> unit
 28 |   (** [pp] formats fiber identifiers. *)
 29 | end
 30 | 
 31 | type priority =
 32 | | Low (** Background computation. *)
 33 | | Normal (** Normal computation. *)
 34 | | High (** Urgent or interactive computation. *)
 35 | (** The type for fiber priorities. *)
 36 | 
 37 | type 'a t
 38 | (** The type for fibers. An asynchronous function call
 39 |     returning a value of type ['a]. *)
 40 | 
 41 | val async : ?only_main:bool -> ?priority:priority -> (unit -> 'a) -> 'a t
 42 | (** [async f] is a fiber executing function [f] in parallel to the
 43 |     caller. The caller scope will not return or raise before [f]
 44 |     returns or raises. [priority] is the execution priority, it
 45 |     defaults to the caller's priority. If [only_main] is [true], the
 46 |     scheduler ensure that the function only gets excecuted on the main
 47 |     thread (defaults to [false]).*)
 48 | 
 49 | val from_val : 'a -> 'a t
 50 | (** [from_val v] is [async (Fun.const v)]. *)
 51 | 
 52 | val yield : unit -> unit
 53 | (** [yield ()] cooperatively suspends the executing fiber.  *)
 54 | 
 55 | (** {1:awaiting Awaiting}
 56 | 
 57 |     {b Note.} Awaiting on fibers can always raise. If you want to guard
 58 |     against this, use the {{!trapping_exn}trapping combinators}
 59 |     before awaiting them. *)
 60 | 
 61 | val await : 'a t -> 'a
 62 | (** [await f] blocks until the asynchronous function of [f] returns or
 63 |     raises. *)
 64 | 
 65 | val await_all : 'a t list -> 'a list
 66 | (** [await_all fs] blocks until {e all} [fs] return or raise. Raises the
 67 |     leftmost exception if one of the fiber raises (including {!Cancelled}). *)
 68 | 
 69 | val await_first : 'a t list -> 'a * 'a t list
 70 | (** [await_first fs] awaits the first, leftmost, [fs]
 71 |     that returns or raises (including {!Cancelled}). The returned list (if any)
 72 |     is [fs], in the same order, without the fiber that returned. Raises
 73 |     [Invalid_argument] if the list is empty. *)
 74 | 
 75 | val await_either : 'a t -> 'b t -> ('a, 'b) Either.t
 76 | (** [await_either f0 f1] awaits the first, leftmost, fiber that returns or
 77 |     raises (including {!Cancelled}). *)
 78 | 
 79 | val poll : 'a t -> 'a option
 80 | (** [poll f] is [None] if [f] is still running and it's return value or raise
 81 |     otherwise. *)
 82 | 
 83 | (** {2:picking Picking}
 84 | 
 85 |     Picking is for selecting among competing computations. *)
 86 | 
 87 | val pick_first : 'a t list -> 'a
 88 | (** [pick_first fs] awaits the first of [fs] that returns or raises a
 89 |     non {!Cancelled} exception and {!cancel}s the other ones. Raises
 90 |     [Invalid_argument] if the list empty. *)
 91 | 
 92 | val pick_either : 'a t -> 'b t -> ('a, 'b) Either.t
 93 | (** [pick_either f0 f1] awaits the first, lefmost, of [f0] and [f1] that returns
 94 |     or raises a non {!Cancelled} exception and {!cancel}s the other one. *)
 95 | 
 96 | (** {1:canceling Cancelling} *)
 97 | 
 98 | exception Cancelled
 99 | (** Exception thrown to indicate that a fiber is cancelled. *)
100 | 
101 | val cancel : 'a t -> unit
102 | (** [cancel f] marks the fiber [f] and its current and future asynchronous
103 |     function calls as being cancelled. If [f] already returned this has no
104 |     effect. *)
105 | 
106 | val self_cancel : unit -> unit
107 | (** [self_cancel ()] cancels the executing fiber. *)
108 | 
109 | val self_is_cancelled : unit -> bool
110 | (** [self_is_cancelled ()] is [true] if the excecuting fiber is cancelled. *)
111 | 
112 | val self_check_cancellation : unit -> unit
113 | (** [self_check_cancellation] raises {!Cancelled} if
114 |     [self_is_cancelled ()] is [true]. *)
115 | 
116 | (** {1:trapping_exn Trapping exceptions}
117 | 
118 |     A few conveniences to protect from raising fibers. Avoids
119 |     multiplying the number of [await] functions. *)
120 | 
121 | val trap_user_exn : 'a t -> ('a, exn * Printexc.raw_backtrace) result t
122 | (** [trap_user_exn f] is [f] but turns any exception
123 |     except {!Cancelled},  {!Stack_overflow}, {!Out_of_memory} or
124 |     {!Sys.Break} into [Error _]. *)
125 | 
126 | val trap_cancelled : 'a t -> 'a option t
127 | (** [trap_cancelled f] is [f] but turns a {!Cancelled} exception into an
128 |     option. *)
129 | 
130 | val trap_any_exn : 'a t -> ('a option, exn * Printexc.raw_backtrace) result t
131 | (** [trap_any_exn] is [f] but turns a {!Cancelled} exception into [None] and any
132 |     other exception except {!Stack_overflow}, {!Out_of_memory}, {!Sys.Break},
133 |     into [Error _]. *)
134 | 
135 | (** {1:props Properties} *)
136 | 
137 | val id : 'a t -> Id.t
138 | (** [id f] is the unique identifier of [f]. *)
139 | 
140 | val priority : 'a t -> priority
141 | (** [priority f] is the priority of [f]. *)
142 | 
143 | val cancelled : 'a t -> bool
144 | (** [cancelled f] is [true] iff [f] is marked as cancelled. *)
145 | 
146 | (** Existential fibers *)
147 | module Handle : sig
148 | 
149 |   type 'a fiber := 'a t
150 | 
151 |   type t (* = V : 'a fiber -> t [@@unboxed] (* FIXME doesn't work. *) *)
152 |   (** The type for exisential fibers. This is {!Fiber.t} with
153 |       the ['a] hidden. *)
154 | 
155 |   val self : unit -> t
156 |   (** [self] is a handle to the executing fiber. *)
157 | 
158 |   val id : t -> Id.t
159 |   (** [id h] is the unique identifier of the fiber. *)
160 | 
161 |   val equal : t -> t -> bool
162 |   (** [equal] tests fibers for equality. *)
163 | 
164 |   val compare : t -> t -> int
165 |   (** [compare] is a total order on fibers compatible with {!equal}. *)
166 | 
167 |   val pp : Format.formatter -> t -> unit
168 |   (** [pp] formats exisential fibers. *)
169 | end
170 | 
171 | val handle : 'a t -> Handle.t
172 | (** [handle f] is the handle of f. *)
173 | 
174 | (** {1:blocking Blocking} *)
175 | 
176 | val block :
177 |   block:(Handle.t -> unit) -> cancel:(Handle.t -> bool) ->
178 |   return:(Handle.t -> 'a) -> 'a
179 | (** [block ~block ~cancel ~return] blocks the calling fiber (hereafter
180 |     [f]) on a blocking operation. The given functions are used as follows:
181 | 
182 |     {ul
183 |     {- The function [block f] is immediately invoked by the scheduler.
184 |        This should register the blocking operation with an external
185 |        entity reponsible for unblocking it when the operation result
186 |        is available.  If [block f] raises, the exception is directly
187 |        thrown into the fiber [f] and not blocked.}
188 |     {- The function [cancel f] is invoked in case [f] gets cancelled while
189 |        blocked on the operation. If [true] is returned the scheduler unblocks
190 |        [f] and throws {!Cancelled} into [f]. If [false] is returned
191 |        the operation remains blocked and [return f] will be called once it
192 |        is unblocked. If [cancel f] raises the scheduler unblocks [f] and
193 |        throws the exception into [f].}
194 |     {- The function [return f] is called to get the operation's value once
195 |        it no longer blocks. This value is used to continue [f]. If [return f]
196 |        raises the exception is thrown into [f].}}
197 | 
198 |     Take into account the following points:
199 | 
200 |     {ul
201 |     {- In general it is recommended for blocking operations not be concerned
202 |        about the cancellation status of the fiber they block (XXX for now
203 |        {!Handle.t} does not even provide that).}
204 |     {- It is recommended for blocking operations to raise {!Cancelled} if
205 |        their [cancel] function is called. Either by returning [true] or
206 |        by raising in [return] (Warning, if [cancelled f] is [true] in
207 |        [return] it does not mean that [cancel] was called, it could
208 |        have been blocked while being already cancelled).}
209 |     {- The function [block] is guaranteed to be called by the domain
210 |        executing the block. Other function may be called by other
211 |        domains.}
212 |     {- Correct schedulers always call these functions at most once. [block]
213 |        is always called. If [cancel] is called and returns [true] or
214 |        raises, [return] is never called.}}
215 | 
216 |     Note that nothing will ever unblock unless you provide an adequate
217 |     {!type-unblock} function to {!val-main}. *)
218 | 
219 | val self_non_cancelling_blocks : (unit -> 'a) -> 'a
220 | (** [self_non_cancelling_blocks f] ensures in [f ()] that blocking
221 |     operations of the {e executing fiber} do not get notified of
222 |     cancellation if it gets cancelled (in other words, [cancel] functions
223 |     of {!block}s invoked by [f] never get called).
224 | 
225 |     {b Important.} Unlike {!cancel} and {!self_cancel} which propagate
226 |     to the asynchronous calls of a fiber. This does not. Making blocks
227 |     non-cancelling may be paramount to a fiber's correctness, so it
228 |     has to remain in control of it. *)
229 | 
230 | (** {2:unblocking Unblocking} *)
231 | 
232 | type unblock = poll:bool -> Handle.t option
233 | (** The type for functions to unblock blocked fibers. These functions
234 |     need to be given to {!main}.
235 | 
236 |     An [unblock] function is called by the scheduler as follows:
237 | 
238 |     {ul
239 |     {- [unblock ~poll:true], the function should return a previously blocked
240 |        fiber that no longer blocks, if any. The call must not block if there
241 |        is no such fiber as there are other fibers that are willing to run.}
242 |     {- [unblock ~poll:false], the function must return a peviously blocked
243 |        fiber that no longer blocks. If there is none, it can block for as
244 |        long as it wishes as there are no fiber to run. If it returns [None]
245 |        it will be called again, which amounts to busy waiting.}}
246 | 
247 |     The function must not raise. If it does the exception is trapped
248 |     and [None] is returned. *)
249 | 
250 | val never_unblock : unblock
251 | (** [never_unblock] nevers unblocks anything. Only use this if you are
252 |     philosophizing. *)
253 | 
254 | val unblocks : unblock list -> unblock
255 | (** [unblocks us] composes [us] by calling them one after the other in
256 |     circular order for fairness. {b FIXME.} That doesn't work for
257 |     [poll:false]. See {!todo}. *)
258 | 
259 | (** {1:run Running} *)
260 | 
261 | val main : ?domains:int -> unblock:unblock -> (unit -> 'a) -> 'a
262 | (** [main f] creates a top level fiber with [f] and runs it to completion.
263 |     {ul
264 |     {- [unblock] is the function called by the scheduler to {{!unblocking}
265 |        unblock}. If you are never blocking but only awaiting you can use
266 |        {!unblock_none}.}
267 |     {- [domains] is the number of domains to use. Defaults to
268 |        to the value specified in the environment variable
269 |        {!AFFECT_DOMAIN_COUNT} or if unparseable to
270 |        {!Domain.recommended_domain_count}.}}
271 | 
272 |     Just interpose {!main} on your [main] function as follows:
273 |     {[
274 |       let main () =
275 |         Fiber.main ~unblock:Funix.unblock @@ fun () ->
276 |         …
277 | 
278 |       let () = if !Sys.interactive then () else exit (main ())
279 |     ]} *)
280 | 
281 | (** {1:fmt Formatters} *)
282 | 
283 | val pp : Format.formatter -> 'a t -> unit
284 | (** [pp ppf f] formats the fiber status [f] for inspection. *)
285 | 
286 | val pp' : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
287 | (** [pp' pp_v] is like {!pp} but uses [pp_v] to format the value if
288 |     available. *)
289 | 
290 | val pp_id : Format.formatter -> 'a t -> unit
291 | (** [pp_id ppf f] formats a short identifying header for [f] *)
292 | 
293 | val pp_value :
294 |   (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
295 | (** [pp_value pp_v f] formats the fiber value of [f] or a placeholder
296 |     if its still running. *)
297 | 
298 | (** {1:low Low-level interface} *)
299 | 
300 | (** For devising your own scheduler.
301 | 
302 |     At some point.
303 | 
304 |     {b Warning.} This interface is subject to change even between
305 |     minore versions of the library. *)
306 | module Private : sig
307 | end
308 | 
309 | (** {1:concurrency_model Concurrency model}
310 | 
311 |     There is no distinction between concurrency and parallelism.
312 |     Fibers represent asynchronous function calls that execute in
313 |     parallel to a calling function. We use the terms {e fiber} and {e
314 |     asynchronous function call} interchangeably.
315 | 
316 |     The model is as follow:
317 |     {ol
318 |     {- Fibers are structured and aligned on function scopes. If a function
319 |        makes asychronous function calls with {!async} it does not return or
320 |        raise before all these subcalls return or raise.}
321 |     {- Fibers are cooperative. They must progress. If they are unable
322 |        to do so they must block. In this case the fiber execution is suspended
323 |        and resumed after the operation is unblocked. A distinguished, built-in,
324 |        blocking operation is {!await} which waits for an asynchronous
325 |        function call to return or raise. Other than that, libraries provide
326 |        suitable direct-style blocking functions that call {!block} underneath
327 |        and an associated function to {!unblock} them that you
328 |        specify for running your {!main} function.}
329 |     {- Fibers are oblivious of their scheduling. Execution can be
330 |        serialized or parallelized on an arbitrary number of domains or
331 |        threads. Except for explicit requests to be only executed on the main
332 |        thread, no assumption can be made on how they are scheduled
333 |        by the running program.}
334 |     {- Fibers have {{!type-priority}priorities}. By default, fibers
335 |        inherit the priority of their caller. Priorities are scheduling
336 |        {e hints}, they can be changed by schedulers. For example to avoid
337 |        priority inversion when a high priority fiber awaits a low priority
338 |        fiber.}
339 |     {- Fibers can be marked for cancellation with {!cancel} or {!self_cancel}.}
340 |     {- Cancellation is structured and aligned on function scopes. When
341 |        a fiber is marked as cancelled, its own current and future
342 |        asynchronous function calls are also marked as cancelled.}
343 |     {- Cancellation is cooperative. It is up to
344 |        the fiber itself to {{!self_is_cancelled}check} for cancellation
345 |        and decide what it wants to do about it. For example it could simply
346 |        return a partially computed result. However it is recommended to quickly
347 |        release the resources it holds and terminate the function by raising
348 |        {!Cancelled}.}
349 |     {- Blocking operations can be cancelled. It is recommended for blocking
350 |        operations not be concerned about the cancellation status of the
351 |        fiber when they block or return. However unless
352 |        {{!self_non_cancelling_blocks}prevented} by the fiber, a blocking
353 |        operation can get notified if the fiber it blocks
354 |        gets cancelled. In this case
355 |        it is recommended for the blocking operation to unblock
356 |        as soon as possible and return from it by raising {!Cancelled}.}}
357 | 
358 |     See also the {{!page-design}design notes}. *)
359 | 


--------------------------------------------------------------------------------
/attic/evloop.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | module String = struct
  7 |   include String
  8 |   let subrange ?(first = 0) ?last s =
  9 |     let max = String.length s - 1 in
 10 |     let last = match last with
 11 |     | None -> max
 12 |     | Some l when l > max -> max
 13 |     | Some l -> l
 14 |     in
 15 |     let first = if first < 0 then 0 else first in
 16 |     if first > last then "" else
 17 |     String.sub s first (last - first + 1)
 18 | end
 19 | 
 20 | module Fmt = struct
 21 |   let pf = Format.fprintf
 22 |   let kpf = Format.kfprintf
 23 |   let pr = Format.printf
 24 |   let epr = Format.eprintf
 25 |   let str = Format.asprintf
 26 |   let kstr = Format.kasprintf
 27 |   let failwith fmt = kstr failwith fmt
 28 |   let failwith_notrace fmt = kstr (fun s -> raise_notrace (Failure s)) fmt
 29 |   let invalid_arg fmt = kstr invalid_arg fmt
 30 |   let error fmt = kstr (fun s -> Error s) fmt
 31 | 
 32 |   type 'a t = Format.formatter -> 'a -> unit
 33 |   let string = Format.pp_print_string
 34 | end
 35 | 
 36 | module Result = struct
 37 | 
 38 |   include Stdlib.Result
 39 | 
 40 |   let product r0 r1 = match r0, r1 with
 41 |   | (Error _ as r), _ | _, (Error _ as r) -> r
 42 |   | Ok v0, Ok v1 -> Ok (v0, v1)
 43 | 
 44 |   (* Interacting with Stdlib exceptions *)
 45 | 
 46 |   let to_failure = function Ok v -> v | Error e -> failwith e
 47 |   let to_invalid_arg = function Ok v -> v | Error e -> invalid_arg e
 48 | 
 49 |   (* Syntax *)
 50 | 
 51 |   module Syntax = struct
 52 |     let ( let* ) x f = bind x f
 53 |     let ( and* ) a b = product a b
 54 |     let ( let+ ) x f = map f x
 55 |     let ( and+ ) a b = product a b
 56 |   end
 57 | end
 58 | 
 59 | module Mtime = struct
 60 |   type uint64 = int64
 61 | 
 62 |   module Span = struct
 63 | 
 64 |     (* Time spans
 65 | 
 66 |        Represented by a nanosecond magnitude stored in an unsigned 64-bit
 67 |        integer. Allows to represent spans for ~584.5 Julian years. *)
 68 | 
 69 |     type t = uint64
 70 |     let zero = 0L
 71 |     let one = 1L
 72 |     let max_span = -1L
 73 |     let add = Int64.add
 74 |     let abs_diff s0 s1 = match Int64.unsigned_compare s0 s1 < 0 with
 75 |     | true ->  Int64.sub s1 s0
 76 |     | false -> Int64.sub s0 s1
 77 | 
 78 |     (* Predicates and comparisons *)
 79 | 
 80 |     let equal = Int64.equal
 81 |     let compare = Int64.unsigned_compare
 82 | 
 83 |     (* Durations *)
 84 | 
 85 |     let ( * ) n s = Int64.mul (Int64.of_int n) s
 86 |     let ns   =                      1L
 87 |     let us   =                  1_000L
 88 |     let ms   =              1_000_000L
 89 |     let s    =          1_000_000_000L
 90 |     let min  =         60_000_000_000L
 91 |     let hour =       3600_000_000_000L
 92 |     let day  =      86400_000_000_000L
 93 |     let year = 31_557_600_000_000_000L
 94 | 
 95 |     (* Conversions *)
 96 | 
 97 |     let to_uint64_ns s = s
 98 |     let of_uint64_ns ns = ns
 99 |     let pp ppf s = Fmt.pf ppf "%Luns" s (* Fmt.uint64_ns_span *)
100 |     let pp_ns ppf s = Fmt.pf ppf "%Luns" s
101 |   end
102 | 
103 |   type span = Span.t
104 | 
105 |   (* Monotonic timestamps *)
106 | 
107 |   type t = uint64
108 | 
109 |   let to_uint64_ns s = s
110 |   let of_uint64_ns ns = ns
111 |   let min_stamp = 0L
112 |   let max_stamp = -1L
113 |   let pp ppf s = Fmt.pf ppf "%Lu" s
114 | 
115 |   (* Predicates *)
116 | 
117 |   let equal = Int64.equal
118 |   let compare = Int64.unsigned_compare
119 |   let is_earlier t ~than = compare t than < 0
120 |   let is_later t ~than = compare t than > 0
121 | 
122 |   (* Arithmetic *)
123 | 
124 |   let span t0 t1 = match compare t0 t1 < 0 with
125 |   | true -> Int64.sub t1 t0
126 |   | false -> Int64.sub t0 t1
127 | 
128 |   let add_span t s =
129 |     let sum = Int64.add t s in
130 |     if compare t sum <= 0 then Some sum else None
131 | 
132 |   let sub_span t s =
133 |     if compare t s < 0 then None else Some (Int64.sub t s)
134 | end
135 | 
136 | module Os = struct
137 |   external mtime_now_ns : unit -> Mtime.t = "ocaml_evloop_monotonic_now_ns"
138 | 
139 |   module Signal = struct
140 |     type t = int
141 | 
142 |     let set s b = match Sys.signal s b with
143 |     | b -> Ok b | exception Sys_error e -> Error e
144 | 
145 |     let set_noerr s b = try Sys.set_signal s b with Sys_error _ -> ()
146 |   end
147 | 
148 |   module Fd = struct
149 |     let uerror e = Unix.error_message e
150 | 
151 |     (* Closing *)
152 | 
153 |     let close_noerr fd = try Unix.close fd with Unix.Unix_error _ -> ()
154 | 
155 |     (* Read and write *)
156 | 
157 |     let rec read fd b ~start ~len = match Unix.read fd b start len with
158 |     | exception Unix.Unix_error (Unix.EINTR, _, _) -> read fd b ~start ~len
159 |     | 0 when len <> 0 -> false
160 |     | c when c < len -> read fd b ~start:(start + c) ~len:(len - c)
161 |     | _ -> true
162 | 
163 |     let rec write fd b ~start ~len = match Unix.single_write fd b start len with
164 |     | exception Unix.Unix_error (Unix.EINTR, _, _) -> write fd b ~start ~len
165 |     | c when c < len -> write fd b ~start:(start + c) ~len:(len - c)
166 |     | _ -> ()
167 | 
168 |     (* Socket endpoints *)
169 | 
170 |     type endpoint =
171 |     [ `Host of string * int
172 |     | `Sockaddr of Unix.sockaddr
173 |     | `Fd of Unix.file_descr ]
174 | 
175 |     let endpoint_of_string ~default_port s =
176 |       match String.contains s Filename.dir_sep.[0] with
177 |       | true -> Ok (`Sockaddr (Unix.ADDR_UNIX s))
178 |       | false ->
179 |           match String.rindex_opt s ':' with
180 |           | None -> Ok (`Host (s, default_port))
181 |           | Some i ->
182 |               match String.index_from_opt s i ']' with (* beware IPv6 *)
183 |               | Some _ -> Ok (`Host (s, default_port))
184 |               | None ->
185 |                   let h = String.subrange ~last:(i - 1) s in
186 |                   let p = String.subrange ~first:(i + 1) s in
187 |                   match int_of_string_opt p with
188 |                   | None -> Fmt.error "port %S not an integer" p
189 |                   | Some p -> Ok (`Host (h, p))
190 | 
191 |     let pp_endpoint ppf ep =
192 |       let pp_name_port ppf (n, p) = Fmt.pf ppf "%s:%d" n p in
193 |       match ep with
194 |       | `Host (n, p) -> pp_name_port ppf (n, p)
195 |       | `Fd _fd -> Fmt.pf ppf "<fd>"
196 |       | `Sockaddr (Unix.ADDR_UNIX s) -> Fmt.string ppf s
197 |       | `Sockaddr (Unix.ADDR_INET (a, p)) ->
198 |           pp_name_port ppf (Unix.string_of_inet_addr a, p)
199 | 
200 |     let rec socket_of_endpoint ep stype = match ep with
201 |     | `Fd fd -> Ok (None, fd, false)
202 |     | `Host (name, port) ->
203 |         begin match Unix.gethostbyname name with
204 |         | exception Not_found -> Fmt.error "%s: host not found" name
205 |         | h ->
206 |             let c = `Sockaddr (Unix.ADDR_INET (h.h_addr_list.(0), port)) in
207 |             socket_of_endpoint c stype
208 |         end
209 |     | `Sockaddr addr ->
210 |         let domain = Unix.domain_of_sockaddr addr in
211 |         match Unix.socket ~cloexec:true domain stype 0 with
212 |         | exception Unix.Unix_error (e, _, _) -> Error (uerror e)
213 |         | fd -> Ok (Some addr, fd, true)
214 | 
215 |     (* Sets *)
216 | 
217 |     module T = struct
218 |       type t = Unix.file_descr
219 |       let compare : Unix.file_descr -> Unix.file_descr -> int = compare
220 |     end
221 | 
222 |     module Set = Set.Make (T)
223 |   end
224 | 
225 |   module Ev = struct
226 | 
227 |     (* Callbacks *)
228 | 
229 |     type cb =
230 |     | Nop
231 |     | Cb of (unit -> unit)
232 |     | Cb_expirable of (expired:bool -> unit -> unit)
233 | 
234 |     (* Events *)
235 | 
236 |     type t = { time : Mtime.t; mutable cb : cb }
237 | 
238 |     let create_untimed cb = { time = Mtime.max_stamp; cb }
239 |     let create ~dur cb = { time = Int64.add (mtime_now_ns ()) dur; cb }
240 |     let farthest = create_untimed Nop
241 | 
242 |     (* Heap priority queue, classical imperative implementation. *)
243 | 
244 |     let heap_compare h i i' = Mtime.compare h.(i).time h.(i').time
245 |     let heap_swap h i i' = let v = h.(i) in h.(i) <- h.(i'); h.(i') <- v
246 | 
247 |     let rec heap_up h i =
248 |       if i = 0 then () else
249 |       let p = (i - 1) / 2 in (* parent index. *)
250 |       if heap_compare h i p < 0 then (heap_swap h i p; heap_up h p)
251 | 
252 |     let rec heap_down h max i =
253 |       let start = 2 * i in
254 |       let l = start + 1 in (* left child index. *)
255 |       let r = start + 2 in (* right child index. *)
256 |       if l > max then () (* no child, stop *) else (* find smallest child k. *)
257 |       let k = if r > max then l else (if heap_compare h l r < 0 then l else r)
258 |       in
259 |       if heap_compare h i k > 0 then (heap_swap h i k; heap_down h max k)
260 | 
261 |     let heap () = Array.make 256 farthest
262 | 
263 |     (* Event sets *)
264 | 
265 |     type set =
266 |       { mutable r : (Unix.file_descr * t) list;
267 |         mutable w : (Unix.file_descr * t) list;
268 |         mutable ready_fds : (Unix.file_descr * (unit -> unit)) list;
269 |         mutable timeouts : t array; (* Heap priority queue for timeouts *)
270 |         mutable timeout_max : int; (* Index of tast element of [timeouts]. *) }
271 | 
272 |     let set () =
273 |       { r = []; w = []; ready_fds = []; timeouts = heap (); timeout_max = -1}
274 | 
275 |     let timeout_exists s = s.timeout_max > -1
276 |     let fd_exists s = s.r <> [] || s.w <> [] || s.ready_fds <> []
277 | 
278 |     (* Timeout handling *)
279 | 
280 |     let shrink_timeouts_threshold = 262144
281 |     let shrink_timeouts s = (* assert (s.timeout_max < 0). *)
282 |       if Array.length s.timeouts < shrink_timeouts_threshold then () else
283 |       s.timeouts <- heap ()
284 | 
285 |     let grow_timeouts s =
286 |       let len = s.timeout_max + 1 in
287 |       let timeouts' = Array.make (2 * len) farthest in
288 |       Array.blit s.timeouts 0 timeouts' 0 len; s.timeouts <- timeouts'
289 | 
290 |     let add_timeout s ev =
291 |       let max = s.timeout_max + 1 in
292 |       if max = Array.length s.timeouts then grow_timeouts s;
293 |       s.timeout_max <- max;
294 |       s.timeouts.(s.timeout_max) <- ev; heap_up s.timeouts s.timeout_max
295 | 
296 |     let pop_timeout s =
297 |       let last = s.timeouts.(s.timeout_max) in
298 |       s.timeouts.(s.timeout_max) <- farthest;
299 |       s.timeout_max <- s.timeout_max - 1;
300 |       if s.timeout_max < 0 then shrink_timeouts s else
301 |       (s.timeouts.(0) <- last; heap_down s.timeouts s.timeout_max 0)
302 | 
303 |     let dur_to_next_timeout s =
304 |       let rec loop s now =
305 |         if s.timeout_max < 0 then None else
306 |         if s.timeouts.(0).cb = Nop then (pop_timeout s; loop s now) else
307 |         let time = s.timeouts.(0).time in
308 |         let late = Mtime.is_earlier time ~than:now in
309 |         Some (if late then Mtime.Span.zero else (Mtime.span now time))
310 |       in
311 |       loop s (mtime_now_ns ())
312 | 
313 |     let expired_timeout s =
314 |       let rec loop s now =
315 |         if s.timeout_max < 0 then None else
316 |         if s.timeouts.(0).cb = Nop then (pop_timeout s; loop s now) else
317 |         let time = s.timeouts.(0).time in
318 |         if not (Mtime.is_earlier time ~than:now) then None else
319 |         let ev = s.timeouts.(0) in
320 |         pop_timeout s;
321 |         match ev.cb with
322 |         | Cb cb -> ev.cb <- Nop; Some (`Event cb)
323 |         | Cb_expirable cb -> ev.cb <- Nop; Some (`Event (cb ~expired:true))
324 |         | Nop -> assert false
325 |       in
326 |       loop s (mtime_now_ns ())
327 | 
328 |     (* Fd handling *)
329 | 
330 |     let ready_fd s = match s.ready_fds with
331 |     | [] -> None | (_, cb) :: rs -> s.ready_fds <- rs; Some (`Event cb)
332 | 
333 |     let rec x_set fds xs = function
334 |     | [] -> fds, xs
335 |     | (fd, ev as x) :: rest ->
336 |         if ev.cb = Nop then x_set fds xs rest else
337 |         x_set (Fd.Set.add fd fds) (x :: xs) rest
338 | 
339 |     let r_set s =
340 |       let fds, r = x_set Fd.Set.empty [] s.r in
341 |       s.r <- r; Fd.Set.elements fds
342 | 
343 |     let w_set s =
344 |       let fds, w = x_set Fd.Set.empty [] s.w in
345 |       s.w <- w; Fd.Set.elements fds
346 | 
347 |     let rec x_ready fds ready xs = function
348 |     | [] -> ready, xs
349 |     | (fd, ev as x) :: rest ->
350 |         if not (Fd.Set.mem fd fds) then x_ready fds ready (x :: xs) rest else
351 |         match ev.cb with
352 |         | Nop -> assert false
353 |         | Cb cb -> ev.cb <- Nop; x_ready fds ((fd, cb) :: ready) xs rest
354 |         | Cb_expirable cb ->
355 |             ev.cb <- Nop; x_ready fds ((fd, cb ~expired:false) :: ready) xs rest
356 | 
357 |     let ready_r_set s fds =
358 |       let ready, r = x_ready (Fd.Set.of_list fds) s.ready_fds [] s.r in
359 |       s.ready_fds <- ready; s.r <- r
360 | 
361 |     let ready_w_set s fds =
362 |       let ready, w = x_ready (Fd.Set.of_list fds) s.ready_fds [] s.w in
363 |       s.ready_fds <- ready; s.w <- w
364 | 
365 |     (* Waiting for next event *)
366 | 
367 |     let wait s = (* assert s.ready_fds = [] *)
368 |       let timeout_s = match dur_to_next_timeout s with
369 |       | None -> -1.
370 |       | Some dur -> Int64.to_float (Mtime.Span.to_uint64_ns dur) *. 1e-9
371 |       in
372 |       let r_set = r_set s and w_set = w_set s in
373 |       if timeout_s = -1. && r_set = [] && w_set = [] then `Empty else
374 |       match Unix.select r_set w_set [] timeout_s with
375 |       | exception Unix.Unix_error (Unix.EINTR, _, _) -> `Signal
376 |       | [], [], [] -> `Next
377 |       | r_set, w_set, _ -> ready_r_set s r_set; ready_w_set s w_set; `Next
378 | 
379 |     let rec next s = match ready_fd s with
380 |     | Some _ as cb -> cb
381 |     | None ->
382 |         match expired_timeout s with
383 |         | Some _ as cb -> cb
384 |         | None ->
385 |             match wait s with
386 |             | `Empty -> None
387 |             | `Signal -> (Some `Signal)
388 |             | `Next -> next s
389 | 
390 |     (* Timeout events *)
391 | 
392 |     let timeout s ~dur cb = let ev = create ~dur (Cb cb) in add_timeout s ev; ev
393 | 
394 |     (* File descriptor events *)
395 | 
396 |     type fd = [`R|`W]
397 | 
398 |     let fd_ev s fd what ev = match what with
399 |     | `R -> s.r <- (fd, ev) :: s.r; ev
400 |     | `W -> s.w <- (fd, ev) :: s.w; ev
401 | 
402 |     let fd s fd what cb = fd_ev s fd what (create_untimed (Cb cb))
403 |     let fd_or_timeout s ~dur fd what cb =
404 |       let ev = create ~dur (Cb_expirable cb) in
405 |       add_timeout s ev; fd_ev s fd what ev
406 | 
407 |     (* Removing events *)
408 | 
409 |     let remove _s ev = ev.cb <- Nop
410 |     let remove_fd s fd =
411 |       let not_fd (fd', ev) = fd' <> fd || (remove s ev; false) in
412 |       s.r <- List.filter not_fd s.r;
413 |       s.w <- List.filter not_fd s.w;
414 |       s.ready_fds <- List.filter (fun (fd', _) -> fd <> fd') s.ready_fds
415 | 
416 |     let remove_all s =
417 |       s.r <- []; s.w <- []; s.ready_fds <- [];
418 |       s.timeouts <- heap (); s.timeout_max <- -1
419 | 
420 |   end
421 | 
422 |   module Mtime = struct
423 | 
424 |     (* Monotonic clock *)
425 | 
426 |     let origin = mtime_now_ns ()
427 |     let elapsed () = Int64.sub (mtime_now_ns ()) origin
428 |     let now = mtime_now_ns
429 | 
430 |     (* Monotonic time counter *)
431 | 
432 |     type counter = Mtime.t
433 |     let counter = mtime_now_ns
434 |     let count c = Int64.sub (mtime_now_ns ()) c
435 |   end
436 | end
437 | 
438 | module Cli = struct
439 | 
440 |   open Cmdliner
441 | 
442 |   let endpoint_conv ~default_port =
443 |     let parse s =
444 |       Result.map_error (fun e -> `Msg e) @@
445 |       Os.Fd.endpoint_of_string ~default_port s
446 |     in
447 |     Arg.conv (parse, Os.Fd.pp_endpoint)
448 | 
449 |   let endpoint
450 |       ?(opts = ["s"; "socket"]) ?docs ~default_port ~default_endpoint ()
451 |     =
452 |     let doc =
453 |       Fmt.str "Connect socket on address $(i,ADDR) and port $(i,PORT) \
454 |         (defaults to %d) or Unix domain socket $(i,PATH)" default_port
455 |     in
456 |     let docv = "ADDR[:PORT]|PATH" in
457 |     let epconv = endpoint_conv ~default_port in
458 |     Arg.(value & opt epconv default_endpoint & info opts ?docs ~doc ~docv)
459 | end
460 | 


--------------------------------------------------------------------------------
/attic/evloop.mli:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2022 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | (** Event loop.
  7 | 
  8 |     This is a sample event loop that you might
  9 |     want to interface with effects. *)
 10 | 
 11 | (** Textual formatters.
 12 | 
 13 |     Helpers for dealing with {!Format}. *)
 14 | module Fmt : sig
 15 | 
 16 |   (** {1:formatting Formatting} *)
 17 | 
 18 |   val pf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a
 19 |   (** [pf] is {!Format.fprintf}. *)
 20 | 
 21 |   val pr : ('a, Format.formatter, unit) format -> 'a
 22 |   (** [pf] is {!Format.printf}. *)
 23 | 
 24 |   val epr : ('a, Format.formatter, unit) format -> 'a
 25 |   (** [epr] is {!Format.eprintf}. *)
 26 | 
 27 |   val str : ('a, Format.formatter, unit, string) format4 -> 'a
 28 |   (** str is {!Format.asprintf}. *)
 29 | 
 30 |   val kpf :
 31 |     (Format.formatter -> 'a) -> Format.formatter ->
 32 |     ('b, Format.formatter, unit, 'a) format4 -> 'b
 33 |   (** [kpf] is {!Format.kfprintf}. *)
 34 | 
 35 |   val kstr : (string -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b
 36 |   (** kstr is {!Format.kasprintf}. *)
 37 | 
 38 |   val failwith : ('b, Format.formatter, unit, 'a) format4 -> 'b
 39 |   (** [failwith fmt ...] is [kstr failwith fmt ...] *)
 40 | 
 41 |   val failwith_notrace : ('b, Format.formatter, unit, 'a) format4 -> 'b
 42 |   (** [failwith_notrace] is like {!failwith} but [Failure] is raised with
 43 |       {!raise_notrace}. *)
 44 | 
 45 |   val invalid_arg : ('b, Format.formatter, unit, 'a) format4 -> 'b
 46 |   (** [invalid_arg fmt ...] is [kstr invalid_arg fmt ...] *)
 47 | 
 48 |   val error : ('b, Format.formatter , unit, ('a, string) result) format4 -> 'b
 49 |   (** [error fmt ...] is [kstr (fun s -> Error s) fmt ...] *)
 50 | 
 51 |   (** {1:formatters Formatters} *)
 52 | 
 53 |   type 'a t = Format.formatter -> 'a -> unit
 54 |   (** The type for formatters. *)
 55 | 
 56 |   val string : string t
 57 |   (** [string] is {!Format.pp_print_string}. *)
 58 | end
 59 | 
 60 | (** Result values *)
 61 | module Result : sig
 62 | 
 63 |   include module type of Stdlib.Result
 64 | 
 65 |   val to_failure : ('a, string) result -> 'a
 66 |   (** [to_failure r] is [failwith e] if [r] is [Error e] and [v]
 67 |       if [r] is [Ok v]. *)
 68 | 
 69 |   val to_invalid_arg : ('a, string) result -> 'a
 70 |   (** [to_invalid_arg r] is [invalid_arg e] if [r] is [Error e] and [v]
 71 |       if [r] is [Ok v]. *)
 72 | 
 73 |   (** let operators. *)
 74 |   module Syntax : sig
 75 |     val ( let* ) :
 76 |       ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result
 77 |     (** [( let* )] is {!bind}. *)
 78 | 
 79 |     val ( and* ) : ('a, 'e) result -> ('b, 'e) result -> ('a * 'b, 'e) result
 80 |     (** [( and* )] is {!product}. *)
 81 | 
 82 |     val ( let+ ) : ('a, 'e) result -> ('a -> 'b) -> ('b, 'e) result
 83 |     (** [( let+ )] is {!map}. *)
 84 | 
 85 |     val ( and+ ) : ('a, 'e) result -> ('b, 'e) result -> ('a * 'b, 'e) result
 86 |     (** [( and* )] is {!product}. *)
 87 |   end
 88 | end
 89 | 
 90 | (** Monotonic time stamps and spans.
 91 | 
 92 |     This module provides support for representing monotonic wall-clock time.
 93 |     This time increases monotonically and is not subject to operating
 94 |     system calendar time adjustement. Its absolute value is meaningless.
 95 | 
 96 |     To obtain monotonic time stamps and measure it use {!Os.Mtime}. *)
 97 | module Mtime : sig
 98 | 
 99 |   (** {1:span Monotonic time spans} *)
100 | 
101 |   type span
102 |   (** The type for non-negative monotonic time spans. They represent
103 |       the difference between two monotonic clock readings with
104 |       nanosecond precision (1e-9s) and can measure up to
105 |       approximatevely 584 Julian year spans before silently rolling
106 |       over (unlikely since this is in a single program run). *)
107 | 
108 |   (** Monotonic time spans *)
109 |   module Span : sig
110 | 
111 |     (** {1:span Time spans} *)
112 | 
113 |     type t = span
114 |     (** See {!type:span}. *)
115 | 
116 |     val zero : span
117 |     (** [zero] is a span of 0ns. *)
118 | 
119 |     val one : span
120 |     (** [one] is a span of 1ns. *)
121 | 
122 |     val max_span : span
123 |     (** [max_span] is a span of [2^64-1]ns. *)
124 | 
125 |     val add : span -> span -> span
126 |     (** [add s0 s1] is [s0] + [s1]. {b Warning.} Rolls over on overflow. *)
127 | 
128 |     val abs_diff : span -> span -> span
129 |     (** [abs_diff s0 s1] is the absolute difference between [s0] and [s1]. *)
130 | 
131 |     (** {1:preds Predicates and comparisons} *)
132 | 
133 |     val equal : span -> span -> bool
134 |     (** [equal s0 s1] is [s0 = s1]. *)
135 | 
136 |     val compare : span -> span -> int
137 |     (** [compare s0 s1] orders span by increasing duration. *)
138 | 
139 |     (** {1:const Durations} *)
140 | 
141 |     val ( * ) : int -> span -> span
142 |     (** [n * dur] is [n] times duration [n]. Does not check for
143 |         overflow or that [n] is positive. *)
144 | 
145 |     val ns : span
146 |     (** [ns] is a nanosecond duration, 1·10{^-9}s. *)
147 | 
148 |     val us : span
149 |     (** [us] is a microsecond duration, 1·10{^-6}s. *)
150 | 
151 |     val ms : span
152 |     (** [ms] is a millisecond duration, 1·10{^-3}s. *)
153 | 
154 |     val s : span
155 |     (** [s] is a second duration, 1s. *)
156 | 
157 |     val min : span
158 |     (** [min] is a minute duration, 60s. *)
159 | 
160 |     val hour : span
161 |     (** [hour] is an hour duration, 3600s. *)
162 | 
163 |     val day : span
164 |     (** [day] is a day duration, 86'400s. *)
165 | 
166 |     val year : span
167 |     (** [year] is a Julian year duration (365.25 days), 31'557'600s. *)
168 | 
169 |     (** {1:conv Conversions} *)
170 | 
171 |     val to_uint64_ns : span -> int64
172 |     (** [to_uint64_ns s] is [s] as an {e unsigned} 64-bit integer nanosecond
173 |         span. *)
174 | 
175 |     val of_uint64_ns : int64 -> span
176 |     (** [of_uint64_ns u] is the {e unsigned} 64-bit integer nanosecond span [u]
177 |         as a span. *)
178 | 
179 |     (** {1:fmt Formatting} *)
180 | 
181 |     val pp : span Fmt.t
182 |     (** [pp] formats with {!Fmt.uint64_ns_span}. *)
183 | 
184 |     val pp_ns : span Fmt.t
185 |     (** [pp_ns ppf s] prints [s] as an unsigned 64-bit integer nanosecond
186 |         span. *)
187 |   end
188 | 
189 |   (** {1:timestamp Monotonic timestamps}
190 | 
191 |       {b Note.} Only use timestamps if you need inter-process time
192 |       correlation,  otherwise prefer {!Os.Mtime.elapsed} and
193 |       {{!Evloop_std.Os.Mtime.monotonic_counters}counters} to measure time. *)
194 | 
195 |   type t
196 |   (** The type for monotonic timestamps relative to an indeterminate
197 |       system-wide event (e.g. last startup). Their absolute value has no
198 |       meaning but can be used for inter-process time correlation. *)
199 | 
200 |   val to_uint64_ns : t -> int64
201 |   (** [to_uint64_ns t] is [t] as an {e unsigned} 64-bit integer
202 |       nanosecond timestamp. The absolute value is meaningless. *)
203 | 
204 |   val of_uint64_ns : int64 -> t
205 |   (** [to_uint64_ns t] is [t] is an {e unsigned} 64-bit integer
206 |       nanosecond timestamp as a timestamp.
207 | 
208 |       {b Warning.} Timestamps returned by this function should only be
209 |       used with other timestamp values that are know to come from the
210 |       same operating system run. *)
211 | 
212 |   val min_stamp : t
213 |   (** [min_stamp] is the earliest timestamp. *)
214 | 
215 |   val max_stamp : t
216 |   (** [max_stamp] is the latest timestamp. *)
217 | 
218 |   val pp : t Fmt.t
219 |   (** [pp] is a formatter for timestamps. *)
220 | 
221 |   (** {1:preds Predicates} *)
222 | 
223 |   val equal : t -> t -> bool
224 |   (** [equal t t'] is [true] iff [t] and [t'] are equal. *)
225 | 
226 |   val compare : t -> t -> int
227 |   (** [compare t t'] orders timestamps by increasing time. *)
228 | 
229 |   val is_earlier : t -> than:t -> bool
230 |   (** [is_earlier t ~than] is [true] iff [t] occurred before [than]. *)
231 | 
232 |   val is_later : t -> than:t -> bool
233 |   (** [is_later t ~than] is [true] iff [t] occurred after [than]. *)
234 | 
235 |   (** {1:arith Arithmetic} *)
236 | 
237 |   val span : t -> t -> span
238 |   (** [span t t'] is the span between [t] and [t'] regardless of the
239 |       order between [t] and [t']. *)
240 | 
241 |   val add_span : t -> span -> t option
242 |   (** [add_span t s] is the timestamp [s] units later than [t] or [None] if
243 |       the result overflows. *)
244 | 
245 |   val sub_span : t -> span -> t option
246 |   (** [sub_span t s] is the timestamp [s] units earlier than [t] or
247 |       [None] if overflows. *)
248 | end
249 | 
250 | 
251 | (** Operating system interaction. *)
252 | module Os : sig
253 | 
254 |   (** Signals *)
255 |   module Signal : sig
256 |     type t = int
257 |     (** The type for signal numbers. *)
258 | 
259 |     val set : t -> Sys.signal_behavior -> (Sys.signal_behavior, string) result
260 |     (** [set sg b] is like {!Sys.signal} but does not raise exceptions. *)
261 | 
262 |     val set_noerr : t -> Sys.signal_behavior -> unit
263 |     (** [set_noerr sg b] is like {!Sys.set_signal} but ignores errors. *)
264 |   end
265 | 
266 |   (** Unix file descriptor helpers *)
267 |   module Fd : sig
268 | 
269 |     (** {1:closing Closing} *)
270 | 
271 |     val close_noerr : Unix.file_descr -> unit
272 |     (** [close_noerr fd] closes [fd] and ignores any error.
273 |         Useful for {!Fun.protect} [finally] functions which must not
274 |         raise. *)
275 | 
276 |     (** {1:read_write Read and write}
277 | 
278 |         {b Note.} These functions may raise {!Unix_error}. *)
279 | 
280 |     val read : Unix.file_descr -> bytes -> start:int -> len:int -> bool
281 |     (** [read fd b ~start ~len] reads [len] bytes from [fd] into [b]
282 |         starting at [start] and returns [true]. Returns [false] if
283 |         [len] bytes could not be read (i.e. end of file/stream was
284 |         hit). The function handles signal interruptions ([EINTR]). *)
285 | 
286 |     val write : Unix.file_descr -> bytes -> start:int -> len:int -> unit
287 |     (** [write fd b ~start ~len] writes [len] bytes starting at [start]
288 |         from [b] on [fd]. The function handles signal interruptions
289 |         ([EINTR]). *)
290 | 
291 |     (** {1:endpoint Socket endpoint specification} *)
292 | 
293 |     type endpoint =
294 |     [ `Host of string * int (** Hostname and port. *)
295 |     | `Sockaddr of Unix.sockaddr (** Given socket address. *)
296 |     | `Fd of Unix.file_descr (** Direct file descriptor. *) ]
297 |     (** The type for specifying a socket endpoint to connect to
298 |         or to listen to on. *)
299 | 
300 |     val endpoint_of_string :
301 |       default_port:int -> string -> (endpoint, string) result
302 |     (** [connection_of_string ~default_port s] parses a connection
303 |         specification from [s].  The format is [ADDR[:PORT]] or [PATH]
304 |         for a Unix domain socket (detected by the the presence of
305 |         a {{!Stdlib.Filename.dir_sep}directory separator}).
306 |         [default_port] port is used if no [PORT] is specified. *)
307 | 
308 |     val pp_endpoint : endpoint Fmt.t
309 |     (** [pp_endpoint] formats an unspecified representation of endpoint
310 |         values. *)
311 | 
312 |     val socket_of_endpoint :
313 |       endpoint -> Unix.socket_type ->
314 |       (Unix.sockaddr option * Unix.file_descr * bool, string) result
315 |     (** [socket_of_endpoint c] is [Ok (addr, fd, close)] with:
316 |         {ul
317 |         {- [addr], the address for the socket, if any.}
318 |         {- [fd], the file descriptor for the socket.}
319 |         {- [close] is [true] if the client is in charge of closing it.}}
320 | 
321 |         Unless [c] was [`Fd _], [fd]
322 |         has {{:Unix.set_close_on_exec}close on exec} set to [true]. *)
323 | 
324 |     (** {1:sets Sets of file descriptors} *)
325 | 
326 |     (** Sets of file descriptors. *)
327 |     module Set : sig
328 |       include Set.S with type elt := Unix.file_descr
329 |     end
330 |   end
331 | 
332 |   (** IO and timeout events. *)
333 |   module Ev : sig
334 | 
335 |     (** {1:sets Sets of events} *)
336 | 
337 |     type set
338 |     (** The type for sets of events. *)
339 | 
340 |     val set : unit -> set
341 |     (** [set ()] is a new empty set of events. *)
342 | 
343 |     val next : set -> [`Signal | `Event of (unit -> unit)] option
344 |     (** [next s] blocks until the next event of [s] or a signal occurs. This is:
345 |         {ul
346 |         {- [None] if there are no longer any events in [set]}
347 |         {- [Some (`Event cb)] if an event occured, [cb] is the function to
348 |            invoke to handle the event.}
349 |         {- [Some `Signal] if a signal occured.}} *)
350 | 
351 |     (** {1:events Events} *)
352 | 
353 |     type t
354 |     (** The type for events. Represents a {{!section-timeout}timeout} or
355 |         {{!section-fd}file descriptor} event. *)
356 | 
357 |     (** {2:timeout Timeout events} *)
358 | 
359 |     val timeout : set -> dur:Mtime.span -> (unit -> unit) -> t
360 |     (** [timeout s ~dur cb] is the event in [s] that schedules the
361 |         callback [cb] after a [dur] duration from now.
362 | 
363 |         {b Note.} Even if [dur] has nanosecond resolution, the
364 |         maximal resolution is more likely to be microseconds, if not
365 |         milliseconds. *)
366 | 
367 |     val timeout_exists : set -> bool
368 |     (** [timeout_exists s] is [true] iff there is a timeout in [s]. *)
369 | 
370 |     (** {2:fd File descriptor events} *)
371 | 
372 |     type fd =
373 |       [ `R (** Read opportunity event. *)
374 |       | `W (** Write opportunity event. *) ]
375 |     (** The type for file descriptor events. *)
376 | 
377 |     val fd : set -> Unix.file_descr -> fd -> (unit -> unit) -> t
378 |     (** [fd s fd what cb] is the event in [s] that schedules the callback [cb]
379 |         whenever a [what] can be performed on [fd]. *)
380 | 
381 |     val fd_or_timeout :
382 |       set -> dur:Mtime.span -> Unix.file_descr -> fd ->
383 |       (expired:bool -> unit -> unit) -> t
384 |     (** [fd_or_timeout s ~dur fd what cb] is the event in [s] that
385 |         schedules the callback [cb ~expired:false] whenever a [what] can be
386 |         performed on [fd] or [cb ~expired:true] if that does not occur before
387 |         duration [dur] from now.
388 | 
389 |         {b Note.} Even if [dur] has nanosecond resolution, the maximal
390 |         resolution is more likely to be microseconds, if not
391 |         milliseconds. *)
392 | 
393 |     val fd_exists : set -> bool
394 |     (** [fd_exists s] is [true] iff there is a fd event in [s]. *)
395 | 
396 |     (** {2:removing Removing events} *)
397 | 
398 |     val remove : set -> t -> unit
399 |     (** [remove s ev] removes [ev] from [s]. The callback associated to [ev]
400 |         is dropped and will not be returned by {!next}. *)
401 | 
402 |     val remove_fd : set -> Unix.file_descr -> unit
403 |     (** [remove_fd s fd] remove (in the sense of {!remove}) all events
404 |         for file descriptor [fd] in [s]. No callback concerning [fd] will
405 |         be returned by {!next}. *)
406 | 
407 |     val remove_all : set -> unit
408 |     (** [remove_all s] removes all events from [s]. {!next} returns
409 |         [None]. *)
410 |   end
411 | 
412 |   (** Monotonic time clock.
413 | 
414 |       See {!Evloop.Mtime} for a discussion about monotonic time. *)
415 |   module Mtime : sig
416 | 
417 |     (** {1:monotonic_clock Monotonic clock} *)
418 | 
419 |     val now : unit -> Mtime.t
420 |     (** [now ()] is the current system-relative monotonic timestamp. Its
421 |         absolute value is meaningless. *)
422 | 
423 |     val elapsed : unit -> Mtime.span
424 |     (** [elapsed ()] is the monotonic time span elapsed since the
425 |         beginning of the program. *)
426 | 
427 |     (** {1:monotonic_counters Monotonic wall-clock time counters} *)
428 | 
429 |     type counter
430 |     (** The type for monotonic wall-clock time counters. *)
431 | 
432 |     val counter : unit -> counter
433 |     (** [counter ()] is a counter counting from now on. *)
434 | 
435 |     val count : counter -> Mtime.span
436 |     (** [count c] is the monotonic time span elapsed since [c] was created. *)
437 | 
438 |     (** {1:err Error handling}
439 | 
440 |         The functions {!elapsed}, {!now}, {!val-counter},
441 |         raise [Sys_error] whenever they can't determine the
442 |         current time or that it doesn't fit in [Mtime]'s range. Usually
443 |         this exception should only be catched at the toplevel of your
444 |         program to log it and abort the program. It indicates a serious
445 |         error condition in the system.
446 | 
447 |         {1:platform_support Platform support}
448 | 
449 |         {ul
450 |         {- Platforms with a POSIX clock (includes Linux) use
451 |         {{:http://pubs.opengroup.org/onlinepubs/9699919799/functions/clock_gettime.html}[clock_gettime]}
452 |         with CLOCK_MONOTONIC.}
453 |         {- Darwin uses
454 |         {{:https://developer.apple.com/library/mac/qa/qa1398/_index.html}[mach_absolute_time]}.}
455 |         {- Windows uses
456 |         {{:https://msdn.microsoft.com/en-us/library/windows/desktop/aa373083%28v=vs.85%29.aspx}Performance counters}.}} *)
457 |   end
458 | 
459 | end
460 | 
461 | (** Command line interface fragments *)
462 | module Cli : sig
463 | 
464 |   (** {1:options Options} *)
465 | 
466 |   val endpoint :
467 |     ?opts:string list -> ?docs:string -> default_port:int ->
468 |     default_endpoint:Os.Fd.endpoint -> unit ->
469 |     Os.Fd.endpoint Cmdliner.Term.t
470 |   (** [endpoint] is an option for specifying a socket endpoint.
471 |       {ul
472 |       {- [default_port] is the default port when unspecified.}
473 |       {- [default_endpoint] is the default endpoint when unspecified}
474 |       {- [docs] is the section where the option is documented}
475 |       {- [opts] are the options to use (defaults to [["s"; "socket"]])}} *)
476 | end
477 | 


--------------------------------------------------------------------------------
/src/fiber.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2024 The affect programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | (* Preliminaries *)
  7 | 
  8 | let pp_uchar ppf u = Format.fprintf ppf "@<1>%s" u
  9 | let pp_list ?(pp_sep = Format.pp_print_space) pp_v ppf l =
 10 |   Format.pp_print_list ~pp_sep pp_v ppf l
 11 | 
 12 | let debug fmt = Format.eprintf (fmt ^^ "@.")
 13 | 
 14 | let invalid_argf fmt = Format.kasprintf invalid_arg fmt
 15 | let is_asynchronous_exn = function
 16 | | Stack_overflow | Out_of_memory | Sys.Break -> true | _ -> false
 17 | 
 18 | module Circular_list = struct (* Circular doubly linked list *)
 19 |   type 'a t =
 20 |     { mutable v : 'a option; (* None is for the root. *)
 21 |       mutable prev : 'a t; (* on root this points to last element. *)
 22 |       mutable next : 'a t; (* on root this points to the first element. *) }
 23 | 
 24 |   let make () = let rec root = { v = None; next = root; prev = root } in root
 25 | 
 26 |   let make_first root n =
 27 |     n.next.prev <- n.prev; n.prev.next <- n.next;
 28 |     n.next <- root.next; n.prev <- root;
 29 |     root.next.prev <- n; root.next <- n
 30 | 
 31 |   let add_first root v =
 32 |     let n = { v = Some v; prev = root; next = root.next } in
 33 |     root.next.prev <- n; root.next <- n
 34 | 
 35 |   let add_last root v =
 36 |     let n = { v = Some v; prev = root.prev; next = root } in
 37 |     root.prev.next <- n; root.prev <- n
 38 | 
 39 |   let take_first root =
 40 |     let first = root.next in
 41 |     root.next <- first.next; first.next.prev <- root; first.v
 42 | 
 43 |   let take_last root =
 44 |     let last = root.prev in
 45 |     root.prev <- last.prev; last.prev.next <- root; last.v
 46 | 
 47 |   let take ~sat root = (* O(n) *)
 48 |     let rec loop pred n = match n.v with
 49 |     | None -> None
 50 |     | Some v when sat v -> n.next.prev <- n.prev; n.prev.next <- n.next; n.v
 51 |     | Some _ -> loop pred n.next
 52 |     in
 53 |     loop pred root.next
 54 | 
 55 |   let of_list vs = let l = make () in List.iter (add_last l) vs; l
 56 | end
 57 | 
 58 | (* Fiber ids *)
 59 | 
 60 | module Id = struct
 61 |   type t = int
 62 |   let nil = 0
 63 |   let equal = Int.equal
 64 |   let compare = Int.compare
 65 |   let pp ppf id = Format.fprintf ppf "%03d" id
 66 |   let make =
 67 |     let id = Atomic.make (nil + 1) in
 68 |     fun () -> Atomic.fetch_and_add id 1
 69 | end
 70 | 
 71 | module Id_set = Set.Make (Id)
 72 | 
 73 | (* Core fiber model definitions.
 74 | 
 75 |    XXX the datastructures and the set of effects can likely be streamlined
 76 |    we went for straightforward implementation for now. It needs more thinking
 77 |    that has been done here especially for being friendly to a multi domain
 78 |    work stealing scheduler. *)
 79 | 
 80 | exception Cancelled
 81 | 
 82 | module Private = struct
 83 |   type priority = Low | Normal | High
 84 |   type handle = V : 'a fiber -> handle [@@unboxed] (* existential fiber *)
 85 |   and 'a fiber =
 86 |     { id : Id.t; (* fiber unique id *)
 87 |       only_main : bool; (* If [true] only schedule on the main thread. *)
 88 |       priority : priority; (* hint, must be refined by prio of awaited_by *)
 89 |       mutable cancelled : bool; (* only ever moves from [false] to [true]. *)
 90 |       mutable non_cancelling_blocks : bool; (* no cancel notif. on blocks *)
 91 |       mutable awaited_by : Id_set.t; (* Possibly still awaited by these. *)
 92 |       mutable still_in_scope : handle list; (* to await before returning *)
 93 |       mutable returns : ('a, exn * Printexc.raw_backtrace) Either.t; }
 94 | 
 95 |   type await =
 96 |     { mutable fibers : handle list; (* at least one of these will return *)
 97 |       all : bool; (* return only all when all return *) }
 98 | 
 99 |   type 'a async =
100 |     { only_main : bool; (* force scheduling on the main thread. *)
101 |       func_priority : priority option; (* None is the caller's priority. *)
102 |       func : unit -> 'a (* function to run asynchronously *) }
103 | 
104 |   type 'a block =
105 |     { block : handle -> unit; (* called to register the blocking fiber *)
106 |       cancel : handle -> bool; (* called if cancelled during the block *)
107 |       return : handle -> 'a (* called to return from the block *) }
108 | 
109 |   type _ Effect.t +=
110 |   | Async : 'a async -> 'a fiber Effect.t (* Request an async fun call *)
111 |   | Await : await -> unit Effect.t (* Await on fibers *)
112 |   | Block : 'a block -> 'a Effect.t (* Block the executing fiber *)
113 |   | Cancel : handle option -> unit Effect.t (* Cancel a fiber *)
114 |   | Return : unit Effect.t (* Notify the executing fiber can return or raise *)
115 |   | Self : handle Effect.t (* Ask for the executing fiber *)
116 |   | Yield : unit Effect.t (* Cooperatively suspend the executing fiber *)
117 | 
118 |   let running = (* Stub value tested for physical equality by is_running *)
119 |     let exception N in Either.Right (N, Printexc.get_raw_backtrace ())
120 | 
121 |   let is_running f = f.returns == running
122 |   let is_cancelled_exn f = match f.returns with
123 |   | Either.Right (Cancelled, _) -> true | _ -> false
124 | 
125 |   (* Formatters *)
126 | 
127 |   let pp_any_value ppf v = Format.fprintf ppf "<%a>" pp_uchar "abstr"
128 |   let pp_cancelled ppf c = pp_uchar ppf (if c then "∅" else "φ")
129 |   let pp_priority ppf p =
130 |     pp_uchar ppf (match p with Normal -> " " | Low -> "↓" | High -> "↑")
131 | 
132 |   let pp_value pp_v ppf f =
133 |     if is_running f then pp_uchar ppf "⟳" else match f.returns with
134 |     | Either.Left v -> Format.fprintf ppf "%a" pp_v v
135 |     | Either.Right (e, _) -> Format.pp_print_string ppf (Printexc.to_string e)
136 | 
137 |   let pp_id ppf f =
138 |     Format.fprintf ppf "[%a%a%a]"
139 |       pp_cancelled f.cancelled pp_priority f.priority Id.pp f.id
140 | 
141 |   let pp' pp_v ppf f =
142 |     Format.fprintf ppf "@[<1>[%a%a%a %a]@]"
143 |       pp_cancelled f.cancelled pp_priority f.priority Id.pp f.id
144 |       (pp_value pp_v) f
145 | 
146 |   let pp ppf f = pp' pp_any_value ppf f
147 | 
148 |   module Handle = struct
149 |     type t = handle = V : 'a fiber -> t [@@unboxed]
150 |     let self () = Effect.perform Self
151 |     let id (V f) = f.id
152 |     let priority (V f) = f.priority
153 |     let cancelled (V f) = f.cancelled
154 |     let is_running (V f) = is_running f
155 |     let is_cancelled_exn (V f) = is_cancelled_exn f
156 |     let equal (V f0) (V f1) = Id.equal f0.id f1.id
157 |     let compare (V f0) (V f1) = Id.compare f0.id f1.id
158 |     let list fs = (* Technically Fun.id *) List.map (fun f -> (V f)) fs
159 |     let pp ppf (V f) = pp ppf f
160 |   end
161 | 
162 |   (* Fibers *)
163 | 
164 |   let id f = f.id
165 |   let priority f = f.priority
166 |   let cancelled f = f.cancelled
167 |   let handle f = V f
168 | 
169 |   let make_fiber ~only_main ~cancelled ~priority =
170 |     { id = Id.make (); only_main; priority; cancelled;
171 |       non_cancelling_blocks = false; awaited_by = Id_set.empty;
172 |       still_in_scope = []; returns = running; }
173 | 
174 |   let do_fiber_return f = (* Returns the result of [f] after it ended *)
175 |     assert (not (is_running f));
176 |     match f.returns with
177 |     | Either.Left v -> v
178 |     | Either.Right (exn, bt) -> Printexc.raise_with_backtrace exn bt
179 | 
180 |   let attach_fiber ~scope:(V f) (V sub as sub') =
181 |     (* This associates sub to the scope of fiber [f]. *)
182 |     assert (is_running f); assert (is_running sub);
183 |     (* Pruning avoids the list to grow unbounded on long running fibers.
184 |        This is because fibers do not have a reference on their parent
185 |        to remove themselves from still_in_scope. XXX Perhaps we should
186 |        consider adding a parent field to fibers to avoid any gc problem of
187 |        long running parents holding on terminated fibers for too long. *)
188 |     let prune (V f as f') = if is_running f then Some f' else None in
189 |     sub.cancelled <- f.cancelled;
190 |     f.still_in_scope <- sub' :: List.filter_map prune f.still_in_scope
191 | 
192 |   let run_scope f func () =
193 |     (* Wraps fiber [f]'s body [func] for execution. It implements
194 |        the structured concurrency aspect. *)
195 |     let finish_scope f =
196 |       if f.still_in_scope <> []
197 |       then Effect.perform (Await { fibers = f.still_in_scope; all = true });
198 |       f.still_in_scope <- [];
199 |     in
200 |     match func () with
201 |     | v -> finish_scope f; f.returns <- Left v; Effect.perform Return
202 |     | exception exn ->
203 |         let bt = Printexc.get_raw_backtrace () in
204 |         if is_asynchronous_exn exn then Printexc.raise_with_backtrace exn bt;
205 |         finish_scope f; f.returns <- Right (exn, bt); Effect.perform Return
206 | end
207 | 
208 | (* Fibers *)
209 | 
210 | include Private
211 | 
212 | type 'a t = 'a fiber
213 | 
214 | let async ?(only_main = false) ?priority:func_priority func =
215 |   Effect.perform (Async {only_main; func_priority; func})
216 | 
217 | let from_val v = async (Fun.const v)
218 | let yield () = Effect.perform Yield
219 | let poll f = if is_running f then None else Some (do_fiber_return f)
220 | 
221 | (* Cancelling *)
222 | 
223 | let cancel f =
224 |   if not f.cancelled && is_running f then Effect.perform (Cancel (Some (V f)))
225 | 
226 | let self_cancel () = Effect.perform (Cancel None)
227 | let self_is_cancelled () = let V f = Effect.perform Self in f.cancelled
228 | let self_check_cancellation () = if self_is_cancelled () then raise Cancelled
229 | 
230 | (* Awaiting *)
231 | 
232 | let invalid_empty_list () = invalid_arg "Cannot await an empty list of fibers"
233 | 
234 | let await f =
235 |   if is_running f then Effect.perform (Await {fibers = [V f]; all = true});
236 |   do_fiber_return f
237 | 
238 | let await_all fs =
239 |   Effect.perform (Await {fibers = Handle.list fs; all = true});
240 |   List.map do_fiber_return fs
241 | 
242 | let await_first fs =
243 |   Effect.perform (Await {fibers = Handle.list fs; all = false});
244 |   let rec loop acc = function
245 |   | [] -> invalid_empty_list ()
246 |   | f :: fs ->
247 |       if is_running f then loop (f :: acc) fs else
248 |       let v = do_fiber_return f in (* N.B. may raise *)
249 |       v, List.rev_append acc fs
250 |   in
251 |   loop [] fs
252 | 
253 | let await_either f0 f1 =
254 |   Effect.perform (Await {fibers = [V f0; V f1]; all = false});
255 |   if is_running f1
256 |   then Either.Left (do_fiber_return f0)
257 |   else Either.Right (do_fiber_return f1)
258 | 
259 | (* Picking *)
260 | 
261 | let rec pick_first fs =
262 |   if fs = [] then invalid_empty_list () else
263 |   begin
264 |     Effect.perform (Await {fibers = Handle.list fs; all = false});
265 |     let rec loop acc = function
266 |     | [] ->
267 |         if acc = [] then raise Cancelled else
268 |         pick_first (List.rev acc)
269 |     | f :: fs ->
270 |         if is_running f then loop (f :: acc) fs else
271 |         if is_cancelled_exn f then loop acc fs else
272 |         let fs = List.rev_append acc fs in
273 |         let () = List.iter cancel fs in
274 |         do_fiber_return f (* N.B. may raise *)
275 |     in
276 |     loop [] fs
277 |   end
278 | 
279 | let pick_either f0 f1 =
280 |   Effect.perform (Await {fibers = [V f0; V f1]; all = false});
281 |   if not (is_running f0) then begin
282 |     if is_cancelled_exn f0
283 |     then Either.Right (await f1)
284 |     else (cancel f1; Either.Left (do_fiber_return f0))
285 |   end else begin
286 |     assert (not (is_running f1));
287 |     if is_cancelled_exn f1
288 |     then Either.Left (await f0)
289 |     else (cancel f0; Either.Right (do_fiber_return f1))
290 |   end
291 | 
292 | (* Blocking *)
293 | 
294 | let block ~block ~cancel ~return =
295 |   Effect.perform (Block { block; cancel; return })
296 | 
297 | let self_non_cancelling_blocks func =
298 |   let V f = Effect.perform Self in
299 |   let before = f.non_cancelling_blocks in
300 |   let finally () = f.non_cancelling_blocks <- before in
301 |   f.non_cancelling_blocks <- true;
302 |   Fun.protect ~finally func
303 | 
304 | type unblock = poll:bool -> Handle.t option
305 | 
306 | let never_unblock ~poll:_ = None
307 | let unblocks = function
308 | | [] -> never_unblock
309 | | us ->
310 |     let count = List.length us in
311 |     let us = Circular_list.of_list us in
312 |     fun ~poll -> (* FIXME doesn't work for [poll:false] *)
313 |       let rec find_first rem_to_check us =
314 |         if rem_to_check = 0 then None else
315 |         let u = Circular_list.take_first us |> Option.get in
316 |         match u ~poll with
317 |         | None -> Circular_list.add_last us u; find_first (rem_to_check - 1) us
318 |         | Some _ as ret -> Circular_list.add_last us u; ret
319 |       in
320 |       find_first count us
321 | 
322 | (* Trapping exceptions *)
323 | 
324 | let trap_user_exn f = async @@ fun () -> try Ok (await f) with
325 | | exn ->
326 |     let bt = Printexc.get_raw_backtrace () in
327 |     if is_asynchronous_exn exn || exn = Cancelled
328 |     then Printexc.raise_with_backtrace exn bt else Error (exn, bt)
329 | 
330 | let trap_cancelled f = async @@ fun () -> try Some (await f) with
331 | | Cancelled -> None
332 | 
333 | let trap_any_exn f = async @@ fun () -> try Ok (Some (await f)) with
334 | | Cancelled -> Ok None
335 | | exn ->
336 |     let bt = Printexc.get_raw_backtrace () in
337 |     if is_asynchronous_exn exn
338 |     then Printexc.raise_with_backtrace exn bt
339 |     else Error (exn, bt)
340 | 
341 | (* Built-in scheduler *)
342 | 
343 | module Scheduler = struct
344 | 
345 |   (* Single domain for now. *)
346 | 
347 |   module Id_map = Map.Make (Id)
348 | 
349 |   type blocked =
350 |   | Block : 'a block * ('a, unit) Effect.Deep.continuation -> blocked
351 |   | Await : Handle.t * await * (unit, unit) Effect.Deep.continuation -> blocked
352 | 
353 |   type t =
354 |     { mutable current : handle;
355 |       (* A fiber is never in [s.todo] and [s.blocked] at the same time. *)
356 |       todo : (handle * (unit -> unit)) Circular_list.t;
357 |       mutable blocked :
358 |         (* This won't work cheaply with multiple domains, both cancelling
359 |            and awating needs to know where a given fiber is blocked. *)
360 |         blocked Id_map.t;
361 |       unblock : unblock; }
362 | 
363 |   let make ?(domains = Domain.recommended_domain_count ()) ~unblock current =
364 |     { current; todo = Circular_list.make (); blocked = Id_map.empty; unblock }
365 | 
366 |   let current s = s.current
367 |   let set_current s f = s.current <- f
368 |   let has_blocked s = not (Id_map.is_empty s.blocked)
369 |   let add_block s f b k =
370 |     s.blocked <- Id_map.add (Handle.id f) (Block (b, k)) s.blocked
371 | 
372 |   let add_await s f a k =
373 |     s.blocked <- Id_map.add (Handle.id f) (Await (f, a, k)) s.blocked
374 | 
375 |   let resume f k () = Effect.Deep.continue k ()
376 |   let resume_with_exn f k exn () = Effect.Deep.discontinue k exn
377 |   let resume_block f block k () =
378 |     assert (Handle.is_running f);
379 |     match block.return f with
380 |     | v -> Effect.Deep.continue k v
381 |     | exception exn -> Effect.Deep.discontinue k exn
382 | 
383 |   let schedule_first s work = ignore (Circular_list.add_first s.todo work)
384 |   let schedule_last s work = ignore (Circular_list.add_last s.todo work)
385 |   let schedule_unblocked_block s f =
386 |     assert (Handle.is_running f);
387 |     let schedule_and_remove = function
388 |     | Some (Block (block, k)) ->
389 |         schedule_last s (f, (resume_block f block k)); None
390 |     | _ ->
391 |         invalid_argf
392 |           "unblock function error: returned a non blocked fiber %a"
393 |           Id.pp (Handle.id f)
394 |     in
395 |     s.blocked <- Id_map.update (Handle.id f) schedule_and_remove s.blocked
396 | 
397 |   let schedule_block_cancel_raise s f exn k =
398 |     s.blocked <- Id_map.remove (Handle.id f) s.blocked;
399 |     schedule_last s (f, (resume_with_exn f k exn))
400 | 
401 |   let schedule_blocked_awaiting s (V finished) =
402 |     let schedule_blocked_await id = match Id_map.find_opt id s.blocked with
403 |     | Some (Await (((V af as af'), await, k))) ->
404 |         if not await.all then begin
405 |           let update_awaited_by (V f) =
406 |             f.awaited_by <- Id_set.remove af.id f.awaited_by;
407 |           in
408 |           List.iter update_awaited_by await.fibers;
409 |           s.blocked <- Id_map.remove id s.blocked;
410 |           schedule_last s (af', (resume af k));
411 |         end else begin
412 |           let not_id (V f) = not (Id.equal f.id finished.id) in
413 |             await.fibers <- List.filter not_id await.fibers;
414 |             if await.fibers <> [] then () else
415 |             (s.blocked <- Id_map.remove id s.blocked;
416 |              schedule_last s (af', (resume af k)));
417 |           end
418 |       | None -> ()
419 |       | Some (Block _) -> assert false
420 |     in
421 |     Id_set.iter schedule_blocked_await finished.awaited_by;
422 |     finished.awaited_by <- Id_set.empty
423 | 
424 |   let rec schedule_cancel_scope s (V f) =
425 |     (* We propogate in depth first order. *)
426 |     f.cancelled <- true;
427 |     if f.non_cancelling_blocks then () else
428 |     begin match Id_map.find_opt f.id s.blocked with
429 |     | Some (Block (block, k)) ->
430 |         begin match block.cancel (V f) with
431 |         | false -> ()
432 |         | true -> schedule_block_cancel_raise s (V f) Cancelled k
433 |         | exception exn ->
434 |             let bt = Printexc.get_raw_backtrace () in
435 |             if is_asynchronous_exn exn
436 |             then Printexc.raise_with_backtrace exn bt
437 |             else schedule_block_cancel_raise s (V f) exn k
438 |         end
439 |     | None | Some (Await (_, _, _)) -> ()
440 |     end;
441 |     List.iter (schedule_cancel_scope s) f.still_in_scope
442 | 
443 |   let rec exec_next_todo s () =
444 |     let rec schedule_unblocked_fibers s = match s.unblock ~poll:true with
445 |     | None -> ()
446 |     | Some f -> schedule_unblocked_block s f; schedule_unblocked_fibers s
447 |     in
448 |     schedule_unblocked_fibers s;
449 |     match Circular_list.take_first s.todo with
450 |     | Some (fiber, k) -> set_current s fiber; k ()
451 |     | None when not (has_blocked s) -> ()
452 |     | None ->
453 |         match s.unblock ~poll:false with
454 |         | Some f -> schedule_unblocked_block s f; exec_next_todo s ()
455 |         | None ->
456 |             (* We could end up busy waiting here, let's relax. *)
457 |             Domain.cpu_relax ();
458 |             exec_next_todo s ()
459 | 
460 |   (* Effect handlers *)
461 | 
462 |   type 'a handler = ('a, unit) Effect.Deep.continuation -> unit
463 | 
464 |   let do_async s exec { only_main; func_priority = prio; func } k =
465 |     let current = current s in
466 |     let priority = Option.value ~default:(Handle.priority current) prio in
467 |     let cancelled = (Handle.cancelled current) in
468 |     let f = make_fiber ~only_main ~cancelled ~priority in
469 |     let run_scope = run_scope f func in
470 |     attach_fiber ~scope:current (V f);
471 |     schedule_last s (V f, fun () -> exec s run_scope);
472 |     Effect.Deep.continue k f
473 | 
474 |   let do_yield s k =
475 |     let current = current s in
476 |     schedule_last s (current, (resume current k));
477 |     exec_next_todo s ()
478 | 
479 |   let do_cancel s what k =
480 |     let current = current s in
481 |     let f = match what with None -> current | Some fiber -> fiber in
482 |     if not (Handle.cancelled f) then schedule_cancel_scope s f;
483 |     schedule_first s (current, (resume current k));
484 |     exec_next_todo s ()
485 | 
486 |   let do_block s block k =
487 |     let current = current s in
488 |     match block.block current with
489 |     | exception exn -> Effect.Deep.discontinue k exn
490 |     | () -> add_block s current block k; exec_next_todo s ()
491 | 
492 |   let do_await s await k =
493 |     let current = current s in
494 |     let rec loop await acc = function
495 |     | (V f as f') :: fs when is_running f -> loop await (f' :: acc) fs
496 |     | f :: fs (* f returned *) -> if await.all then loop await acc fs else None
497 |     | [] -> if acc = [] then None else Some { await with fibers = acc }
498 |     in
499 |     begin match loop await [] await.fibers with
500 |     | None -> (* no need to block *)
501 |         schedule_first s (current, (resume current k))
502 |     | Some await ->
503 |         let update_awaited_by (V f) =
504 |           f.awaited_by <- Id_set.add (Handle.id current) f.awaited_by;
505 |         in
506 |         let () = List.iter update_awaited_by await.fibers in
507 |         let await = (Await (current, await, k)) in
508 |         s.blocked <- Id_map.add (Handle.id current) await s.blocked
509 |     end;
510 |     exec_next_todo s ()
511 | 
512 |   let do_self s k = Effect.Deep.continue k s.current
513 |   let do_return s k =
514 |     let current = current s in
515 |     schedule_blocked_awaiting s current;
516 |     schedule_first s (current, (resume current k));
517 |     exec_next_todo s ()
518 | 
519 |   let run ?domains ~unblock func =
520 |     let rec exec : t -> (unit -> unit) -> unit = fun s f ->
521 |       let retc = exec_next_todo s in
522 |       let exnc = raise in
523 |       let effc (type c) (e : c Effect.t) = match e with
524 |       | Yield -> Some (do_yield s : c handler)
525 |       | Async async -> Some (do_async s exec async : c handler)
526 |       | Cancel what -> Some (do_cancel s what : c handler)
527 |       | Block block -> Some (do_block s block : c handler)
528 |       | Await await -> Some (do_await s await : c handler)
529 |       | Self -> Some (do_self s : c handler)
530 |       | Return -> Some (do_return s : c handler)
531 |       | e -> None
532 |       in
533 |       Effect.Deep.match_with f () { Effect.Deep.retc; exnc; effc }
534 |     in
535 |     let main = make_fiber ~only_main:true ~cancelled:false ~priority:Normal in
536 |     let scope = run_scope main func in
537 |     let s = make ~unblock ?domains (V main) in
538 |     exec s scope;
539 |     assert (not (has_blocked s));
540 |     assert (not (is_running main));
541 |     do_fiber_return main
542 | end
543 | 
544 | let main ?domains ~unblock f =
545 |   let domains = match domains with
546 |   | Some _ as d -> d
547 |   | None ->
548 |       let var = Sys.getenv_opt "AFFECT_DOMAIN_COUNT" in
549 |       Option.join @@ (Option.map int_of_string_opt var)
550 |   in
551 |   Scheduler.run ?domains ~unblock f
552 | 


--------------------------------------------------------------------------------