|
| 1 | +(* |
| 2 | + * Copyright (C) 2023 Thomas Leonard |
| 3 | + * |
| 4 | + * Permission to use, copy, modify, and distribute this software for any |
| 5 | + * purpose with or without fee is hereby granted, provided that the above |
| 6 | + * copyright notice and this permission notice appear in all copies. |
| 7 | + * |
| 8 | + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES |
| 9 | + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF |
| 10 | + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR |
| 11 | + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES |
| 12 | + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN |
| 13 | + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF |
| 14 | + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. |
| 15 | + *) |
| 16 | + |
| 17 | +open Eio.Std |
| 18 | + |
| 19 | +[@@@alert "-unstable"] |
| 20 | + |
| 21 | +module Fd = Eio_unix.Fd |
| 22 | + |
| 23 | +(* Run an event loop in the current domain, using [fn x] as the root fiber. *) |
| 24 | +let run_event_loop fn x = |
| 25 | + Sched.with_sched @@ fun sched -> |
| 26 | + let open Effect.Deep in |
| 27 | + let extra_effects : _ effect_handler = { |
| 28 | + effc = fun (type a) (e : a Effect.t) : ((a, Sched.exit) continuation -> Sched.exit) option -> |
| 29 | + match e with |
| 30 | + | Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k (Time.mono_clock : Eio.Time.Mono.t)) |
| 31 | + | Eio_unix.Private.Socket_of_fd (sw, close_unix, unix_fd) -> Some (fun k -> |
| 32 | + let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in |
| 33 | + (* TODO: On Windows, if the FD from Unix.pipe () is passed this will fail *) |
| 34 | + (try Unix.set_nonblock unix_fd with Unix.Unix_error (Unix.ENOTSOCK, _, _) -> ()); |
| 35 | + continue k (Flow.of_fd fd :> Eio_unix.socket) |
| 36 | + ) |
| 37 | + | Eio_unix.Private.Socketpair (sw, domain, ty, protocol) -> Some (fun k -> |
| 38 | + match |
| 39 | + let unix_a, unix_b = Unix.socketpair ~cloexec:true domain ty protocol in |
| 40 | + let a = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_a in |
| 41 | + let b = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_b in |
| 42 | + Unix.set_nonblock unix_a; |
| 43 | + Unix.set_nonblock unix_b; |
| 44 | + (Flow.of_fd a :> Eio_unix.socket), (Flow.of_fd b :> Eio_unix.socket) |
| 45 | + with |
| 46 | + | r -> continue k r |
| 47 | + | exception Unix.Unix_error (code, name, arg) -> |
| 48 | + discontinue k (Err.wrap code name arg) |
| 49 | + ) |
| 50 | + | Eio_unix.Private.Pipe sw -> Some (fun k -> |
| 51 | + match |
| 52 | + let r, w = Low_level.pipe ~sw in |
| 53 | + let source = (Flow.of_fd r :> Eio_unix.source) in |
| 54 | + let sink = (Flow.of_fd w :> Eio_unix.sink) in |
| 55 | + (source, sink) |
| 56 | + with |
| 57 | + | r -> continue k r |
| 58 | + | exception Unix.Unix_error (code, name, arg) -> |
| 59 | + discontinue k (Err.wrap code name arg) |
| 60 | + ) |
| 61 | + | _ -> None |
| 62 | + } |
| 63 | + in |
| 64 | + Sched.run ~extra_effects sched fn x |
| 65 | + |
| 66 | +let v = object |
| 67 | + inherit Eio.Domain_manager.t |
| 68 | + |
| 69 | + method run_raw fn = |
| 70 | + let domain = ref None in |
| 71 | + Eio.Private.Suspend.enter (fun _ctx enqueue -> |
| 72 | + domain := Some (Domain.spawn (fun () -> Fun.protect fn ~finally:(fun () -> enqueue (Ok ())))) |
| 73 | + ); |
| 74 | + Domain.join (Option.get !domain) |
| 75 | + |
| 76 | + method run fn = |
| 77 | + let domain = ref None in |
| 78 | + Eio.Private.Suspend.enter (fun ctx enqueue -> |
| 79 | + let cancelled, set_cancelled = Promise.create () in |
| 80 | + Eio.Private.Fiber_context.set_cancel_fn ctx (Promise.resolve set_cancelled); |
| 81 | + domain := Some (Domain.spawn (fun () -> |
| 82 | + Fun.protect (run_event_loop (fun () -> fn ~cancelled)) |
| 83 | + ~finally:(fun () -> enqueue (Ok ())))) |
| 84 | + ); |
| 85 | + Domain.join (Option.get !domain) |
| 86 | +end |
0 commit comments