├── .dockerignore ├── .gitattributes ├── .github └── workflows │ └── main.yml ├── .gitignore ├── CHANGES.md ├── CODE_OF_CONDUCT.md ├── Dockerfile ├── HACKING.md ├── LICENSE.md ├── Makefile ├── README.md ├── bench.Dockerfile ├── bench ├── bench_buf_read.ml ├── bench_cancel.ml ├── bench_condition.ml ├── bench_copy.ml ├── bench_fd.ml ├── bench_fstat.ml ├── bench_http.ml ├── bench_mutex.ml ├── bench_promise.ml ├── bench_semaphore.ml ├── bench_stat.ml ├── bench_stream.ml ├── bench_systhread.ml ├── bench_yield.ml ├── dune ├── main.ml └── metric.ml ├── doc ├── dune ├── multicore.md ├── prelude.ml ├── rationale.md └── traces │ ├── Makefile │ ├── both-posix.fxt │ ├── both-posix.svg │ ├── cancel-posix.fxt │ ├── cancel-posix.svg │ ├── multicore-posix.fxt │ ├── multicore-posix.svg │ ├── net-posix.fxt │ ├── net-posix.svg │ ├── switch-mock.fxt │ └── switch-mock.svg ├── dune ├── dune-project ├── eio.opam ├── eio_linux.opam ├── eio_linux.opam.template ├── eio_main.opam ├── eio_main.opam.template ├── eio_posix.opam ├── eio_windows.opam ├── eio_windows.opam.template ├── examples ├── both │ ├── dune │ └── main.ml ├── capsicum │ ├── dune │ └── main.ml ├── fs │ ├── dune │ └── main.ml ├── hello │ ├── dune │ └── main.ml ├── net │ ├── client.ml │ ├── dune │ ├── main.ml │ └── server.ml ├── signals │ ├── dune │ └── main.ml └── trace │ ├── dune │ └── main.ml ├── fuzz ├── dune ├── fuzz_buf_read.ml ├── fuzz_buf_read.mli ├── fuzz_buf_write.ml ├── fuzz_buf_write.mli └── fuzz_inherit_fds.ml ├── lib_eio ├── buf_read.ml ├── buf_read.mli ├── buf_write.ml ├── buf_write.mli ├── condition.ml ├── condition.mli ├── core │ ├── broadcast.ml │ ├── broadcast.mli │ ├── cancel.ml │ ├── cells.ml │ ├── cells.mli │ ├── debug.ml │ ├── dune │ ├── eio__core.ml │ ├── eio__core.mli │ ├── exn.ml │ ├── fiber.ml │ ├── promise.ml │ ├── single_waiter.ml │ ├── single_waiter.mli │ ├── suspend.ml │ ├── switch.ml │ ├── trace.ml │ └── trace.mli ├── domain_manager.ml ├── domain_manager.mli ├── dune ├── eio.ml ├── eio.mli ├── eio_mutex.ml ├── eio_mutex.mli ├── executor_pool.ml ├── executor_pool.mli ├── file.ml ├── file.mli ├── flow.ml ├── flow.mli ├── fs.ml ├── hook.ml ├── lazy.ml ├── lazy.mli ├── mock │ ├── action.ml │ ├── backend.ml │ ├── backend.mli │ ├── clock.ml │ ├── clock.mli │ ├── domain_manager.ml │ ├── domain_manager.mli │ ├── dune │ ├── eio_mock.ml │ ├── eio_mock.mli │ ├── flow.ml │ ├── handler.ml │ └── net.ml ├── net.ml ├── net.mli ├── path.ml ├── path.mli ├── pool.ml ├── pool.mli ├── process.ml ├── process.mli ├── resource.ml ├── resource.mli ├── runtime_events │ ├── dune │ ├── eio_runtime_events.ml │ └── eio_runtime_events.mli ├── sem_state.ml ├── semaphore.ml ├── semaphore.mli ├── std.ml ├── std.mli ├── stream.ml ├── stream.mli ├── sync.ml ├── sync.mli ├── tests │ ├── broadcast.md │ ├── dscheck │ │ ├── atomic.ml │ │ ├── dune │ │ ├── eio_mutex.ml │ │ ├── fake_sched.ml │ │ ├── fake_sched.mli │ │ ├── simple_cqs.ml │ │ ├── test_cells.ml │ │ ├── test_condition.ml │ │ ├── test_pool.ml │ │ ├── test_rcfd.ml │ │ ├── test_semaphore.ml │ │ ├── test_sync.ml │ │ └── unix.ml │ ├── dune │ ├── semaphore.md │ ├── sync.md │ └── trace.md ├── time.ml ├── time.mli ├── unix │ ├── cap.c │ ├── cap.ml │ ├── cap.mli │ ├── dune │ ├── eio_unix.ml │ ├── eio_unix.mli │ ├── fd.ml │ ├── fd.mli │ ├── fork_action.c │ ├── fork_action.ml │ ├── fork_action.mli │ ├── include │ │ └── fork_action.h │ ├── inherit_fds.ml │ ├── inherit_fds.mli │ ├── net.ml │ ├── net.mli │ ├── pi.ml │ ├── pi.mli │ ├── primitives.h │ ├── private.ml │ ├── process.ml │ ├── process.mli │ ├── rcfd.ml │ ├── rcfd.mli │ ├── resource.ml │ ├── stubs.c │ ├── thread_pool.ml │ ├── thread_pool.mli │ └── types.ml ├── utils │ ├── dla.ml │ ├── dla.mli │ ├── dune │ ├── eio_utils.ml │ ├── lf_queue.ml │ ├── lf_queue.mli │ ├── suspended.ml │ ├── zzz.ml │ └── zzz.mli ├── waiters.ml └── waiters.mli ├── lib_eio_linux ├── dune ├── eio_linux.ml ├── eio_linux.mli ├── eio_stubs.c ├── err.ml ├── flow.ml ├── flow.mli ├── low_level.ml ├── low_level.mli ├── primitives.h ├── sched.ml └── tests │ ├── basic_eio_linux.ml │ ├── bench_noop.ml │ ├── dune │ ├── eurcp.ml │ ├── eurcp_lib.ml │ ├── fd_sharing.md │ ├── spawn.md │ └── test.ml ├── lib_eio_posix ├── domain_mgr.ml ├── dune ├── eio_posix.ml ├── eio_posix.mli ├── eio_posix_stubs.c ├── err.ml ├── flow.ml ├── fs.ml ├── include │ ├── discover.ml │ └── dune ├── low_level.ml ├── low_level.mli ├── net.ml ├── path.ml ├── path.mli ├── primitives.h ├── process.ml ├── sched.ml ├── sched.mli ├── test │ ├── dune │ ├── open_beneath.ml │ ├── path.md │ ├── poll.md │ ├── spawn.md │ └── test_await.ml └── time.ml ├── lib_eio_windows ├── domain_mgr.ml ├── dune ├── eio_windows.ml ├── eio_windows.mli ├── eio_windows_stubs.c ├── err.ml ├── flow.ml ├── fs.ml ├── include │ ├── discover.ml │ └── dune ├── low_level.ml ├── low_level.mli ├── net.ml ├── sched.ml ├── sched.mli ├── test │ ├── dune │ ├── test.ml │ ├── test_fs.ml │ └── test_net.ml ├── time.ml └── unix_cstruct.ml ├── lib_main ├── dune ├── eio_main.ml ├── eio_main.mli ├── linux_backend.disabled.ml ├── linux_backend.enabled.ml ├── posix_backend.disabled.ml ├── posix_backend.enabled.ml ├── windows_backend.disabled.ml └── windows_backend.enabled.ml ├── stress ├── dune ├── stress_proc.ml ├── stress_release.ml └── stress_semaphore.ml └── tests ├── buf_reader.md ├── buf_write.md ├── condition.md ├── debug.md ├── domains.md ├── dune ├── executor_pool.md ├── exn.md ├── fd_passing.md ├── fiber.md ├── flow.md ├── fs.md ├── lazy.md ├── lf_queue.md ├── mocks.md ├── mutex.md ├── network.md ├── nounix ├── dune └── nounix.ml ├── pool.md ├── process.md ├── random.md ├── semaphore.md ├── signal.md ├── stream.md ├── switch.md ├── sync.md ├── time.md └── trace.md /.dockerignore: -------------------------------------------------------------------------------- 1 | Dockerfile 2 | _build 3 | .git 4 | **/*.swp 5 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # To work around MDX issues 2 | README.md text eol=lf 3 | CHANGES.md whitespace=-blank-at-eol 4 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | pull_request: 5 | push: 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: 13 | - macos-latest 14 | ocaml-compiler: 15 | - 5.2.x 16 | local-packages: 17 | - eio eio_posix eio_main 18 | 19 | runs-on: ${{ matrix.os }} 20 | 21 | steps: 22 | - name: Checkout code 23 | uses: actions/checkout@v3 24 | 25 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 26 | uses: ocaml/setup-ocaml@v2 27 | with: 28 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 29 | opam-local-packages: 30 | opam-disable-sandboxing: true 31 | 32 | - run: opam --cli=2.1 pin -yn --with-version=dev . 33 | - run: opam install ${{ matrix.local-packages }} --deps-only --with-test 34 | - run: opam install ${{ matrix.local-packages }} --with-test 35 | windows: 36 | runs-on: windows-latest 37 | 38 | steps: 39 | - name: Checkout code 40 | uses: actions/checkout@v3 41 | 42 | - name: Set-up OCaml 43 | uses: ocaml/setup-ocaml@v2 44 | with: 45 | opam-pin: false 46 | opam-depext: false 47 | ocaml-compiler: ocaml.5.2.0,ocaml-option-mingw 48 | opam-repositories: | 49 | dra27: https://github.com/dra27/opam-repository.git#windows-5.0 50 | normal: https://github.com/ocaml/opam-repository.git 51 | # --with-version=dev is not available, and --with-test also tries running tests for packages (like MDX) which fail... 52 | - run: | 53 | opam pin -yn eio.dev . 54 | opam pin -yn eio_windows.dev . 55 | opam pin -yn eio_main.dev . 56 | opam install eio eio_windows eio_main --deps-only --with-test 57 | - run: opam exec -- dune build 58 | - run: opam exec -- dune runtest 59 | - run: opam exec -- dune exec -- ./examples/net/main.exe 60 | - run: opam exec -- dune exec -- ./examples/fs/main.exe 61 | docker: 62 | runs-on: ubuntu-latest 63 | steps: 64 | - uses: actions/checkout@v2 65 | - name: Build the Docker image 66 | run: docker build . 67 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | _opam 3 | .ocamlformat 4 | .*.swp 5 | *.install 6 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). 4 | 5 | # Enforcement 6 | 7 | This project follows the OCaml Code of Conduct 8 | [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). 9 | 10 | To report any violations, please contact: 11 | 12 | * Patrick Ferris 13 | * Sudha Parimala 14 | * Thomas Leonard 15 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:debian-11-ocaml-5.2 2 | # Make sure we're using opam-2.1: 3 | RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam 4 | # Ensure opam-repository is up-to-date: 5 | RUN cd opam-repository && git pull -q origin 97de3378749cf8d2d70a5d710d310e5cc17c9dea && opam update 6 | # Install utop for interactive use: 7 | RUN opam install utop fmt 8 | # Install Eio's dependencies (adding just the opam files first to help with caching): 9 | RUN mkdir eio 10 | WORKDIR eio 11 | COPY *.opam ./ 12 | RUN opam pin --with-version=dev . -yn 13 | RUN opam install --deps-only eio_main eio_linux eio 14 | # Build Eio: 15 | COPY . ./ 16 | RUN opam install eio_main 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all bench stress 2 | 3 | all: 4 | dune build @runtest @all 5 | 6 | bench: 7 | dune exec -- ./bench/main.exe 8 | 9 | test_posix: 10 | EIO_BACKEND=posix dune runtest 11 | 12 | dscheck: 13 | dune exec -- ./lib_eio/tests/dscheck/test_condition.exe 14 | dune exec -- ./lib_eio/tests/dscheck/test_rcfd.exe 15 | dune exec -- ./lib_eio/tests/dscheck/test_sync.exe 16 | dune exec -- ./lib_eio/tests/dscheck/test_semaphore.exe 17 | dune exec -- ./lib_eio/tests/dscheck/test_cells.exe 18 | 19 | stress: 20 | dune exec -- ./stress/stress_proc.exe 21 | dune exec -- ./stress/stress_semaphore.exe 22 | dune exec -- ./stress/stress_release.exe 23 | 24 | docker: 25 | docker build -t eio . 26 | -------------------------------------------------------------------------------- /bench.Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:debian-11-ocaml-5.2 2 | # Make sure we're using opam-2.1: 3 | RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam 4 | # Ensure opam-repository is up-to-date: 5 | RUN cd opam-repository && git pull -q origin 97de3378749cf8d2d70a5d710d310e5cc17c9dea && opam update 6 | # Install Eio's dependencies (adding just the opam files first to help with caching): 7 | RUN mkdir eio 8 | WORKDIR eio 9 | COPY *.opam ./ 10 | RUN opam pin --with-version=dev . -yn 11 | RUN opam install eio_main yojson 12 | # Build the benchmarks: 13 | COPY . ./ 14 | RUN opam exec -- dune build ./bench 15 | -------------------------------------------------------------------------------- /bench/bench_buf_read.ml: -------------------------------------------------------------------------------- 1 | module R = Eio.Buf_read 2 | 3 | let run _env = 4 | let test_data = String.make 100_000_000 'x' in 5 | let r = R.of_string test_data in 6 | let t0 = Unix.gettimeofday () in 7 | let i = ref 0 in 8 | try 9 | while true do 10 | assert (R.any_char r = 'x'); 11 | incr i 12 | done; 13 | assert false 14 | with End_of_file -> 15 | let t1 = Unix.gettimeofday () in 16 | let time = t1 -. t0 in 17 | let bytes_per_second = float (String.length test_data) /. time in 18 | [Metric.create "any_char" (`Float bytes_per_second) "bytes/s" "Parsing a long string one character at a time"] 19 | -------------------------------------------------------------------------------- /bench/bench_cancel.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | (* The main domain spawns two other domains, connected to each by a stream. 4 | It keeps reading from whichever stream is ready first, cancelling the other read. 5 | This tests the time needed to set up and tear down cancellation contexts and 6 | tests that cancellation can happen in parallel with success. *) 7 | 8 | let n_iters = 100_000 9 | 10 | let run_sender stream = 11 | for i = 1 to n_iters do 12 | Eio.Stream.add stream i 13 | done 14 | 15 | let run_bench ?domain_mgr ~clock () = 16 | let stream1 = Eio.Stream.create 1 in 17 | let stream2 = Eio.Stream.create 1 in 18 | let run_sender stream () = 19 | match domain_mgr with 20 | | Some dm -> Eio.Domain_manager.run dm (fun () -> run_sender stream) 21 | | None -> run_sender stream 22 | in 23 | let name str = 24 | match domain_mgr with 25 | | Some _ -> str ^ "/separate domains" 26 | | None -> str ^ "/single domain" 27 | in 28 | Gc.full_major (); 29 | let t0 = Eio.Time.now clock in 30 | try 31 | Switch.run (fun sw -> 32 | Fiber.fork ~sw (run_sender stream1); 33 | Fiber.fork ~sw (run_sender stream2); 34 | for _ = 1 to n_iters do 35 | ignore @@ 36 | Fiber.first 37 | (fun () -> Eio.Stream.take stream1) 38 | (fun () -> Eio.Stream.take stream2) 39 | done; 40 | raise Exit 41 | ) 42 | with Exit -> 43 | let t1 = Eio.Time.now clock in 44 | let time_total = t1 -. t0 in 45 | let time_per_iter = time_total /. float n_iters in 46 | Metric.create 47 | (name "take-first") 48 | (`Float (1e9 *. time_per_iter)) "ns" 49 | "Time to take from one of two streams" 50 | 51 | let main ~domain_mgr ~clock = 52 | let m1 = run_bench ~clock () in 53 | let m2 = run_bench ~domain_mgr ~clock () in 54 | [m1; m2] 55 | 56 | let run env = 57 | main 58 | ~domain_mgr:(Eio.Stdenv.domain_mgr env) 59 | ~clock:(Eio.Stdenv.clock env) 60 | -------------------------------------------------------------------------------- /bench/bench_condition.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | (* A publisher keeps updating a counter and signalling a condition. 4 | Two consumers read the counter whenever they get a signal. 5 | The producer stops after signalling [target], and the consumers stop after seeing it. *) 6 | 7 | let n_iters = 100 8 | let target = 100000 9 | 10 | let run_publisher cond v = 11 | for i = 1 to target do 12 | Atomic.set v i; 13 | (* traceln "set %d" i; *) 14 | Eio.Condition.broadcast cond 15 | done 16 | 17 | let run_consumer cond v = 18 | try 19 | while true do 20 | Fiber.both 21 | (fun () -> Eio.Condition.await_no_mutex cond) 22 | (fun () -> 23 | let current = Atomic.get v in 24 | (* traceln "saw %d" current; *) 25 | if current = target then raise Exit 26 | ) 27 | done 28 | with Exit -> () 29 | 30 | let run_bench ?domain_mgr ~clock () = 31 | let cond = Eio.Condition.create () in 32 | let v = Atomic.make 0 in 33 | let run_consumer () = 34 | match domain_mgr with 35 | | Some dm -> Eio.Domain_manager.run dm (fun () -> run_consumer cond v) 36 | | None -> run_consumer cond v 37 | in 38 | let name str = 39 | match domain_mgr with 40 | | Some _ -> str ^ "_domain" 41 | | None -> str 42 | in 43 | Gc.full_major (); 44 | let t0 = Eio.Time.now clock in 45 | for _ = 1 to n_iters do 46 | Fiber.all [ 47 | run_consumer; 48 | run_consumer; 49 | (fun () -> run_publisher cond v); 50 | ]; 51 | done; 52 | let t1 = Eio.Time.now clock in 53 | let time_total = t1 -. t0 in 54 | let time_per_iter = time_total /. float n_iters in 55 | Metric.create (name "broadcast") (`Float (1e3 *. time_per_iter)) "ms" "Time to signal a new value" 56 | 57 | let main ~domain_mgr ~clock = [ 58 | run_bench ~clock (); 59 | run_bench ~domain_mgr ~clock (); 60 | ] 61 | 62 | let run env = 63 | main 64 | ~domain_mgr:(Eio.Stdenv.domain_mgr env) 65 | ~clock:(Eio.Stdenv.clock env) 66 | -------------------------------------------------------------------------------- /bench/bench_copy.ml: -------------------------------------------------------------------------------- 1 | (* A client opens a connection to an echo service and sends a load of data via it. *) 2 | 3 | open Eio.Std 4 | 5 | let chunk_size = 1 lsl 16 6 | let n_chunks = 10000 7 | let n_bytes = n_chunks * chunk_size 8 | 9 | let run_client sock = 10 | Fiber.both 11 | (fun () -> 12 | let chunk = Cstruct.create chunk_size in 13 | for _ = 1 to n_chunks do 14 | Eio.Flow.write sock [chunk] 15 | done; 16 | Eio.Flow.shutdown sock `Send 17 | ) 18 | (fun () -> 19 | let chunk = Cstruct.create chunk_size in 20 | for _ = 1 to n_chunks do 21 | Eio.Flow.read_exact sock chunk 22 | done 23 | ) 24 | 25 | let time name service = 26 | Switch.run ~name @@ fun sw -> 27 | let client_sock, server_sock = Eio_unix.Net.socketpair_stream ~sw () in 28 | let t0 = Unix.gettimeofday () in 29 | Fiber.both 30 | (fun () -> service server_sock) 31 | (fun () -> run_client client_sock); 32 | let t1 = Unix.gettimeofday () in 33 | let time = t1 -. t0 in 34 | let bytes_per_second = float n_bytes /. time in 35 | traceln "%s: %.2f MB/s" name (bytes_per_second /. 1024. /. 1024.); 36 | Metric.create name (`Float bytes_per_second) "bytes/s" (name ^ " Flow.copy") 37 | 38 | let run _env = 39 | [ 40 | time "default" (fun sock -> Eio.Flow.copy sock sock); 41 | time "buf_read" (fun sock -> 42 | let r = Eio.Buf_read.of_flow sock ~initial_size:(64 * 1024) ~max_size:(64 * 1024) |> Eio.Buf_read.as_flow in 43 | Eio.Flow.copy r sock); 44 | ] 45 | -------------------------------------------------------------------------------- /bench/bench_fd.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let time label len fn = 4 | let t0 = Unix.gettimeofday () in 5 | fn (); 6 | let t1 = Unix.gettimeofday () in 7 | Metric.create 8 | label 9 | (`Float (float len /. (t1 -. t0) /. (2. ** 30.))) "GB/s" 10 | "Reading from /dev/zero using a single FD" 11 | 12 | let main ~domain_mgr zero = 13 | let iters = 100_000 in 14 | let len = 64 * 1024 in 15 | let n_fibers = 4 in 16 | let n_domains = 4 in 17 | let buf = Cstruct.create len in 18 | let run1 () = 19 | for _ = 1 to iters do Eio.Flow.read_exact zero buf done 20 | in 21 | [time "fibers:1" (iters * len) run1; 22 | time (Fmt.str "fibers:%d" n_fibers) (iters * n_fibers * len) (fun () -> 23 | Switch.run @@ fun sw -> 24 | for _ = 1 to n_fibers do 25 | Fiber.fork ~sw run1 26 | done 27 | ); 28 | time (Fmt.str "domains:%d" n_domains) (iters * n_domains * len) (fun () -> 29 | Switch.run @@ fun sw -> 30 | for _ = 1 to n_domains do 31 | Fiber.fork ~sw (fun () -> Eio.Domain_manager.run domain_mgr run1) 32 | done 33 | )] 34 | 35 | let ( / ) = Eio.Path.( / ) 36 | 37 | let run env = 38 | Eio.Path.with_open_in (env#fs / "/dev/zero") (main ~domain_mgr:env#domain_mgr) 39 | -------------------------------------------------------------------------------- /bench/bench_fstat.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let ( / ) = Eio.Path.( / ) 4 | 5 | let n_stat = 100000 6 | 7 | let run_fiber file = 8 | for _ = 1 to n_stat do 9 | let info = (Eio.File.stat file).kind in 10 | assert (info = `Regular_file) 11 | done 12 | 13 | let run env = 14 | Eio.Path.with_open_out ~create:(`If_missing 0o600) (env#cwd / "test-stat") @@ fun file -> 15 | [1; 10] |> List.map (fun par -> 16 | let t0 = Unix.gettimeofday () in 17 | Switch.run (fun sw -> 18 | for _ = 1 to par do 19 | Fiber.fork ~sw (fun () -> run_fiber file) 20 | done 21 | ); 22 | let t1 = Unix.gettimeofday () in 23 | let stat_per_s = float (n_stat * par) /. (t1 -. t0) in 24 | let label = Printf.sprintf "n=%d fibers=%d" n_stat par in 25 | Metric.create label (`Float stat_per_s) "stat/s" "Call fstat on an open file" 26 | ) 27 | -------------------------------------------------------------------------------- /bench/bench_mutex.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let v = ref 0 4 | 5 | let run_worker ~iters_per_thread mutex = 6 | for _ = 1 to iters_per_thread do 7 | Eio.Mutex.lock mutex; 8 | let x = !v in 9 | v := x + 1; 10 | Fiber.yield (); 11 | assert (!v = x + 1); 12 | v := x; 13 | Eio.Mutex.unlock mutex; 14 | done 15 | 16 | let run_bench ~domain_mgr ~clock ~use_domains ~iters_per_thread ~threads = 17 | let mutex = Eio.Mutex.create () in 18 | Gc.full_major (); 19 | let t0 = Eio.Time.now clock in 20 | Switch.run (fun sw -> 21 | for _ = 1 to threads do 22 | Fiber.fork ~sw (fun () -> 23 | if use_domains then ( 24 | Eio.Domain_manager.run domain_mgr @@ fun () -> 25 | run_worker ~iters_per_thread mutex 26 | ) else ( 27 | run_worker ~iters_per_thread mutex 28 | ) 29 | ) 30 | done 31 | ); 32 | assert (!v = 0); 33 | let t1 = Eio.Time.now clock in 34 | let time_total = t1 -. t0 in 35 | let n_iters = iters_per_thread * threads in 36 | let time_per_iter = time_total /. float n_iters in 37 | Metric.create 38 | (Printf.sprintf "iterations=%d threads=%d" n_iters threads) 39 | (`Float (1e9 *. time_per_iter)) "ns" "Time to update a shared counter" 40 | 41 | let main ~domain_mgr ~clock = 42 | [false, 1_000_000, 1; 43 | false, 1_000_000, 2; 44 | false, 100_000, 8; 45 | true, 100_000, 1; 46 | true, 10_000, 2; 47 | true, 10_000, 8] 48 | |> List.map (fun (use_domains, iters_per_thread, threads) -> 49 | run_bench ~domain_mgr ~clock ~use_domains ~iters_per_thread ~threads) 50 | 51 | let run env = 52 | main 53 | ~domain_mgr:(Eio.Stdenv.domain_mgr env) 54 | ~clock:(Eio.Stdenv.clock env) 55 | -------------------------------------------------------------------------------- /bench/bench_semaphore.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | (* Simulate other work in the domain, and also prevent it from going to sleep. 4 | Otherwise, we're just measuring how long it takes the OS to wake a sleeping thread. *) 5 | let rec spin () = 6 | Fiber.yield (); 7 | spin () 8 | 9 | let run_bench ~domain_mgr ~clock ~use_domains ~n_iters ~n_resources = 10 | let n_workers = 4 in 11 | let sem = Eio.Semaphore.make n_resources in 12 | let n_pending = Atomic.make n_workers in 13 | let all_started, set_all_started = Promise.create () in 14 | let t0 = ref 0.0 in 15 | let run_worker ~n_iters sem = 16 | Switch.run @@ fun sw -> 17 | Fiber.fork_daemon ~sw spin; 18 | if Atomic.fetch_and_add n_pending (-1) = 1 then ( 19 | Promise.resolve set_all_started (); 20 | t0 := Eio.Time.now clock; 21 | ) else ( 22 | Promise.await all_started 23 | ); 24 | for _ = 1 to n_iters do 25 | Eio.Semaphore.acquire sem; 26 | Fiber.yield (); 27 | Eio.Semaphore.release sem 28 | done 29 | in 30 | let run () = 31 | if use_domains then ( 32 | Eio.Domain_manager.run domain_mgr @@ fun () -> 33 | run_worker ~n_iters sem 34 | ) else ( 35 | run_worker ~n_iters sem 36 | ) 37 | in 38 | Gc.full_major (); 39 | Fiber.all (List.init n_workers (Fun.const run)); 40 | let t1 = Eio.Time.now clock in 41 | let time_total = t1 -. !t0 in 42 | let time_per_iter = time_total /. float n_iters in 43 | Metric.create 44 | (Printf.sprintf "iterations:%d resources:%d" n_iters n_resources) 45 | (`Float (1e9 *. time_per_iter)) "ns" 46 | "Time to acquire a semaphore, yeild, and release it" 47 | 48 | let main ~domain_mgr ~clock = 49 | [false, 100_000, 2; 50 | false, 100_000, 3; 51 | false, 100_000, 4; 52 | true, 10_000, 2; 53 | true, 10_000, 3; 54 | true, 10_000, 4] 55 | |> List.map (fun (use_domains, n_iters, n_resources) -> 56 | run_bench ~domain_mgr ~clock ~use_domains ~n_iters ~n_resources 57 | ) 58 | 59 | let run env = 60 | main 61 | ~domain_mgr:(Eio.Stdenv.domain_mgr env) 62 | ~clock:(Eio.Stdenv.clock env) 63 | -------------------------------------------------------------------------------- /bench/bench_systhread.ml: -------------------------------------------------------------------------------- 1 | (* Measure the overhead of [Eio_unix.run_in_systhread]. *) 2 | 3 | open Eio.Std 4 | 5 | let n_iters = 1000 6 | 7 | let do_syscall () = ignore (Unix.getuid () : int) 8 | 9 | let work () = 10 | for _ = 1 to n_iters do 11 | Eio_unix.run_in_systhread do_syscall 12 | done 13 | 14 | (* Return the average time for one call to [getuid]. *) 15 | let run_domain ~fibers = 16 | let t0 = Unix.gettimeofday () in 17 | Switch.run ~name:"run_domain" (fun sw -> 18 | for _ = 1 to fibers do 19 | Fiber.fork ~sw work 20 | done 21 | ); 22 | let t1 = Unix.gettimeofday () in 23 | (t1 -. t0) /. float n_iters 24 | 25 | let time ~domain_mgr ~baseline ~domains ~fibers = 26 | let overhead t = t /. baseline in 27 | let name = Printf.sprintf "domains:%d fibers:%d" domains fibers in 28 | (* Work-around for https://github.com/ocaml/ocaml/issues/12948 *) 29 | let main_done, set_main_done = Promise.create () in 30 | Switch.run ~name @@ fun sw -> 31 | let times = 32 | List.init (domains - 1) (fun _ -> 33 | Fiber.fork_promise ~sw (fun () -> 34 | Eio.Domain_manager.run domain_mgr (fun () -> 35 | let r = run_domain ~fibers in 36 | Promise.await main_done; 37 | r 38 | ) 39 | ) 40 | ) 41 | in 42 | let my_time = run_domain ~fibers in 43 | Promise.resolve set_main_done (); (* Allow Domain.join to be called *) 44 | let times = 45 | my_time :: List.map Promise.await_exn times 46 | |> List.map (fun t -> t *. 1e6) 47 | in 48 | traceln "%s" name; 49 | times |> List.iteri (fun i t -> 50 | traceln "%d: %.2f us (%.1f times slower)" i t (overhead t) 51 | ); 52 | let avg = (List.fold_left (+.) 0. times) /. float domains in 53 | Metric.create name (`Float avg) "us" name 54 | 55 | let run env = 56 | let domain_mgr = env#domain_mgr in 57 | let baseline = 58 | Eio.Private.Trace.with_span "baseline" @@ fun () -> 59 | let t0 = Unix.gettimeofday () in 60 | for _ = 1 to n_iters do 61 | do_syscall () 62 | done; 63 | let t1 = Unix.gettimeofday () in 64 | ((t1 -. t0) /. float n_iters) *. 1e6 65 | in 66 | traceln "baseline (no systhreads): %.2f us" baseline; 67 | let results = 68 | [ 69 | time ~domains:1 ~fibers:1; 70 | time ~domains:1 ~fibers:2; 71 | time ~domains:1 ~fibers:4; 72 | time ~domains:4 ~fibers:1; 73 | ] 74 | |> List.map (fun f -> f ~domain_mgr ~baseline) 75 | in 76 | Metric.create "blocking" (`Float baseline) "us" "baseline" :: results 77 | -------------------------------------------------------------------------------- /bench/bench_yield.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let n_fibers = [1; 2; (* 3; 4; 5; 10; 20; 30; 40; 50; *) 100; 500; 1000; 10000] 4 | 5 | let main ~clock = 6 | n_fibers |> List.map (fun n_fibers -> 7 | let n_iters = 1000000 / n_fibers in 8 | Gc.full_major (); 9 | let t0 = Eio.Time.now clock in 10 | Switch.run (fun sw -> 11 | for _ = 1 to n_fibers do 12 | Fiber.fork ~sw (fun () -> 13 | for _ = 1 to n_iters do 14 | Fiber.yield () 15 | done 16 | ) 17 | done 18 | ); 19 | let t1 = Eio.Time.now clock in 20 | let time_total = t1 -. t0 in 21 | let n_total = n_fibers * n_iters in 22 | let time_per_iter = time_total /. float n_total in 23 | Metric.create 24 | (Printf.sprintf "fibers:%d" n_fibers) 25 | (`Float (1e9 *. time_per_iter)) "ns" "Time to yield" 26 | ) 27 | 28 | let run env = 29 | main ~clock:(Eio.Stdenv.clock env) 30 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | ; This should be an executable, but dune won't let us associate non-installed executables 2 | ; to packages, so we use this work-around. 3 | (test 4 | (name main) 5 | (package eio_main) 6 | (deps ./main.exe) 7 | (action (progn)) ; Don't run as a test 8 | (libraries eio_main yojson)) 9 | -------------------------------------------------------------------------------- /bench/main.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let benchmarks = [ 4 | "Promise", Bench_promise.run; 5 | "Cancel", Bench_cancel.run; 6 | "Buf_read", Bench_buf_read.run; 7 | "Condition", Bench_condition.run; 8 | "Fiber.yield", Bench_yield.run; 9 | "Mutex", Bench_mutex.run; 10 | "Semaphore", Bench_semaphore.run; 11 | "Stream", Bench_stream.run; 12 | "HTTP", Bench_http.run; 13 | "Eio_unix.Fd", Bench_fd.run; 14 | "File.stat", Bench_fstat.run; 15 | "Path.stat", Bench_stat.run; 16 | "Flow.copy", Bench_copy.run; 17 | "Eio_unix.run_in_systhread", Bench_systhread.run; 18 | ] 19 | 20 | let usage_error () = 21 | let names = List.map fst benchmarks in 22 | Fmt.epr "Usage: main.exe [%a]@." Fmt.(list ~sep:(any " | ") string) names; 23 | exit 1 24 | 25 | let () = 26 | Eio_main.run @@ fun env -> 27 | traceln "Using %s backend" env#backend_id; 28 | let benchmarks = 29 | match Array.to_list Sys.argv with 30 | | [_] -> benchmarks 31 | | [_; name] -> 32 | begin match List.assoc_opt name benchmarks with 33 | | Some run -> [name, run] 34 | | None -> 35 | Fmt.epr "Unknown benchmark %S@." name; 36 | usage_error () 37 | end 38 | | _ -> usage_error () 39 | in 40 | let run (name, fn) = 41 | traceln "Running %s..." name; 42 | let metrics = fn env in 43 | `Assoc [ 44 | "name", `String name; 45 | "metrics", `List metrics; 46 | ] 47 | in 48 | (* The benchmark machine runs an old Docker that blocks pidfd_open *) 49 | (* let uname = Eio.Process.parse_out env#process_mgr Eio.Buf_read.take_all ["uname"; "-a"] in *) 50 | let uname = 51 | let ch = Unix.open_process_in "uname -a" in 52 | let x = input_line ch in 53 | close_in ch; 54 | x 55 | in 56 | Fmt.pr "%a@." (Yojson.Safe.pretty_print ~std:true) @@ `Assoc [ 57 | "config", `Assoc [ 58 | "uname", `String uname; 59 | "backend", `String env#backend_id; 60 | "recommended_domain_count", `Int (Domain.recommended_domain_count ()); 61 | ]; 62 | "results", `List (List.map run benchmarks); 63 | ] 64 | -------------------------------------------------------------------------------- /bench/metric.ml: -------------------------------------------------------------------------------- 1 | let create name value units description : Yojson.Safe.t = 2 | `Assoc [ 3 | "name", `String name; 4 | "value", (value :> Yojson.Safe.t); 5 | "units", `String units; 6 | "description", `String description; 7 | ] 8 | -------------------------------------------------------------------------------- /doc/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package eio_main) 3 | (deps (package eio_main) (env_var "EIO_BACKEND")) 4 | (enabled_if (<> %{os_type} "Win32")) 5 | (files multicore.md)) 6 | -------------------------------------------------------------------------------- /doc/prelude.ml: -------------------------------------------------------------------------------- 1 | #require "eio_main";; 2 | #require "eio.mock";; 3 | 4 | module Eio_main = struct 5 | open Eio.Std 6 | 7 | module Fake_clock = struct 8 | type time = float 9 | type t = unit 10 | let sleep_until () _time = failwith "No sleeping in tests!" 11 | let now _ = 1623940778.27033591 12 | end 13 | 14 | let fake_clock = 15 | let handler = Eio.Time.Pi.clock (module Fake_clock) in 16 | Eio.Resource.T ((), handler) 17 | 18 | let run fn = 19 | (* To avoid non-deterministic output, we run the examples a single domain. *) 20 | let fake_domain_mgr = Eio_mock.Domain_manager.create () in 21 | Eio_main.run @@ fun env -> 22 | fn @@ object 23 | method net = env#net 24 | method stdin = env#stdin 25 | method stdout = env#stdout 26 | method stderr = env#stderr 27 | method cwd = env#cwd 28 | method process_mgr = env#process_mgr 29 | method domain_mgr = fake_domain_mgr 30 | method clock = fake_clock 31 | end 32 | end 33 | 34 | let parse_config (flow : _ Eio.Flow.source) = ignore 35 | -------------------------------------------------------------------------------- /doc/traces/Makefile: -------------------------------------------------------------------------------- 1 | all: both-posix.svg cancel-posix.svg switch-mock.svg net-posix.svg multicore-posix.svg 2 | 3 | %.svg: %.fxt 4 | eio-trace render "$<" 5 | -------------------------------------------------------------------------------- /doc/traces/both-posix.fxt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-multicore/eio/8f7f82d2c12076af8e9b8b365c58ebadaa963b8c/doc/traces/both-posix.fxt -------------------------------------------------------------------------------- /doc/traces/cancel-posix.fxt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-multicore/eio/8f7f82d2c12076af8e9b8b365c58ebadaa963b8c/doc/traces/cancel-posix.fxt -------------------------------------------------------------------------------- /doc/traces/multicore-posix.fxt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-multicore/eio/8f7f82d2c12076af8e9b8b365c58ebadaa963b8c/doc/traces/multicore-posix.fxt -------------------------------------------------------------------------------- /doc/traces/net-posix.fxt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-multicore/eio/8f7f82d2c12076af8e9b8b365c58ebadaa963b8c/doc/traces/net-posix.fxt -------------------------------------------------------------------------------- /doc/traces/switch-mock.fxt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-multicore/eio/8f7f82d2c12076af8e9b8b365c58ebadaa963b8c/doc/traces/switch-mock.fxt -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package eio_main) 3 | (deps (package eio_main) (package kcas) (env_var "EIO_BACKEND")) 4 | (preludes doc/prelude.ml) 5 | (enabled_if (<> %{os_type} "Win32")) 6 | (files README.md)) 7 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.9) 2 | (name eio) 3 | (formatting disabled) 4 | (subst disabled) 5 | (generate_opam_files true) 6 | (source (github ocaml-multicore/eio)) 7 | (license ISC) 8 | (authors "Anil Madhavapeddy" "Thomas Leonard") 9 | (maintainers "anil@recoil.org") 10 | (documentation "https://ocaml-multicore.github.io/eio/") 11 | (package 12 | (name eio) 13 | (synopsis "Effect-based direct-style IO API for OCaml") 14 | (description "An effect-based IO API for multicore OCaml with fibers.") 15 | (conflicts (seq (< 0.3))) 16 | (depends 17 | (ocaml (>= 5.2.0)) 18 | (bigstringaf (>= 0.9.0)) 19 | (cstruct (>= 6.0.1)) 20 | lwt-dllist 21 | (optint (>= 0.1.0)) 22 | (psq (>= 0.2.0)) 23 | (fmt (>= 0.8.9)) 24 | (hmap (>= 0.8.1)) 25 | (domain-local-await (>= 0.1.0)) 26 | (crowbar (and (>= 0.2) :with-test)) 27 | (mtime (>= 2.0.0)) 28 | (mdx (and (>= 2.4.1) :with-test)) 29 | (dscheck (and (>= 0.1.0) :with-test)))) 30 | (package 31 | (name eio_linux) 32 | (synopsis "Eio implementation for Linux using io-uring") 33 | (description "An Eio implementation for Linux using io-uring.") 34 | (allow_empty) ; Work-around for dune bug #6938 35 | (depends 36 | (alcotest (and (>= 1.7.0) :with-test)) 37 | (eio (= :version)) 38 | (mdx (and (>= 2.4.1) :with-test)) 39 | (logs (and (>= 0.7.0) :with-test)) 40 | (fmt (>= 0.8.9)) 41 | (cmdliner (and (>= 1.1.0) :with-test)) 42 | (uring (>= 0.9)))) 43 | (package 44 | (name eio_posix) 45 | (allow_empty) ; Work-around for dune bug #6938 46 | (synopsis "Eio implementation for POSIX systems") 47 | (description "An Eio implementation for most Unix-like platforms") 48 | (depends 49 | (eio (= :version)) 50 | (iomux (>= 0.2)) 51 | (mdx (and (>= 2.4.1) :with-test)) 52 | (conf-bash :with-test) 53 | (fmt (>= 0.8.9)))) 54 | (package 55 | (name eio_windows) 56 | (synopsis "Eio implementation for Windows") 57 | (description "An Eio implementation using OCaml's Unix.select") 58 | (allow_empty) ; Work-around for dune bug #6938 59 | (depends 60 | (eio (= :version)) 61 | (fmt (>= 0.8.9)) 62 | (kcas (and (>= 0.3.0) :with-test)) 63 | (alcotest (and (>= 1.7.0) :with-test)))) 64 | (package 65 | (name eio_main) 66 | (synopsis "Effect-based direct-style IO mainloop for OCaml") 67 | (description "Selects an appropriate Eio backend for the current platform.") 68 | (depends 69 | (mdx (and (>= 2.4.1) :with-test)) 70 | (kcas (and (>= 0.3.0) :with-test)) 71 | (yojson (and (>= 2.0.2) :with-test)) 72 | (eio_linux (and 73 | (= :version) 74 | (= :os "linux") 75 | (or (<> :os-distribution "centos") (> :os-version 7)))) 76 | (eio_posix (and (= :version) (<> :os "win32"))) 77 | (eio_windows (and (= :version) (= :os "win32"))))) 78 | (using mdx 0.2) 79 | -------------------------------------------------------------------------------- /eio.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Effect-based direct-style IO API for OCaml" 4 | description: "An effect-based IO API for multicore OCaml with fibers." 5 | maintainer: ["anil@recoil.org"] 6 | authors: ["Anil Madhavapeddy" "Thomas Leonard"] 7 | license: "ISC" 8 | homepage: "https://github.com/ocaml-multicore/eio" 9 | doc: "https://ocaml-multicore.github.io/eio/" 10 | bug-reports: "https://github.com/ocaml-multicore/eio/issues" 11 | depends: [ 12 | "dune" {>= "3.9"} 13 | "ocaml" {>= "5.2.0"} 14 | "bigstringaf" {>= "0.9.0"} 15 | "cstruct" {>= "6.0.1"} 16 | "lwt-dllist" 17 | "optint" {>= "0.1.0"} 18 | "psq" {>= "0.2.0"} 19 | "fmt" {>= "0.8.9"} 20 | "hmap" {>= "0.8.1"} 21 | "domain-local-await" {>= "0.1.0"} 22 | "crowbar" {>= "0.2" & with-test} 23 | "mtime" {>= "2.0.0"} 24 | "mdx" {>= "2.4.1" & with-test} 25 | "dscheck" {>= "0.1.0" & with-test} 26 | "odoc" {with-doc} 27 | ] 28 | conflicts: [ 29 | "seq" {< "0.3"} 30 | ] 31 | build: [ 32 | [ 33 | "dune" 34 | "build" 35 | "-p" 36 | name 37 | "-j" 38 | jobs 39 | "@install" 40 | "@runtest" {with-test} 41 | "@doc" {with-doc} 42 | ] 43 | ] 44 | dev-repo: "git+https://github.com/ocaml-multicore/eio.git" 45 | -------------------------------------------------------------------------------- /eio_linux.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Eio implementation for Linux using io-uring" 4 | description: "An Eio implementation for Linux using io-uring." 5 | maintainer: ["anil@recoil.org"] 6 | authors: ["Anil Madhavapeddy" "Thomas Leonard"] 7 | license: "ISC" 8 | homepage: "https://github.com/ocaml-multicore/eio" 9 | doc: "https://ocaml-multicore.github.io/eio/" 10 | bug-reports: "https://github.com/ocaml-multicore/eio/issues" 11 | depends: [ 12 | "dune" {>= "3.9"} 13 | "alcotest" {>= "1.7.0" & with-test} 14 | "eio" {= version} 15 | "mdx" {>= "2.4.1" & with-test} 16 | "logs" {>= "0.7.0" & with-test} 17 | "fmt" {>= "0.8.9"} 18 | "cmdliner" {>= "1.1.0" & with-test} 19 | "uring" {>= "0.9"} 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/ocaml-multicore/eio.git" 36 | available: [os = "linux"] 37 | -------------------------------------------------------------------------------- /eio_linux.opam.template: -------------------------------------------------------------------------------- 1 | available: [os = "linux"] 2 | -------------------------------------------------------------------------------- /eio_main.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Effect-based direct-style IO mainloop for OCaml" 4 | description: "Selects an appropriate Eio backend for the current platform." 5 | maintainer: ["anil@recoil.org"] 6 | authors: ["Anil Madhavapeddy" "Thomas Leonard"] 7 | license: "ISC" 8 | homepage: "https://github.com/ocaml-multicore/eio" 9 | doc: "https://ocaml-multicore.github.io/eio/" 10 | bug-reports: "https://github.com/ocaml-multicore/eio/issues" 11 | depends: [ 12 | "dune" {>= "3.9"} 13 | "mdx" {>= "2.4.1" & with-test} 14 | "kcas" {>= "0.3.0" & with-test} 15 | "yojson" {>= "2.0.2" & with-test} 16 | "eio_linux" 17 | {= version & os = "linux" & 18 | (os-distribution != "centos" | os-version > "7")} 19 | "eio_posix" {= version & os != "win32"} 20 | "eio_windows" {= version & os = "win32"} 21 | "odoc" {with-doc} 22 | ] 23 | build: [ 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/ocaml-multicore/eio.git" 37 | x-ci-accept-failures: ["macos-homebrew"] 38 | -------------------------------------------------------------------------------- /eio_main.opam.template: -------------------------------------------------------------------------------- 1 | x-ci-accept-failures: ["macos-homebrew"] 2 | -------------------------------------------------------------------------------- /eio_posix.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Eio implementation for POSIX systems" 4 | description: "An Eio implementation for most Unix-like platforms" 5 | maintainer: ["anil@recoil.org"] 6 | authors: ["Anil Madhavapeddy" "Thomas Leonard"] 7 | license: "ISC" 8 | homepage: "https://github.com/ocaml-multicore/eio" 9 | doc: "https://ocaml-multicore.github.io/eio/" 10 | bug-reports: "https://github.com/ocaml-multicore/eio/issues" 11 | depends: [ 12 | "dune" {>= "3.9"} 13 | "eio" {= version} 14 | "iomux" {>= "0.2"} 15 | "mdx" {>= "2.4.1" & with-test} 16 | "conf-bash" {with-test} 17 | "fmt" {>= "0.8.9"} 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/ocaml-multicore/eio.git" 34 | -------------------------------------------------------------------------------- /eio_windows.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Eio implementation for Windows" 4 | description: "An Eio implementation using OCaml's Unix.select" 5 | maintainer: ["anil@recoil.org"] 6 | authors: ["Anil Madhavapeddy" "Thomas Leonard"] 7 | license: "ISC" 8 | homepage: "https://github.com/ocaml-multicore/eio" 9 | doc: "https://ocaml-multicore.github.io/eio/" 10 | bug-reports: "https://github.com/ocaml-multicore/eio/issues" 11 | depends: [ 12 | "dune" {>= "3.9"} 13 | "eio" {= version} 14 | "fmt" {>= "0.8.9"} 15 | "kcas" {>= "0.3.0" & with-test} 16 | "alcotest" {>= "1.7.0" & with-test} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/ocaml-multicore/eio.git" 33 | #available: [os = "win32"] 34 | -------------------------------------------------------------------------------- /eio_windows.opam.template: -------------------------------------------------------------------------------- 1 | #available: [os = "win32"] 2 | -------------------------------------------------------------------------------- /examples/both/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries eio_main)) 4 | -------------------------------------------------------------------------------- /examples/both/main.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let () = 4 | Eio_main.run @@ fun _env -> 5 | Fiber.both 6 | (fun () -> for x = 1 to 3 do traceln "x = %d" x; Fiber.yield () done) 7 | (fun () -> for y = 1 to 3 do traceln "y = %d" y; Fiber.yield () done) 8 | -------------------------------------------------------------------------------- /examples/capsicum/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries eio_main)) 4 | -------------------------------------------------------------------------------- /examples/capsicum/main.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let ( / ) = Eio.Path.( / ) 4 | 5 | let test_eio dir = 6 | traceln "Using the file-system via the directory resource works:"; 7 | let test_file = dir / "capsicum-test.txt" in 8 | traceln "Writing %a..." Eio.Path.pp test_file; 9 | Eio.Path.save test_file "A test file" ~create:(`Exclusive 0o644); 10 | traceln "Read: %S" (Eio.Path.load test_file); 11 | Eio.Path.unlink test_file 12 | 13 | let test_legacy () = 14 | traceln "Bypassing Eio and accessing other resources should fail in Capsicum mode:"; 15 | let ch = open_in "/etc/passwd" in 16 | let len = in_channel_length ch in 17 | let data = really_input_string ch len in 18 | close_in ch; 19 | traceln "Was able to read /etc/passwd:@.%s" (String.trim data) 20 | 21 | let () = 22 | Eio_main.run @@ fun env -> 23 | (* Parse command-line arguments *) 24 | let path = 25 | match Sys.argv with 26 | | [| _; dir |] -> Eio.Stdenv.fs env / dir 27 | | _ -> failwith "Usage: main.exe DIR" 28 | in 29 | if not (Eio.Path.is_directory path) then Fmt.failwith "%a is not a directory" Eio.Path.pp path; 30 | (* Get access to resources before calling cap_enter: *) 31 | Eio.Path.with_open_dir path @@ fun dir -> 32 | traceln "Opened directory %a" Eio.Path.pp path; 33 | (* Switch to capability mode, if possible: *) 34 | begin match Eio_unix.Cap.enter () with 35 | | Ok () -> traceln "Capsicum mode enabled" 36 | | Error `Not_supported -> traceln "!! CAPSICUM PROTECTION NOT AVAILABLE !!" 37 | end; 38 | (* Run tests: *) 39 | test_eio dir; 40 | test_legacy () 41 | -------------------------------------------------------------------------------- /examples/fs/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries eio_main)) 4 | -------------------------------------------------------------------------------- /examples/fs/main.ml: -------------------------------------------------------------------------------- 1 | (* Walk the directory tree rooted at the current directory, 2 | showing a summary for any .mli files. *) 3 | 4 | let ( / ) = Eio.Path.( / ) 5 | 6 | let is_doc_comment = String.starts_with ~prefix:"(** " 7 | 8 | (* Print the first line of [t]'s doc-comment, if any *) 9 | let scan_mli t f = 10 | Eio.Path.with_lines t (fun lines -> 11 | Seq.find is_doc_comment lines 12 | |> Option.iter (fun line -> 13 | let stop = String.index_from_opt line 4 '*' |> Option.value ~default:(String.length line) in 14 | Format.fprintf f "%a: %s@." Eio.Path.pp t (String.sub line 4 (stop - 4)) 15 | ) 16 | ) 17 | 18 | (* Walk the tree rooted at [t] and scan any .mli files found. *) 19 | let rec scan t f = 20 | match Eio.Path.kind ~follow:false t with 21 | | `Directory -> 22 | Eio.Path.read_dir t |> List.iter (function 23 | | "_build" | "_opam" -> () (* Don't examine these directories *) 24 | | item when String.starts_with ~prefix:"." item -> () (* Skip hidden items *) 25 | | item -> scan (t / item) f 26 | ) 27 | | `Regular_file when Filename.check_suffix (snd t) ".mli" -> scan_mli t f 28 | | _ -> () 29 | 30 | let () = 31 | Eio_main.run @@ fun env -> 32 | scan (Eio.Stdenv.cwd env) Format.std_formatter 33 | -------------------------------------------------------------------------------- /examples/hello/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries eio_main)) 4 | -------------------------------------------------------------------------------- /examples/hello/main.ml: -------------------------------------------------------------------------------- 1 | let main ~stdout = 2 | Eio.Flow.copy_string "Hello, world!\n" stdout 3 | 4 | let () = 5 | Eio_main.run @@ fun env -> 6 | main ~stdout:(Eio.Stdenv.stdout env) 7 | -------------------------------------------------------------------------------- /examples/net/client.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | (* Prefix all trace output with "client: " *) 4 | let traceln fmt = traceln ("client: " ^^ fmt) 5 | 6 | module Read = Eio.Buf_read 7 | module Write = Eio.Buf_write 8 | 9 | (* Connect to [addr] on [net], send a message and then read the reply. *) 10 | let run ~net ~addr = 11 | Switch.run ~name:"client" @@ fun sw -> 12 | traceln "Connecting to server at %a..." Eio.Net.Sockaddr.pp addr; 13 | let flow = Eio.Net.connect ~sw net addr in 14 | (* We use a buffered writer here so we can create the message in multiple 15 | steps but still send it efficiently as a single packet: *) 16 | Write.with_flow flow @@ fun to_server -> 17 | Write.string to_server "Hello"; 18 | Write.char to_server ' '; 19 | Write.string to_server "from client\n"; 20 | let reply = Read.(parse_exn take_all) flow ~max_size:100 in 21 | traceln "Got reply %S" reply 22 | -------------------------------------------------------------------------------- /examples/net/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries eio_main)) 4 | -------------------------------------------------------------------------------- /examples/net/main.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8080) 4 | 5 | (* Run a server and a test client, communicating using [net]. *) 6 | let main ~net = 7 | Switch.run ~name:"main" @@ fun sw -> 8 | (* We create the listening socket first so that we can be sure it is ready 9 | as soon as the client wants to use it. *) 10 | let listening_socket = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in 11 | (* Start the server running in a new fiber. 12 | Using [fork_daemon] here means that it will be stopped once the client is done 13 | (we don't wait for it to finish because it will keep accepting new connections forever). *) 14 | Fiber.fork_daemon ~sw (fun () -> Server.run listening_socket); 15 | (* Test the server: *) 16 | Client.run ~net ~addr 17 | 18 | let () = 19 | Eio_main.run @@ fun env -> 20 | main ~net:(Eio.Stdenv.net env) 21 | -------------------------------------------------------------------------------- /examples/net/server.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | (* Prefix all trace output with "server: " *) 4 | let traceln fmt = traceln ("server: " ^^ fmt) 5 | 6 | module Read = Eio.Buf_read 7 | 8 | (* Read one line from [client] and respond with "OK". *) 9 | let handle_client flow addr = 10 | traceln "Accepted connection from %a" Eio.Net.Sockaddr.pp addr; 11 | (* We use a buffered reader because we may need to combine multiple reads 12 | to get a single line (or we may get multiple lines in a single read, 13 | although here we only use the first one). *) 14 | let from_client = Read.of_flow flow ~max_size:100 in 15 | traceln "Received: %S" (Read.line from_client); 16 | Eio.Flow.copy_string "OK" flow 17 | 18 | (* Accept incoming client connections on [socket]. 19 | We can handle multiple clients at the same time. 20 | Never returns (but can be cancelled). *) 21 | let run socket = 22 | Eio.Net.run_server socket handle_client 23 | ~on_error:(traceln "Error handling connection: %a" Fmt.exn) 24 | ~max_connections:1000 25 | -------------------------------------------------------------------------------- /examples/signals/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries eio_main)) 4 | -------------------------------------------------------------------------------- /examples/signals/main.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let load_config () = 4 | (* A real system would load the file and then pass it to the running service 5 | somehow, but we're just demonstrating signal handling so just sleep to 6 | simulate some time taken to load the new configuration. *) 7 | Eio_unix.sleep 2.0 8 | 9 | (* $MDX part-begin=main *) 10 | let main ~config_changed = 11 | Eio.Condition.loop_no_mutex config_changed (fun () -> 12 | traceln "Reading configuration ('kill -SIGHUP %d' to reload)..." (Unix.getpid ()); 13 | load_config (); 14 | traceln "Finished reading configuration"; 15 | None (* Keep waiting for futher changes *) 16 | ) 17 | (* $MDX part-end *) 18 | 19 | let () = 20 | Eio_main.run @@ fun _env -> 21 | let config_changed = Eio.Condition.create () in 22 | let handle_signal (_signum : int) = 23 | (* Warning: we're in a signal handler now. 24 | Most operations are unsafe here, except for Eio.Condition.broadcast! *) 25 | Eio.Condition.broadcast config_changed 26 | in 27 | Sys.set_signal Sys.sighup (Signal_handle handle_signal); 28 | main ~config_changed 29 | -------------------------------------------------------------------------------- /examples/trace/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries eio.runtime_events eio_main)) 4 | -------------------------------------------------------------------------------- /examples/trace/main.ml: -------------------------------------------------------------------------------- 1 | (* This example shows how to trace an Eio program. 2 | 3 | The [main] function creates a listening socket and has a client connect and send a message, 4 | which is handled by a server fiber. 5 | 6 | At the same time, another fiber is displaying trace events. 7 | For simplicity, this example runs the tracer in the same process as the program being traced, 8 | but typically they would be separate processes. *) 9 | 10 | open Eio.Std 11 | 12 | let callbacks = 13 | Runtime_events.Callbacks.create () 14 | (* Uncomment to trace GC events too: *) 15 | (* 16 | ~runtime_begin:(handle (fun f phase -> Fmt.pf f "begin %s" (Runtime_events.runtime_phase_name phase))) 17 | ~runtime_end:(handle (fun f phase -> Fmt.pf f "end %s" (Runtime_events.runtime_phase_name phase))) 18 | *) 19 | ~lost_events:(fun ring n -> traceln "ring %d lost %d events" ring n) 20 | |> Eio_runtime_events.add_callbacks 21 | (fun ring ts e -> 22 | (* Note: don't use traceln here, as it will just generate more log events! *) 23 | Fmt.epr "%9Ld:ring %d: %a@." (Runtime_events.Timestamp.to_int64 ts) ring Eio_runtime_events.pp_event e 24 | ) 25 | (* (see lib_eio/runtime_events/eio_runtime_events.mli for more event types) *) 26 | 27 | (* Read and display trace events from [cursor] until [finished]. *) 28 | let trace ~finished (clock, delay) cursor = 29 | traceln "tracer: starting"; 30 | let rec aux () = 31 | let _ : int = Runtime_events.read_poll cursor callbacks None in 32 | if !finished then ( 33 | traceln "tracer: stopping" 34 | ) else ( 35 | Eio.Time.Mono.sleep clock delay; 36 | aux () 37 | ) 38 | in 39 | aux () 40 | 41 | (* The program to be traced. *) 42 | let main net = 43 | Switch.run ~name:"main" @@ fun sw -> 44 | let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8123) in 45 | let s = Eio.Net.listen ~sw ~backlog:1 ~reuse_addr:true net addr in 46 | Fiber.both 47 | (fun () -> 48 | traceln "server: starting"; 49 | let c, _addr = Eio.Net.accept ~sw s in 50 | traceln "server: got connection from client"; 51 | let msg = Eio.Flow.read_all c in 52 | traceln "server: read %S from socket" msg 53 | ) 54 | (fun () -> 55 | traceln "client: connecting socket..."; 56 | let c = Eio.Net.connect ~sw net addr in 57 | Eio.Flow.copy_string "Hello" c; 58 | Eio.Flow.close c 59 | ) 60 | 61 | (* Enable tracing then run the [main] and [trace] fibers. *) 62 | let () = 63 | Runtime_events.start (); 64 | let cursor = Runtime_events.create_cursor None in (* Create a in-process cursor *) 65 | Eio_main.run @@ fun env -> 66 | let finished = ref false in 67 | Fiber.both 68 | (fun () -> trace ~finished (env#mono_clock, 0.01) cursor) 69 | (fun () -> main env#net; finished := true) 70 | -------------------------------------------------------------------------------- /fuzz/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (package eio) 3 | (libraries cstruct crowbar fmt eio eio.mock eio.unix) 4 | (names fuzz_buf_read fuzz_buf_write fuzz_inherit_fds)) 5 | -------------------------------------------------------------------------------- /fuzz/fuzz_buf_read.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-multicore/eio/8f7f82d2c12076af8e9b8b365c58ebadaa963b8c/fuzz/fuzz_buf_read.mli -------------------------------------------------------------------------------- /fuzz/fuzz_buf_write.ml: -------------------------------------------------------------------------------- 1 | (* Run a random sequence of write operations on an [Eio.Buf_write]. 2 | Check that the expected data gets written to the flow. *) 3 | 4 | module W = Eio.Buf_write 5 | 6 | let initial_size = 10 7 | 8 | type op = Op : string * (W.t -> unit) -> op (* Expected string, writer *) 9 | 10 | let cstruct = 11 | Crowbar.(map [bytes; int; int]) (fun s off len -> 12 | if String.length s = 0 then Cstruct.empty 13 | else ( 14 | let off = min (abs off) (String.length s) in 15 | let len = min (abs len) (String.length s - off) in 16 | Cstruct.of_string s ~off ~len 17 | ) 18 | ) 19 | 20 | let op = 21 | let label (name, gen) = Crowbar.with_printer (fun f (Op (s, _)) -> Fmt.pf f "%s:%S" name s) gen in 22 | Crowbar.choose @@ List.map label [ 23 | "string", Crowbar.(map [bytes]) (fun s -> Op (s, (fun t -> W.string t s))); 24 | "cstruct", Crowbar.(map [cstruct]) (fun cs -> Op (Cstruct.to_string cs, (fun t -> W.cstruct t cs))); 25 | "schedule_cstruct", Crowbar.(map [cstruct]) (fun cs -> Op (Cstruct.to_string cs, (fun t -> W.schedule_cstruct t cs))); 26 | "yield", Crowbar.const @@ Op ("", (fun _ -> Eio.Fiber.yield ())); 27 | "flush", Crowbar.const @@ Op ("", W.flush); 28 | "pause", Crowbar.const @@ Op ("", W.pause); 29 | "unpause", Crowbar.const @@ Op ("", W.unpause); 30 | ] 31 | 32 | let random ops close = 33 | Eio_mock.Backend.run @@ fun _ -> 34 | let b = Buffer.create 100 in 35 | let flow = Eio.Flow.buffer_sink b in 36 | let expected = ref [] in 37 | W.with_flow flow ~initial_size (fun t -> 38 | let perform (Op (s, write)) = 39 | expected := s :: !expected; 40 | write t 41 | in 42 | List.iter perform ops; 43 | if close then W.close t 44 | ); 45 | let expected = String.concat "" (List.rev !expected) in 46 | Crowbar.check_eq ~pp:Fmt.Dump.string (Buffer.contents b) expected 47 | 48 | let () = 49 | Crowbar.(add_test ~name:"random ops" [list op; bool] random) 50 | -------------------------------------------------------------------------------- /fuzz/fuzz_buf_write.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-multicore/eio/8f7f82d2c12076af8e9b8b365c58ebadaa963b8c/fuzz/fuzz_buf_write.mli -------------------------------------------------------------------------------- /fuzz/fuzz_inherit_fds.ml: -------------------------------------------------------------------------------- 1 | module I = Eio_unix__Inherit_fds 2 | 3 | module S = Set.Make(Int) 4 | 5 | let pp f = function 6 | | `Cloexec x -> Fmt.pf f "close %d" x 7 | | `Keep x -> Fmt.pf f "keep %d" x 8 | 9 | let rec has_duplicates ~seen = function 10 | | [] -> false 11 | | (dst, _) :: _ when S.mem dst seen -> true 12 | | (dst, _) :: xs -> has_duplicates xs ~seen:(S.add dst seen) 13 | 14 | let inherit_fds mapping = 15 | let has_duplicates = has_duplicates ~seen:S.empty mapping in 16 | let fds = Hashtbl.create 10 in 17 | mapping |> List.iter (fun (_dst, src) -> 18 | Hashtbl.add fds src (`Cloexec src); 19 | ); 20 | match I.plan mapping with 21 | | exception (Invalid_argument _) -> assert has_duplicates 22 | | plan -> 23 | assert (not has_duplicates); 24 | plan |> List.iter (fun {I.src; dst} -> 25 | (* Fmt.pr "%d -> %d@." src dst; *) 26 | let v = 27 | match Hashtbl.find fds src with 28 | | `Cloexec x | `Keep x -> 29 | if dst = -1 then `Cloexec x else `Keep x 30 | in 31 | Hashtbl.add fds dst v 32 | ); 33 | mapping |> List.iter (fun (dst, src) -> 34 | let v = Hashtbl.find fds dst in 35 | Crowbar.check_eq ~pp v (`Keep src); 36 | Hashtbl.remove fds dst; 37 | ); 38 | fds |> Hashtbl.iter (fun x -> function 39 | | `Cloexec _ -> () 40 | | `Keep _ -> Fmt.failwith "%d should be close-on-exec!" x 41 | ) 42 | 43 | let fd = Crowbar.range 10 (* Restrict range to make cycles more likely *) 44 | 45 | let () = 46 | Crowbar.(add_test ~name:"inherit_fds" [list (pair fd fd)] inherit_fds) 47 | -------------------------------------------------------------------------------- /lib_eio/core/broadcast.mli: -------------------------------------------------------------------------------- 1 | (** A lock-free queue of waiters that should all be resumed at once. 2 | 3 | This uses {!Cells} internally. *) 4 | 5 | type t 6 | 7 | type request 8 | (** A handle to a pending request that can be used to cancel it. *) 9 | 10 | val create : unit -> t 11 | (** [create ()] is a fresh broadcast queue. *) 12 | 13 | val suspend : t -> (unit -> unit) -> request option 14 | (** [suspend t fn] arranges for [fn ()] to be called on {!resume_all}. 15 | 16 | [fn ()] may be called from the caller's context, or by [resume_all], 17 | so it needs to be able to cope with running in any context where that 18 | can run. For example, [fn] must be safe to call from a signal handler 19 | if [resume_all] can be called from one. [fn] must not raise. 20 | 21 | The returned request can be used to cancel. It can be [None] in the 22 | (unlikely) event that [t] got resumed before the function returned. *) 23 | 24 | val resume_all : t -> unit 25 | (** [resume_all t] calls all non-cancelled callbacks attached to [t], 26 | in the order in which they were suspended. 27 | 28 | This function is lock-free and can be used safely even from a signal handler or GC finalizer. *) 29 | 30 | val cancel : request -> bool 31 | (** [cancel request] attempts to remove a pending request. 32 | 33 | It returns [true] if the request was cancelled, or [false] if it got 34 | resumed before that could happen. *) 35 | 36 | val dump : Format.formatter -> t -> unit 37 | (** Display the internal state of a queue, for debugging. *) 38 | -------------------------------------------------------------------------------- /lib_eio/core/debug.ml: -------------------------------------------------------------------------------- 1 | type traceln = { 2 | traceln : 'a. ?__POS__:string * int * int * int -> ('a, Format.formatter, unit, unit) format4 -> 'a; 3 | } [@@unboxed] 4 | 5 | let traceln_key : traceln Fiber.key = Fiber.create_key () 6 | 7 | let traceln_mutex = Mutex.create () 8 | 9 | let default_traceln ?__POS__:pos fmt = 10 | let k go = 11 | Trace.with_span "traceln" @@ fun () -> 12 | let b = Buffer.create 512 in 13 | let f = Format.formatter_of_buffer b in 14 | go f; 15 | Option.iter (fun (file, lnum, _, _) -> Format.fprintf f " [%s:%d]" file lnum) pos; 16 | Format.pp_close_box f (); 17 | Format.pp_print_flush f (); 18 | let msg = Buffer.contents b in 19 | Trace.log msg; 20 | let lines = String.split_on_char '\n' msg in 21 | Mutex.lock traceln_mutex; 22 | Fun.protect ~finally:(fun () -> Mutex.unlock traceln_mutex) @@ fun () -> 23 | List.iter (Printf.eprintf "+%s\n") lines; 24 | flush stderr 25 | in 26 | Format.kdprintf k ("@[" ^^ fmt) 27 | 28 | let get () = 29 | match Fiber.get traceln_key with 30 | | Some traceln -> traceln 31 | | None 32 | | exception (Effect.Unhandled _) -> { traceln = default_traceln } 33 | 34 | let with_trace_prefix prefix fn = 35 | let { traceln } = get () in 36 | let traceln ?__POS__ fmt = 37 | traceln ?__POS__ ("%t" ^^ fmt) prefix 38 | in 39 | Fiber.with_binding traceln_key { traceln } fn 40 | 41 | let traceln ?__POS__ fmt = 42 | let { traceln } = get () in 43 | traceln ?__POS__ fmt 44 | 45 | type t = < 46 | traceln : traceln Fiber.key; 47 | > 48 | 49 | let v = object 50 | method traceln = traceln_key 51 | end 52 | -------------------------------------------------------------------------------- /lib_eio/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio__core) 3 | (public_name eio.core) 4 | (libraries hmap lwt-dllist fmt optint eio.runtime_events)) 5 | -------------------------------------------------------------------------------- /lib_eio/core/eio__core.ml: -------------------------------------------------------------------------------- 1 | module Promise = Promise 2 | module Fiber = Fiber 3 | module Switch = Switch 4 | module Cancel = Cancel 5 | module Exn = Exn 6 | module Private = struct 7 | module Suspend = Suspend 8 | module Cells = Cells 9 | module Broadcast = Broadcast 10 | module Single_waiter = Single_waiter 11 | module Trace = Trace 12 | module Fiber_context = Cancel.Fiber_context 13 | module Debug = Debug 14 | 15 | module Effects = struct 16 | type 'a enqueue = 'a Suspend.enqueue 17 | type _ Effect.t += 18 | | Suspend = Suspend.Suspend 19 | | Fork = Fiber.Fork 20 | | Get_context = Cancel.Get_context 21 | end 22 | end 23 | -------------------------------------------------------------------------------- /lib_eio/core/single_waiter.ml: -------------------------------------------------------------------------------- 1 | type 'a state = 2 | | Running 3 | | Sleeping of (('a, exn) result -> unit) 4 | 5 | type 'a t = 'a state ref 6 | 7 | let create () = ref Running 8 | 9 | let wake t v = 10 | match !t with 11 | | Running -> false 12 | | Sleeping fn -> 13 | t := Running; 14 | fn v; 15 | true 16 | 17 | let wake_if_sleeping t = 18 | ignore (wake t (Ok ()) : bool) 19 | 20 | let await t op id = 21 | let x = 22 | Suspend.enter op @@ fun ctx enqueue -> 23 | Cancel.Fiber_context.set_cancel_fn ctx (fun ex -> 24 | t := Running; 25 | enqueue (Error ex) 26 | ); 27 | t := Sleeping (fun x -> 28 | Cancel.Fiber_context.clear_cancel_fn ctx; 29 | t := Running; 30 | enqueue x 31 | ) 32 | in 33 | Trace.get id; 34 | x 35 | 36 | let await_protect t op id = 37 | let x = 38 | Suspend.enter_unchecked op @@ fun _ctx enqueue -> 39 | t := Sleeping (fun x -> t := Running; enqueue x) 40 | in 41 | Trace.get id; 42 | x 43 | -------------------------------------------------------------------------------- /lib_eio/core/single_waiter.mli: -------------------------------------------------------------------------------- 1 | (** Allows a single fiber to wait to be notified by another fiber in the same domain. 2 | If multiple fibers need to wait at once, or the notification comes from another domain, 3 | this can't be used. *) 4 | 5 | type 'a t 6 | (** A handle representing a fiber that might be sleeping. 7 | It is either in the Running or Sleeping state. *) 8 | 9 | val create : unit -> 'a t 10 | (** [create ()] is a new waiter, initially in the Running state. *) 11 | 12 | val wake : 'a t -> ('a, exn) result -> bool 13 | (** [wake t v] resumes [t]'s fiber with value [v] and returns [true] if it was sleeping. 14 | If [t] is Running then this just returns [false]. *) 15 | 16 | val wake_if_sleeping : unit t -> unit 17 | (** [wake_if_sleeping] is [ignore (wake t (Ok ()))]. *) 18 | 19 | val await : 'a t -> string -> Trace.id -> 'a 20 | (** [await t op id] suspends the calling fiber, changing [t]'s state to Sleeping. 21 | If the fiber is cancelled, a cancel exception is raised. 22 | [op] and [id] are used for tracing. *) 23 | 24 | val await_protect : 'a t -> string -> Trace.id -> 'a 25 | (** [await_protect] is like {!await}, but the sleep cannot be cancelled. *) 26 | -------------------------------------------------------------------------------- /lib_eio/core/suspend.ml: -------------------------------------------------------------------------------- 1 | type 'a enqueue = ('a, exn) result -> unit 2 | type _ Effect.t += Suspend : (Cancel.fiber_context -> 'a enqueue -> unit) -> 'a Effect.t 3 | 4 | let enter_unchecked op fn = 5 | Trace.suspend_fiber op; 6 | Effect.perform (Suspend fn) 7 | 8 | let enter op fn = 9 | enter_unchecked op @@ fun fiber enqueue -> 10 | match Cancel.Fiber_context.get_error fiber with 11 | | None -> fn fiber enqueue 12 | | Some ex -> enqueue (Error ex) 13 | -------------------------------------------------------------------------------- /lib_eio/core/trace.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | type id = int 4 | 5 | let id_chunk_size = 1024 6 | 7 | let next_id_chunk = Atomic.make 0 8 | 9 | let next_id_key = 10 | Domain.DLS.new_key (fun () -> Atomic.fetch_and_add next_id_chunk id_chunk_size) 11 | 12 | let mint_id () = 13 | let next_id_local = Domain.DLS.get next_id_key in 14 | let next_id_local_succ = 15 | if ((next_id_local + 1) mod id_chunk_size) = 0 then 16 | (* we're out of local IDs *) 17 | Atomic.fetch_and_add next_id_chunk id_chunk_size 18 | else 19 | next_id_local + 1 20 | in 21 | Domain.DLS.set next_id_key next_id_local_succ; 22 | next_id_local 23 | 24 | module RE = Eio_runtime_events 25 | 26 | let add_event = Runtime_events.User.write 27 | 28 | let create_obj ?label id ty = 29 | add_event RE.create_obj (id, ty); 30 | Option.iter (fun l -> add_event RE.name (id, l)) label 31 | 32 | let create_cc id ty = 33 | add_event RE.create_cc (id, ty) 34 | 35 | let create_fiber ~cc id = 36 | add_event RE.create_fiber (id, cc) 37 | 38 | let log = add_event RE.log 39 | let name id x = add_event RE.name (id, x) 40 | let enter_span = add_event RE.enter_span 41 | let exit_span = add_event RE.exit_span 42 | let fiber = add_event RE.fiber 43 | let suspend_domain = add_event RE.suspend_domain 44 | let try_get = add_event RE.try_get 45 | let get = add_event RE.get 46 | let put = add_event RE.put 47 | let exit_fiber = add_event RE.exit_fiber 48 | let exit_cc = add_event RE.exit_cc 49 | let error id ex = add_event RE.error (id, ex) 50 | let suspend_fiber op = add_event RE.suspend_fiber op 51 | let domain_spawn ~parent = add_event RE.domain_spawn parent 52 | 53 | let with_span op fn = 54 | enter_span op; 55 | match fn () with 56 | | r -> exit_span (); r 57 | | exception ex -> 58 | let bt = Printexc.get_raw_backtrace () in 59 | exit_span (); 60 | Printexc.raise_with_backtrace ex bt 61 | -------------------------------------------------------------------------------- /lib_eio/core/trace.mli: -------------------------------------------------------------------------------- 1 | (** Trace Eio events using OCaml's runtime events system. *) 2 | 3 | type id = private int 4 | (** Each thread/fiber/promise is identified by a unique ID. *) 5 | 6 | val mint_id : unit -> id 7 | (** [mint_id ()] is a fresh unique [id]. *) 8 | 9 | (** {2 Recording events} 10 | Libraries and applications can use these functions to make the traces more useful. *) 11 | 12 | val log : string -> unit 13 | (** [log msg] attaches text [msg] to the current fiber. *) 14 | 15 | val name : id -> string -> unit 16 | (** [name id label] sets [label] as the name for [id]. *) 17 | 18 | val with_span : string -> (unit -> 'a) -> 'a 19 | (** [with_span op fn] runs [fn ()], labelling the timespan during which it runs with [op]. *) 20 | 21 | val suspend_fiber : string -> unit 22 | (** [suspend_fiber op] records that the current fiber is now suspended waiting for [op]. *) 23 | 24 | (** {2 Recording system events} 25 | These are normally only called by the scheduler. *) 26 | 27 | val create_fiber : cc:id -> id -> unit 28 | (** [create_fiber ~cc id] records the creation of fiber [id] in context [cc]. *) 29 | 30 | val create_cc : id -> Eio_runtime_events.cc_ty -> unit 31 | (** [create_cc id ty] records the creation of cancellation context [id]. *) 32 | 33 | val create_obj : ?label:string -> id -> Eio_runtime_events.obj_ty -> unit 34 | (** [create_obj id ty] records the creation of [id]. *) 35 | 36 | val get : id -> unit 37 | (** [get src] records reading a promise, taking from a stream, taking a lock, etc. *) 38 | 39 | val try_get : id -> unit 40 | (** [try_get src] records that the current fiber wants to get from [src] (which is not currently ready). *) 41 | 42 | val put : id -> unit 43 | (** [put dst] records resolving a promise, adding to a stream, releasing a lock, etc. *) 44 | 45 | val fiber : id -> unit 46 | (** [fiber id] records that [id] is now the current fiber for this domain. *) 47 | 48 | val suspend_domain : Runtime_events.Type.span -> unit 49 | (** [suspend_domain] records when the event loop is stopped waiting for events from the OS. *) 50 | 51 | val domain_spawn : parent:id -> unit 52 | (** [domain_spawn ~parent] records that the current domain was spawned by fiber [parent]. *) 53 | 54 | val exit_cc : unit -> unit 55 | (** [exit_cc ()] records that the current CC has finished. *) 56 | 57 | val exit_fiber : id -> unit 58 | (** [exit_fiber id] records that fiber [id] has finished. *) 59 | 60 | val error : id -> exn -> unit 61 | (** [error id exn] records that [id] received an error. *) 62 | -------------------------------------------------------------------------------- /lib_eio/domain_manager.ml: -------------------------------------------------------------------------------- 1 | open Std 2 | 3 | type ty = [`Domain_mgr] 4 | type 'a t = ([> ty] as 'a) r 5 | 6 | module Pi = struct 7 | module type MGR = sig 8 | type t 9 | val run : t -> (cancelled:exn Promise.t -> 'a) -> 'a 10 | val run_raw : t -> (unit -> 'a) -> 'a 11 | end 12 | 13 | type (_, _, _) Resource.pi += 14 | | Mgr : ('t, (module MGR with type t = 't), [> ty]) Resource.pi 15 | 16 | let mgr (type t) (module X : MGR with type t = t) = 17 | Resource.handler [H (Mgr, (module X))] 18 | end 19 | 20 | let run_raw (Resource.T (t, ops)) fn = 21 | let module X = (val (Resource.get ops Pi.Mgr)) in 22 | X.run_raw t fn 23 | 24 | let run (Resource.T (t, ops)) fn = 25 | let module X = (val (Resource.get ops Pi.Mgr)) in 26 | X.run t @@ fun ~cancelled -> 27 | (* If the spawning fiber is cancelled, [cancelled] gets set to the exception. *) 28 | try 29 | Fiber.first 30 | (fun () -> 31 | match Promise.await cancelled with 32 | | Cancel.Cancelled ex -> raise ex (* To avoid [Cancelled (Cancelled ex))] *) 33 | | ex -> raise ex (* Shouldn't happen *) 34 | ) 35 | fn 36 | with ex -> 37 | match Promise.peek cancelled with 38 | | Some (Cancel.Cancelled ex2 as cex) when ex == ex2 -> 39 | (* We unwrapped the exception above to avoid [fn] seeing a double cancelled exception. 40 | But this means that the top-level reported the original exception, 41 | which isn't what we want. *) 42 | raise cex 43 | | _ -> raise ex 44 | -------------------------------------------------------------------------------- /lib_eio/domain_manager.mli: -------------------------------------------------------------------------------- 1 | type ty = [`Domain_mgr] 2 | type 'a t = ([> ty] as 'a) Resource.t 3 | 4 | val run : _ t -> (unit -> 'a) -> 'a 5 | (** [run t f] runs [f ()] in a newly-created domain and returns the result. 6 | 7 | Other fibers in the calling domain can run in parallel with the new domain. 8 | 9 | Warning: [f] must only access thread-safe values from the calling domain, 10 | but this is not enforced by the type system. 11 | 12 | If the calling fiber is cancelled, this is propagated to the spawned domain. *) 13 | 14 | val run_raw : _ t -> (unit -> 'a) -> 'a 15 | (** [run_raw t f] is like {!run}, but does not run an event loop in the new domain, 16 | and so cannot perform IO, fork fibers, etc. *) 17 | 18 | (** {2 Provider Interface} *) 19 | 20 | module Pi : sig 21 | module type MGR = sig 22 | type t 23 | 24 | val run : t -> (cancelled:exn Promise.t -> 'a) -> 'a 25 | (** [run t fn] runs [fn ~cancelled] in a new domain. 26 | 27 | If the calling fiber is cancelled, [cancelled] becomes resolved to the {!Cancel.Cancelled} exception. 28 | [fn] should cancel itself in this case. *) 29 | 30 | val run_raw : t -> (unit -> 'a) -> 'a 31 | end 32 | 33 | type (_, _, _) Resource.pi += 34 | | Mgr : ('t, (module MGR with type t = 't), [> ty]) Resource.pi 35 | 36 | val mgr : (module MGR with type t = 't) -> ('t, ty) Resource.handler 37 | end 38 | -------------------------------------------------------------------------------- /lib_eio/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio) 3 | (public_name eio) 4 | (flags (:standard -open Eio__core -open Eio__core.Private)) 5 | (libraries eio__core cstruct lwt-dllist fmt bigstringaf optint mtime)) 6 | -------------------------------------------------------------------------------- /lib_eio/eio.ml: -------------------------------------------------------------------------------- 1 | include Eio__core 2 | 3 | module Debug = Private.Debug 4 | let traceln = Debug.traceln 5 | 6 | module Std = Std 7 | module Semaphore = Semaphore 8 | module Mutex = Eio_mutex 9 | module Condition = Condition 10 | module Stream = Stream 11 | module Lazy = Lazy 12 | module Pool = Pool 13 | module Executor_pool = Executor_pool 14 | module Exn = Exn 15 | module Resource = Resource 16 | module Buf_read = Buf_read 17 | module Flow = struct 18 | include Flow 19 | 20 | let read_all flow = 21 | Buf_read.(parse_exn take_all) flow ~max_size:max_int 22 | end 23 | module Buf_write = Buf_write 24 | module Net = Net 25 | module Process = Process 26 | module Domain_manager = Domain_manager 27 | module Time = Time 28 | module File = File 29 | module Fs = Fs 30 | module Path = Path 31 | 32 | module Stdenv = struct 33 | let stdin (t : ) = t#stdin 34 | let stdout (t : ) = t#stdout 35 | let stderr (t : ) = t#stderr 36 | let net (t : ) = t#net 37 | let process_mgr (t : ) = t#process_mgr 38 | let domain_mgr (t : ) = t#domain_mgr 39 | let clock (t : ) = t#clock 40 | let mono_clock (t : ) = t#mono_clock 41 | let secure_random (t: ) = t#secure_random 42 | let fs (t : ) = t#fs 43 | let cwd (t : ) = t#cwd 44 | let debug (t : ) = t#debug 45 | let backend_id (t: ) = t#backend_id 46 | end 47 | 48 | exception Io = Exn.Io 49 | -------------------------------------------------------------------------------- /lib_eio/executor_pool.ml: -------------------------------------------------------------------------------- 1 | type job = Pack : { 2 | fn : unit -> 'a; 3 | w : ('a, exn) Result.t Promise.u; 4 | weight : int; 5 | } -> job 6 | 7 | type t = { 8 | queue : job Sync.t; 9 | } 10 | 11 | let max_capacity = 1_000_000 12 | 13 | let max_capacity_f = float max_capacity 14 | 15 | (* This function is the core of executor_pool.ml. 16 | Each worker runs in its own domain, 17 | taking jobs from [queue] whenever it has spare capacity. *) 18 | let run_worker { queue } = 19 | Switch.run ~name:"run_worker" @@ fun sw -> 20 | let capacity = ref 0 in 21 | let condition = Condition.create () in 22 | (* The main worker loop. *) 23 | let rec loop () = 24 | while !capacity >= max_capacity do Condition.await_no_mutex condition done; 25 | match Sync.take queue with 26 | | Error `Closed -> `Stop_daemon 27 | | Ok (Pack { fn; w; weight }) -> 28 | capacity := !capacity + weight; 29 | Option.iter (Promise.resolve_error w) (Switch.get_error sw); 30 | Fiber.fork ~sw (fun () -> 31 | Promise.resolve w (try Ok (fn ()) with ex -> Error ex); 32 | capacity := !capacity - weight; 33 | Condition.broadcast condition 34 | ); 35 | (* Give a chance to other domains to start waiting on [queue] 36 | before the current thread blocks on [Sync.take] again. *) 37 | Fiber.yield (); 38 | (loop [@tailcall]) () 39 | in 40 | loop () 41 | 42 | let create ~sw ~domain_count domain_mgr = 43 | let queue = Sync.create () in 44 | let t = { queue } in 45 | Switch.on_release sw (fun () -> Sync.close queue); 46 | for _ = 1 to domain_count do 47 | (* Workers run as daemons to not hold the user's switch from completing. 48 | It's up to the user to hold the switch open (and thus, the executor pool) 49 | by blocking on the jobs issued to the pool. *) 50 | Fiber.fork_daemon ~sw (fun () -> 51 | Domain_manager.run domain_mgr (fun () -> 52 | run_worker t)) 53 | done; 54 | t 55 | 56 | let enqueue { queue } ~weight fn = 57 | if not (weight >= 0. && weight <= 1.) (* Handles NaN *) 58 | then Fmt.invalid_arg "Executor_pool: weight %g not >= 0.0 && <= 1.0" weight 59 | else ( 60 | let weight = Float.to_int (weight *. max_capacity_f) in 61 | let p, w = Promise.create () in 62 | Sync.put queue (Pack { fn; w; weight }); 63 | p 64 | ) 65 | 66 | let submit t ~weight fn = 67 | enqueue t ~weight fn |> Promise.await 68 | 69 | let submit_exn t ~weight fn = 70 | enqueue t ~weight fn |> Promise.await_exn 71 | 72 | let submit_fork ~sw t ~weight fn = 73 | (* [enqueue] blocks until the job is accepted, so we have to fork here. *) 74 | Fiber.fork_promise ~sw (fun () -> submit_exn t ~weight fn) 75 | -------------------------------------------------------------------------------- /lib_eio/executor_pool.mli: -------------------------------------------------------------------------------- 1 | (** An executor pool distributes jobs (functions to execute) among a pool of domain workers (threads). 2 | 3 | Domains are reused and can execute multiple jobs concurrently. 4 | Jobs are queued up if they cannot be started immediately due to all workers being busy. 5 | 6 | [Eio.Executor_pool] is the recommended way of leveraging OCaml 5's multicore capabilities. 7 | It is built on top of the low level [Eio.Domain_manager]. 8 | 9 | Usually you will only want one pool for an entire application, 10 | so the pool is typically created when the application starts: 11 | 12 | {[ 13 | let () = 14 | Eio_main.run @@ fun env -> 15 | Switch.run @@ fun sw -> 16 | let pool = 17 | Eio.Executor_pool.create 18 | ~sw (Eio.Stdenv.domain_mgr env) 19 | ~domain_count:4 20 | in 21 | main ~pool 22 | ]} 23 | 24 | The pool starts its domain workers (threads) immediately upon creation. 25 | *) 26 | 27 | type t 28 | (** An executor pool. *) 29 | 30 | val create : 31 | sw:Switch.t -> 32 | domain_count:int -> 33 | _ Domain_manager.t -> 34 | t 35 | (** [create ~sw ~domain_count dm] creates a new executor pool. 36 | 37 | The executor pool will not block switch [sw] from completing; 38 | when the switch finishes, all domain workers and running jobs are cancelled. 39 | 40 | @param domain_count The number of domain workers to create. 41 | The total number of domains should not exceed {!Domain.recommended_domain_count} or the number of cores on your system. 42 | Additionally, consider reducing this number by 1 if your original domain will be performing CPU intensive work at the same time as the Executor_pool. 43 | *) 44 | 45 | val submit : t -> weight:float -> (unit -> 'a) -> ('a, exn) result 46 | (** [submit t ~weight fn] runs [fn ()] using this executor pool. 47 | 48 | The job is added to the back of the queue. 49 | 50 | @param weight This value represents the anticipated proportion of a CPU core used by the job. 51 | This value must be >= 0.0 and <= 1.0; Example: given an IO-bound job that averages 2% of a CPU core, pass [~weight:0.02]. 52 | Each domain worker starts new jobs until the total [~weight] of its running jobs reaches 1.0 53 | *) 54 | 55 | val submit_exn : t -> weight:float -> (unit -> 'a) -> 'a 56 | (** Same as {!submit} but raises if the job fails. *) 57 | 58 | val submit_fork : sw:Switch.t -> t -> weight:float -> (unit -> 'a) -> 'a Promise.or_exn 59 | (** Same as {!submit} but returns immediately, without blocking. *) 60 | -------------------------------------------------------------------------------- /lib_eio/fs.ml: -------------------------------------------------------------------------------- 1 | (** Note: file-system operations, such as opening or deleting files, 2 | can be found in the {!Path} module. *) 3 | 4 | open Std 5 | 6 | (** {2 Types} *) 7 | 8 | type path = string 9 | 10 | type error = 11 | | Already_exists of Exn.Backend.t 12 | | Not_found of Exn.Backend.t 13 | | Permission_denied of Exn.Backend.t 14 | | File_too_large 15 | | Not_native of string (** Raised by {!Path.native_exn}. *) 16 | 17 | type Exn.err += E of error 18 | 19 | let err e = 20 | Exn.create (E e) 21 | 22 | let () = 23 | Exn.register_pp (fun f -> function 24 | | E e -> 25 | Fmt.string f "Fs "; 26 | begin match e with 27 | | Already_exists e -> Fmt.pf f "Already_exists %a" Exn.Backend.pp e 28 | | Not_found e -> Fmt.pf f "Not_found %a" Exn.Backend.pp e 29 | | Permission_denied e -> Fmt.pf f "Permission_denied %a" Exn.Backend.pp e 30 | | File_too_large -> Fmt.pf f "File_too_large" 31 | | Not_native m -> Fmt.pf f "Not_native %S" m 32 | end; 33 | true 34 | | _ -> false 35 | ) 36 | 37 | (** When to create a new file. *) 38 | type create = [ 39 | | `Never (** fail if the named file doesn't exist *) 40 | | `If_missing of File.Unix_perm.t (** create if file doesn't already exist *) 41 | | `Or_truncate of File.Unix_perm.t (** any existing file is truncated to zero length *) 42 | | `Exclusive of File.Unix_perm.t (** always create; fail if the file already exists *) 43 | ] 44 | (** If a new file is created, the given permissions are used for it. *) 45 | 46 | type dir_ty = [`Dir] 47 | type 'a dir = ([> dir_ty] as 'a) r 48 | (** Note: use the functions in {!Path} to access directories. *) 49 | 50 | (** {2 Provider Interface} *) 51 | 52 | module Pi = struct 53 | module type DIR = sig 54 | type t 55 | 56 | val open_in : t -> sw:Switch.t -> path -> File.ro_ty r 57 | 58 | val open_out : 59 | t -> 60 | sw:Switch.t -> 61 | append:bool -> 62 | create:create -> 63 | path -> File.rw_ty r 64 | 65 | val mkdir : t -> perm:File.Unix_perm.t -> path -> unit 66 | val open_dir : t -> sw:Switch.t -> path -> [`Close | dir_ty] r 67 | val read_dir : t -> path -> string list 68 | val stat : t -> follow:bool -> string -> File.Stat.t 69 | val unlink : t -> path -> unit 70 | val rmdir : t -> path -> unit 71 | val rename : t -> path -> _ dir -> path -> unit 72 | val read_link : t -> path -> string 73 | val symlink : link_to:path -> t -> path -> unit 74 | val pp : t Fmt.t 75 | val native : t -> string -> string option 76 | end 77 | 78 | type (_, _, _) Resource.pi += 79 | | Dir : ('t, (module DIR with type t = 't), [> dir_ty]) Resource.pi 80 | end 81 | -------------------------------------------------------------------------------- /lib_eio/hook.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Null 3 | | Node : 'a Lwt_dllist.node -> t 4 | | Node_with_mutex : 'a Lwt_dllist.node * Mutex.t -> t 5 | 6 | let null = Null 7 | 8 | let remove = function 9 | | Null -> () 10 | | Node n -> Lwt_dllist.remove n 11 | | Node_with_mutex (n, m) -> 12 | Mutex.lock m; 13 | Fun.protect ~finally:(fun () -> Mutex.unlock m) 14 | (fun () -> Lwt_dllist.remove n) 15 | -------------------------------------------------------------------------------- /lib_eio/lazy.ml: -------------------------------------------------------------------------------- 1 | open Std 2 | 3 | type 'a state = 4 | | Value of 'a 5 | | Waiting of (unit Promise.u -> unit) 6 | | Running of unit Promise.t (* Wait until resolved and check again *) 7 | | Failed of Exn.with_bt 8 | 9 | type 'a t = 'a state Atomic.t 10 | 11 | let init = Waiting (fun _ -> assert false) 12 | 13 | let from_fun ~cancel fn = 14 | let state = Atomic.make init in 15 | let rec force r = 16 | match 17 | if cancel = `Protect then Cancel.protect fn else fn () 18 | with 19 | | x -> 20 | Atomic.set state (Value x); 21 | Promise.resolve r () 22 | | exception ex -> 23 | let bt = Printexc.get_raw_backtrace () in 24 | match ex with 25 | | Cancel.Cancelled _ when cancel = `Restart && Fiber.is_cancelled () -> 26 | Atomic.set state (Waiting force); 27 | Promise.resolve r (); 28 | Fiber.check () 29 | | _ -> 30 | Atomic.set state (Failed (ex, bt)); 31 | Promise.resolve r (); 32 | Printexc.raise_with_backtrace ex bt 33 | in 34 | Atomic.set state @@ Waiting force; 35 | state 36 | 37 | let from_val v = Atomic.make (Value v) 38 | 39 | let rec force t = 40 | match Atomic.get t with 41 | | Value v -> v 42 | | Failed (ex, bt) -> Printexc.raise_with_backtrace ex bt 43 | | Running p -> Promise.await p; force t 44 | | Waiting fn as prev -> 45 | let p, r = Promise.create () in 46 | if Atomic.compare_and_set t prev (Running p) then fn r; 47 | force t 48 | -------------------------------------------------------------------------------- /lib_eio/lazy.mli: -------------------------------------------------------------------------------- 1 | (** This is like [Stdlib.Lazy], but multiple fibers or domains can force at once. *) 2 | 3 | type 'a t 4 | (** A lazy value that produces a value of type ['a]. *) 5 | 6 | val from_fun : 7 | cancel:[`Restart | `Record | `Protect] -> 8 | (unit -> 'a) -> 'a t 9 | (** [from_fun ~cancel fn] is a lazy value that runs [fn ()] the first time it is forced. 10 | 11 | [cancel] determines how cancellation is handled while forcing: 12 | 13 | - [`Restart] : if the forcing fiber is cancelled, the next waiting fiber runs [fn] again. 14 | - [`Record] : the failure is recorded and the lazy value will always report cancelled if used. 15 | - [`Protect] : the forcing fiber is protected from cancellation while running. *) 16 | 17 | val from_val : 'a -> 'a t 18 | (** [from_val v] is a lazy value that is already forced. 19 | 20 | It is equivalent to [from_fun (fun () -> v)]. *) 21 | 22 | val force : 'a t -> 'a 23 | (** [force t] returns the result of running the function passed to {!from_fun}. 24 | 25 | If the function is currently running, this waits for it to finish and then retries. 26 | If the function has already completed then it returns the saved result. 27 | If the function returned an exception then [force] re-raises it. *) 28 | -------------------------------------------------------------------------------- /lib_eio/mock/action.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | type 'a t = [ 4 | | `Return of 'a 5 | | `Raise of exn 6 | | `Await of 'a Eio.Promise.or_exn 7 | | `Yield_then of 'a t 8 | | `Run of unit -> 'a 9 | ] 10 | 11 | let rec run = function 12 | | `Return x -> x 13 | | `Raise ex -> raise ex 14 | | `Await p -> Promise.await_exn p 15 | | `Yield_then t -> Fiber.yield (); run t 16 | | `Run fn -> fn () 17 | 18 | let rec map f = function 19 | | `Return x -> `Return (f x) 20 | | `Raise ex -> `Raise ex 21 | | `Await p -> `Run (fun () -> f (Promise.await_exn p)) 22 | | `Yield_then t -> `Yield_then (map f t) 23 | | `Run fn -> `Run (fun () -> f (fn ())) 24 | -------------------------------------------------------------------------------- /lib_eio/mock/backend.mli: -------------------------------------------------------------------------------- 1 | (** A dummy Eio backend with no actual IO. 2 | 3 | This backend does not support the use of multiple domains or systhreads, 4 | but the tradeoff is that it can reliably detect deadlock, because if the 5 | run queue is empty then it knows that no wake up event can be coming from 6 | elsewhere. *) 7 | 8 | exception Deadlock_detected 9 | 10 | val run : (unit -> 'a) -> 'a 11 | (** [run fn] runs an event loop and then calls [fn env] within it. 12 | @raise Deadlock_detected if the run queue becomes empty but [fn] hasn't returned. *) 13 | 14 | type stdenv = < 15 | clock : Clock.t; 16 | mono_clock : Clock.Mono.t; 17 | debug : Eio.Debug.t; 18 | backend_id: string; 19 | > 20 | 21 | val run_full : (stdenv -> 'a) -> 'a 22 | (** [run_full] is like {!run} but also provides a mock environment. 23 | 24 | The mock monotonic clock it provides advances automatically when there is nothing left to do. 25 | The mock wall clock is linked directly to the monotonic time. *) 26 | -------------------------------------------------------------------------------- /lib_eio/mock/clock.mli: -------------------------------------------------------------------------------- 1 | (** Note that {!Backend.run_full} provides mock clocks 2 | that advance automatically when there is nothing left to do. *) 3 | 4 | open Eio.Std 5 | 6 | type 'time ty = [`Mock | 'time Eio.Time.clock_ty] 7 | 8 | module type S = sig 9 | type time 10 | 11 | type t = time ty r 12 | 13 | val make : unit -> t 14 | (** [make ()] is a new clock. 15 | 16 | The time is initially set to 0.0 and doesn't change except when you call {!advance} or {!set_time}. *) 17 | 18 | val advance : t -> unit 19 | (** [advance t] sets the time to the next scheduled event (adding any due fibers to the run queue). 20 | @raise Invalid_argument if nothing is scheduled. *) 21 | 22 | val try_advance : t -> bool 23 | (** Like {!advance}, but returns [false] instead of raising an exception. *) 24 | 25 | val set_time : t -> time -> unit 26 | (** [set_time t time] sets the time to [time] (adding any due fibers to the run queue). *) 27 | end 28 | 29 | include S with type time := float 30 | 31 | module Mono : S with type time := Mtime.t 32 | -------------------------------------------------------------------------------- /lib_eio/mock/domain_manager.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let id = Fiber.create_key () 4 | 5 | let with_domain_tracing fn = 6 | Eio.Debug.with_trace_prefix (fun f -> 7 | Fiber.get id |> Option.iter (fun id -> Fmt.pf f "[%s] " id) 8 | ) fn 9 | 10 | module Fake_domain_mgr = struct 11 | type t = { 12 | mutable next_domain_id : int; 13 | } 14 | 15 | let create () = { next_domain_id = 1 } 16 | 17 | let run t fn = 18 | let self = t.next_domain_id in 19 | t.next_domain_id <- t.next_domain_id + 1; 20 | let cancelled, _ = Promise.create () in 21 | Fiber.with_binding id (string_of_int self) 22 | (fun () -> fn ~cancelled) 23 | 24 | let run_raw t fn = 25 | let self = t.next_domain_id in 26 | t.next_domain_id <- t.next_domain_id + 1; 27 | Fiber.with_binding id (string_of_int self) fn 28 | end 29 | 30 | let create = 31 | let handler = Eio.Domain_manager.Pi.mgr (module Fake_domain_mgr) in 32 | fun () -> Eio.Resource.T (Fake_domain_mgr.create (), handler) 33 | 34 | let run fn = 35 | let dm = create () in 36 | with_domain_tracing @@ fun () -> 37 | Fiber.with_binding id "0" @@ fun () -> 38 | fn dm 39 | -------------------------------------------------------------------------------- /lib_eio/mock/domain_manager.mli: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | val create : unit -> Eio.Domain_manager.ty r 4 | (** [create ()] is a mock domain manager. 5 | 6 | When asked to run a new Eio domain, it just runs it in the parent domain. 7 | It runs the function in a context where {!id} is a fresh domain ID 8 | (assigned sequentially starting from 1). *) 9 | 10 | val run : (Eio.Domain_manager.ty r -> 'a) -> 'a 11 | (** [run fn] runs [fn dm], where [dm] is a new fake domain manager. 12 | It also runs {!with_domain_tracing} to display domain IDs in trace output. 13 | 14 | [fn] itself runs with {!id} set to "0". *) 15 | 16 | val id : string Fiber.key 17 | (** [id] is used to get or set the current fake domain's ID. 18 | 19 | This is used in traceln output. *) 20 | 21 | val with_domain_tracing : (unit -> 'a) -> 'a 22 | (** [with_domain_tracing fn] runs [fn ()] with a modified [traceln] function that 23 | prefixes the current {!id} (if any) to each trace message. *) 24 | -------------------------------------------------------------------------------- /lib_eio/mock/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio_mock) 3 | (public_name eio.mock) 4 | (libraries eio eio.utils)) 5 | -------------------------------------------------------------------------------- /lib_eio/mock/eio_mock.ml: -------------------------------------------------------------------------------- 1 | module Action = Action 2 | module Handler = Handler 3 | module Flow = Flow 4 | module Net = Net 5 | module Clock = Clock 6 | module Domain_manager = Domain_manager 7 | module Backend = Backend 8 | 9 | type Eio.Exn.Backend.t += Simulated_failure 10 | let () = Eio.Exn.Backend.register_pp (fun f -> function 11 | | Simulated_failure -> Fmt.string f "Simulated_failure"; true 12 | | _ -> false 13 | ) 14 | -------------------------------------------------------------------------------- /lib_eio/mock/handler.ml: -------------------------------------------------------------------------------- 1 | type 'a actions = 'a Action.t list 2 | 3 | type 'a t = { 4 | default_action : 'a Action.t; 5 | mutable handler : (unit -> 'a); 6 | } 7 | 8 | let run t = t.handler () 9 | 10 | let set_handler t f = t.handler <- f 11 | 12 | let seq t actions = 13 | let actions = ref actions in 14 | let next () = 15 | match !actions with 16 | | [] -> Action.run t.default_action 17 | | x :: xs -> 18 | actions := xs; 19 | Action.run x 20 | in 21 | set_handler t next 22 | 23 | let run_default_action t = 24 | Action.run t.default_action 25 | 26 | let make default_action = 27 | { default_action; handler = (fun () -> Action.run default_action) } 28 | -------------------------------------------------------------------------------- /lib_eio/pool.mli: -------------------------------------------------------------------------------- 1 | (** This is useful to manage a collection of resources where creating new ones is expensive 2 | and so you want to reuse them where possible. 3 | 4 | Example: 5 | 6 | {[ 7 | let buffer_pool = Eio.Pool.create 10 (fun () -> Bytes.create 1024) in 8 | Eio.Pool.use buffer_pool (fun buf -> ...) 9 | ]} 10 | 11 | Note: If you just need to limit how many resources are in use, it is simpler to use {!Eio.Semaphore} instead. 12 | *) 13 | 14 | type 'a t 15 | 16 | val create : 17 | ?validate:('a -> bool) -> 18 | ?dispose:('a -> unit) -> 19 | int -> 20 | (unit -> 'a) -> 21 | 'a t 22 | (** [create n alloc] is a fresh pool which allows up to [n] resources to be live at a time. 23 | It uses [alloc] to create new resources as needed. 24 | If [alloc] raises an exception then that use fails, but future calls to {!use} will retry. 25 | 26 | The [alloc] function is called in the context of the fiber trying to use the pool. 27 | 28 | You should take care about handling cancellation in [alloc], since resources are typically 29 | attached to a switch with the lifetime of the pool, meaning that if [alloc] fails then they won't 30 | be freed automatically until the pool itself is finished. 31 | 32 | @param validate If given, this is used to check each resource before using it. 33 | If it returns [false], the pool removes it with [dispose] and then allocates a fresh resource. 34 | @param dispose Used to free resources rejected by [validate]. 35 | If it raises, the exception is passed on to the user, 36 | but resource is still considered to have been disposed. *) 37 | 38 | val use : 'a t -> ?never_block:bool -> ('a -> 'b) -> 'b 39 | (** [use t fn] waits for some resource [x] to be available and then runs [f x]. 40 | Afterwards (on success or error), [x] is returned to the pool. 41 | 42 | @param never_block If [true] and the pool has reached maximum capacity, 43 | then a fresh resource is created to ensure that this [use] 44 | call does not wait for a resource to become available. 45 | This resource is immediately disposed after [f x] returns. 46 | *) 47 | -------------------------------------------------------------------------------- /lib_eio/resource.ml: -------------------------------------------------------------------------------- 1 | type ('t, 'impl, 'tags) pi = .. 2 | type _ binding = H : ('t, 'impl, 'tags) pi * 'impl -> 't binding 3 | type 't ops = 't binding array 4 | type ('t, 'tags) handler = 't ops 5 | type -'a t = T : ('t * 't ops) -> 'a t 6 | 7 | let not_supported () = failwith "Operation not supported!" 8 | 9 | let handler = Array.of_list 10 | let bindings = Array.to_list 11 | 12 | let get : 't ops -> ('t, 'impl, 'tags) pi -> 'impl = fun ops op -> 13 | let rec aux i = 14 | if i = Array.length ops then not_supported (); 15 | let H (k, v) = ops.(i) in 16 | if Obj.repr k == Obj.repr op then Obj.magic v 17 | else aux (i + 1) 18 | in 19 | aux 0 20 | 21 | let get_opt : 't ops -> ('t, 'impl, 'tags) pi -> 'impl option = fun ops op -> 22 | let rec aux i = 23 | if i = Array.length ops then None 24 | else ( 25 | let H (k, v) = ops.(i) in 26 | if Obj.repr k == Obj.repr op then Some (Obj.magic v) 27 | else aux (i + 1) 28 | ) 29 | in 30 | aux 0 31 | 32 | type close_ty = [`Close] 33 | type (_, _, _) pi += Close : ('t, 't -> unit, [> close_ty]) pi 34 | 35 | let close (T (t, ops)) = get ops Close t 36 | -------------------------------------------------------------------------------- /lib_eio/runtime_events/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio_runtime_events) 3 | (public_name eio.runtime_events) 4 | (libraries runtime_events)) 5 | -------------------------------------------------------------------------------- /lib_eio/semaphore.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | id : Trace.id; 3 | state : Sem_state.t; 4 | } 5 | 6 | let make n = 7 | let id = Trace.mint_id () in 8 | Trace.create_obj id Semaphore; 9 | { 10 | id; 11 | state = Sem_state.create n; 12 | } 13 | 14 | let release t = 15 | Trace.put t.id; 16 | Sem_state.release t.state 17 | 18 | let acquire t = 19 | if not (Sem_state.acquire t.state) then ( 20 | (* No free resources. 21 | We must wait until one of the existing users increments the counter and resumes us. 22 | It's OK if they resume before we suspend; we'll just pick up the token they left. *) 23 | Suspend.enter_unchecked "Semaphore.acquire" (fun ctx enqueue -> 24 | match Sem_state.suspend t.state (fun () -> enqueue (Ok ())) with 25 | | None -> () (* Already resumed *) 26 | | Some request -> 27 | Trace.try_get t.id; 28 | match Fiber_context.get_error ctx with 29 | | Some ex -> 30 | if Sem_state.cancel request then enqueue (Error ex); 31 | (* else already resumed *) 32 | | None -> 33 | Fiber_context.set_cancel_fn ctx (fun ex -> 34 | if Sem_state.cancel request then enqueue (Error ex) 35 | (* else already resumed *) 36 | ) 37 | ) 38 | ); 39 | Trace.get t.id 40 | 41 | let get_value t = 42 | max 0 (Atomic.get t.state.state) 43 | -------------------------------------------------------------------------------- /lib_eio/semaphore.mli: -------------------------------------------------------------------------------- 1 | (** The API is based on OCaml's [Semaphore.Counting]. 2 | 3 | The difference is that when waiting for the semaphore this will switch to the next runnable fiber, 4 | whereas the stdlib one will block the whole domain. 5 | 6 | Semaphores are thread-safe and so can be shared between domains and used 7 | to synchronise between them. *) 8 | 9 | type t 10 | (** The type of counting semaphores. *) 11 | 12 | val make : int -> t 13 | (** [make n] returns a new counting semaphore, with initial value [n]. 14 | The initial value [n] must be nonnegative. 15 | @raise Invalid_argument if [n < 0] *) 16 | 17 | val release : t -> unit 18 | (** [release t] increments the value of semaphore [t]. 19 | If other fibers are waiting on [t], the one that has been waiting the longest is resumed. 20 | @raise Sys_error if the value of the semaphore would overflow [max_int] *) 21 | 22 | val acquire : t -> unit 23 | (** [acquire t] blocks the calling fiber until the value of semaphore [t] 24 | is not zero, then atomically decrements the value of [t] and returns. *) 25 | 26 | val get_value : t -> int 27 | (** [get_value t] returns the current value of semaphore [t]. *) 28 | -------------------------------------------------------------------------------- /lib_eio/std.ml: -------------------------------------------------------------------------------- 1 | module Promise = Eio__core.Promise 2 | module Fiber = Eio__core.Fiber 3 | module Switch = Eio__core.Switch 4 | type 'a r = 'a Resource.t 5 | let traceln = Debug.traceln 6 | -------------------------------------------------------------------------------- /lib_eio/std.mli: -------------------------------------------------------------------------------- 1 | module Promise = Eio__core.Promise 2 | module Fiber = Eio__core.Fiber 3 | module Switch = Eio__core.Switch 4 | 5 | type 'a r = 'a Resource.t 6 | 7 | val traceln : 8 | ?__POS__:string * int * int * int -> 9 | ('a, Format.formatter, unit, unit) format4 -> 'a 10 | (** Same as {!Eio.traceln}. *) 11 | -------------------------------------------------------------------------------- /lib_eio/stream.mli: -------------------------------------------------------------------------------- 1 | (** Reading from an empty queue will wait until an item is available. 2 | Writing to a full queue will wait until there is space. 3 | 4 | Example: 5 | {[ 6 | let t = Stream.create 100 in 7 | Stream.add t 1; 8 | Stream.add t 2; 9 | assert (Stream.take t = 1); 10 | assert (Stream.take t = 2) 11 | ]} 12 | 13 | Streams are thread-safe and so can be shared between domains and used 14 | to communicate between them. *) 15 | 16 | type 'a t 17 | (** A queue of items of type ['a]. *) 18 | 19 | val create : int -> 'a t 20 | (** [create capacity] is a new stream which can hold up to [capacity] items without blocking writers. 21 | 22 | - If [capacity = 0] then writes block until a reader is ready. 23 | - If [capacity = 1] then this acts as a "mailbox". 24 | - If [capacity = max_int] then the stream is effectively unbounded. *) 25 | 26 | val add : 'a t -> 'a -> unit 27 | (** [add t item] adds [item] to [t]. 28 | 29 | If this would take [t] over capacity, it blocks until there is space. *) 30 | 31 | val take : 'a t -> 'a 32 | (** [take t] takes the next item from the head of [t]. 33 | 34 | If no items are available, it waits until one becomes available. *) 35 | 36 | val take_nonblocking : 'a t -> 'a option 37 | (** [take_nonblocking t] is like [Some (take t)] except that 38 | it returns [None] if the stream is empty rather than waiting. 39 | 40 | Note that if another domain may add to the stream then a [None] 41 | result may already be out-of-date by the time this returns. *) 42 | 43 | val length : 'a t -> int 44 | (** [length t] returns the number of items currently in [t]. *) 45 | 46 | val is_empty : 'a t -> bool 47 | (** [is_empty t] is [length t = 0]. *) 48 | 49 | val dump : 'a t Fmt.t 50 | (** For debugging. *) 51 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/atomic.ml: -------------------------------------------------------------------------------- 1 | include Dscheck.TracedAtomic 2 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/dune: -------------------------------------------------------------------------------- 1 | ; We copy cells.ml here so we can build it using TracedAtomic instead of the default one. 2 | (copy_files# (files ../../core/cells.ml)) 3 | (copy_files# (files ../../sem_state.ml)) 4 | (copy_files# (files ../../sync.ml)) 5 | (copy_files# (files ../../unix/rcfd.ml)) 6 | (copy_files# (files ../../condition.ml)) 7 | (copy_files# (files ../../pool.ml)) 8 | (copy_files# (files ../../core/broadcast.ml)) 9 | 10 | (executables 11 | (names test_cells test_semaphore test_sync test_rcfd test_condition test_pool) 12 | (libraries dscheck optint fmt eio)) 13 | 14 | (rule 15 | (alias dscheck) 16 | (package eio) 17 | (action (run %{exe:test_rcfd.exe}))) 18 | 19 | (rule 20 | (alias dscheck) 21 | (package eio) 22 | (action (run %{exe:test_cells.exe}))) 23 | 24 | (rule 25 | (alias dscheck) 26 | (package eio) 27 | (action (run %{exe:test_sync.exe}))) 28 | 29 | (rule 30 | (alias dscheck) 31 | (package eio) 32 | (action (run %{exe:test_semaphore.exe}))) 33 | 34 | (rule 35 | (alias dscheck) 36 | (package eio) 37 | (action (run %{exe:test_condition.exe}))) 38 | 39 | (rule 40 | (alias dscheck) 41 | (package eio) 42 | (action (run %{exe:test_pool.exe}))) 43 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/eio_mutex.ml: -------------------------------------------------------------------------------- 1 | let lock _ = assert false 2 | let unlock _ = assert false 3 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/fake_sched.ml: -------------------------------------------------------------------------------- 1 | let cancel ctx = Eio.Cancel.cancel ctx (Failure "test cancellation") 2 | 3 | let run fn = 4 | let module Fiber_context = Eio__core.Private.Fiber_context in 5 | let continue_result k = function 6 | | Ok x -> Effect.Deep.continue k x 7 | | Error x -> Effect.Deep.discontinue k x 8 | in 9 | let fiber = lazy (Fiber_context.make_root ()) in 10 | Effect.Deep.try_with fn () 11 | { effc = fun (type a) (e : a Effect.t) : ((a, 'b) Effect.Deep.continuation -> 'b) option -> 12 | match e with 13 | | Eio.Private.Effects.Suspend fn -> 14 | Some (fun cont -> 15 | fn (Lazy.force fiber) (continue_result cont); 16 | ) 17 | | _ -> None 18 | }; 19 | if Lazy.is_val fiber then 20 | Some (Fiber_context.cancellation_context (Lazy.force fiber)) 21 | else None 22 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/fake_sched.mli: -------------------------------------------------------------------------------- 1 | val run : (unit -> unit) -> Eio.Cancel.t option 2 | (** [run fn] runs [fn ()] in a new fiber and returns its context so it can be cancelled. 3 | 4 | Returns None if it never suspended. *) 5 | 6 | val cancel : Eio.Cancel.t -> unit 7 | (** [cancel ctx] cancels the context with a suitable dummy exception. *) 8 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/simple_cqs.ml: -------------------------------------------------------------------------------- 1 | (* A queue built on cells.ml using the "simple" cancellation mode, 2 | where resuming a cancelled request does nothing instead of retrying. *) 3 | 4 | module Make(Config : sig val segment_order : int end) = struct 5 | module Cell = struct 6 | type _ t = 7 | | Empty 8 | | Value of int 9 | | Waiting of (int -> unit) 10 | | Cancelled 11 | | Finished 12 | 13 | let init = Empty 14 | 15 | let segment_order = Config.segment_order 16 | 17 | let dump f = function 18 | | Empty -> Fmt.string f "Empty" 19 | | Value v -> Fmt.pf f "Value %d" v 20 | | Waiting _ -> Fmt.string f "Waiting" 21 | | Cancelled -> Fmt.string f "Cancelled" 22 | | Finished -> Fmt.string f "Finished" 23 | end 24 | 25 | module Cells = Cells.Make(Cell) 26 | 27 | let cancel (segment, cell) = 28 | match Atomic.get cell with 29 | | Cell.Waiting _ as prev -> 30 | if Atomic.compare_and_set cell prev Cancelled then ( 31 | Cells.cancel_cell segment; 32 | true 33 | ) else ( 34 | false 35 | ) 36 | | Finished -> false 37 | | _ -> assert false 38 | 39 | let resume t v = 40 | let cell = Cells.next_resume t in 41 | if not (Atomic.compare_and_set cell Cell.Empty (Value v)) then ( 42 | match Atomic.get cell with 43 | | Waiting w as prev -> 44 | if Atomic.compare_and_set cell prev Finished then w v 45 | (* else cancelled *) 46 | | Cancelled -> () 47 | | Empty | Value _ | Finished -> assert false 48 | ) 49 | 50 | let suspend t k = 51 | let segment, cell = Cells.next_suspend t in 52 | if Atomic.compare_and_set cell Cell.Empty (Waiting k) then Some (segment, cell) 53 | else ( 54 | match Atomic.get cell with 55 | | Value v -> Atomic.set cell Finished; k v; None 56 | | Cancelled | Empty | Waiting _ | Finished -> assert false 57 | ) 58 | 59 | let make = Cells.make 60 | 61 | let dump = Cells.dump 62 | end 63 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/test_condition.ml: -------------------------------------------------------------------------------- 1 | let debug = false 2 | 3 | exception Abort 4 | 5 | module T = Condition 6 | 7 | (* [prod] threads increment a counter and notify a condition. 8 | A consumer watches the condition and waits until it has seen 9 | all of them. We check that the client always sees the final value. 10 | If [cancel] is set, we also try to cancel the client and accept 11 | that as success too. *) 12 | let test ~prod ~cancel () = 13 | let t = T.create () in 14 | let sent = Atomic.make 0 in 15 | for _ = 1 to prod do 16 | Atomic.spawn (fun () -> 17 | Atomic.incr sent; 18 | T.broadcast t 19 | ) 20 | done; 21 | let finished = ref false in 22 | Atomic.spawn (fun () -> 23 | let ctx = 24 | Fake_sched.run @@ fun () -> 25 | try 26 | T.loop_no_mutex t (fun () -> 27 | if Atomic.get sent = prod && not cancel then Some () 28 | else None 29 | ); 30 | finished := true 31 | with T.Cancel.Cancelled Abort -> 32 | finished := true 33 | in 34 | if cancel then 35 | Option.iter (fun c -> T.Cancel.cancel c Abort) ctx 36 | ); 37 | Atomic.final (fun () -> 38 | Atomic.check (fun () -> !finished); 39 | if debug then ( 40 | Fmt.pr "%a@." Broadcast.dump t; 41 | ); 42 | ) 43 | 44 | let () = 45 | Atomic.trace (test ~prod:2 ~cancel:false); 46 | Atomic.trace (test ~prod:2 ~cancel:true) 47 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/test_pool.ml: -------------------------------------------------------------------------------- 1 | module T = Pool 2 | module Cancel = Eio__core.Cancel 3 | 4 | exception Abort 5 | 6 | (* [clients] threads try to use a pool of size [n]. 7 | If [cancel] is set, they also try to cancel, and accept 8 | that as success too. *) 9 | let test ~n ~clients ~cancel () = 10 | let t = T.create n (fun () -> ()) in 11 | let used = Atomic.make 0 in 12 | let finished = ref 0 in 13 | for _ = 1 to clients do 14 | Atomic.spawn (fun () -> 15 | let ctx = 16 | Fake_sched.run @@ fun () -> 17 | try 18 | T.use t (fun () -> Atomic.incr used); 19 | incr finished; 20 | with Cancel.Cancelled Abort -> 21 | incr finished; 22 | in 23 | if cancel then 24 | Option.iter (fun c -> Cancel.cancel c Abort) ctx 25 | ) 26 | done; 27 | Atomic.final (fun () -> 28 | if not cancel then Atomic.check (fun () -> Atomic.get used = clients); 29 | Atomic.check (fun () -> !finished = clients); 30 | ) 31 | 32 | let () = 33 | Atomic.trace (test ~n:1 ~clients:2 ~cancel:false); 34 | Atomic.trace (test ~n:1 ~clients:2 ~cancel:true) 35 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/test_rcfd.ml: -------------------------------------------------------------------------------- 1 | let debug = false 2 | 3 | module T = Rcfd 4 | 5 | let test ~n_users ~n_closers () = 6 | let messages = ref [] in 7 | let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in 8 | if debug then log "== start =="; 9 | let wrapped_fd = Unix.make () in 10 | let t = T.make wrapped_fd in 11 | let n_closed = ref 0 in 12 | for _ = 1 to n_users do 13 | Atomic.spawn (fun () -> 14 | T.use t ~if_closed:ignore (fun fd -> 15 | log "Using FD"; 16 | assert (Atomic.get fd = `Open); 17 | log "Releasing FD"; 18 | ) 19 | ) 20 | done; 21 | for _ = 1 to n_closers do 22 | Atomic.spawn (fun () -> 23 | log "Closing FD"; 24 | if T.close t then ( 25 | log "Closed FD"; 26 | incr n_closed 27 | ) else ( 28 | log "FD already closed"; 29 | ) 30 | ) 31 | done; 32 | Atomic.final (fun () -> 33 | if debug then List.iter print_string (List.rev !messages); 34 | assert (!n_closed = 1); 35 | assert (Atomic.get wrapped_fd = `Closed); 36 | ) 37 | 38 | let () = 39 | Atomic.trace (test ~n_users:2 ~n_closers:2); 40 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/test_semaphore.ml: -------------------------------------------------------------------------------- 1 | let debug = false 2 | 3 | module T = Sem_state 4 | 5 | let test ~capacity ~users () = 6 | let messages = ref [] in 7 | let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in 8 | if debug then log "== start =="; 9 | let t = T.create capacity in 10 | let running = Atomic.make 0 in 11 | let acquire fn = 12 | if T.acquire t then (fn (); None) 13 | else T.suspend t fn 14 | in 15 | for i = 1 to users do 16 | Atomic.spawn (fun () -> 17 | match 18 | acquire (fun () -> 19 | if debug then log "%d: got resource" i; 20 | Atomic.incr running; 21 | Atomic.decr running; 22 | if debug then log "%d: released resource" i; 23 | T.release t 24 | ) 25 | with 26 | | None -> () 27 | | Some request -> 28 | if T.cancel request then ( 29 | if debug then log "%d: cancelled request" i; 30 | ) 31 | ) 32 | done; 33 | Atomic.every (fun () -> assert (Atomic.get running <= capacity)); 34 | Atomic.final (fun () -> 35 | if debug then ( 36 | List.iter print_string (List.rev !messages); 37 | Fmt.pr "%a@." T.dump t; 38 | ); 39 | assert (Atomic.get t.state = capacity); 40 | (* Do a dummy non-cancelled operation to ensure the pointers end up together: *) 41 | T.resume t; 42 | assert (T.suspend t ignore = None); 43 | assert (T.Cells.Position.index t.cells.suspend = 44 | T.Cells.Position.index t.cells.resume); 45 | ) 46 | 47 | let () = 48 | Atomic.trace (test ~capacity:1 ~users:3); 49 | Atomic.trace (test ~capacity:2 ~users:3) 50 | -------------------------------------------------------------------------------- /lib_eio/tests/dscheck/unix.ml: -------------------------------------------------------------------------------- 1 | type error = ECONNRESET 2 | 3 | exception Unix_error of error * string * string 4 | 5 | type file_descr = [`Open | `Closed] Atomic.t 6 | 7 | let make () = Atomic.make `Open 8 | 9 | let close t = 10 | if not (Atomic.compare_and_set t `Open `Closed) then 11 | failwith "Already closed!" 12 | -------------------------------------------------------------------------------- /lib_eio/tests/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package eio) 3 | (enabled_if (<> %{os_type} "Win32")) 4 | (deps 5 | (package eio) 6 | (file ./dscheck/fake_sched.ml) 7 | (file ./dscheck/fake_sched.mli))) 8 | -------------------------------------------------------------------------------- /lib_eio/tests/trace.md: -------------------------------------------------------------------------------- 1 | # Test unique ID generation 2 | 3 | 4 | ```ocaml 5 | # #require "eio";; 6 | # for _ = 1 to 5 do 7 | Printf.printf "%d\n%!" (Eio.Private.Trace.mint_id () :> int) 8 | done;; 9 | 1 10 | 2 11 | 3 12 | 4 13 | 5 14 | - : unit = () 15 | ``` 16 | 17 | A new domain gets a new chunk: 18 | 19 | ```ocaml 20 | # Domain.join @@ Domain.spawn 21 | (fun () -> 22 | for _ = 1 to 5 do 23 | Printf.printf "%d\n%!" (Eio.Private.Trace.mint_id () :> int) 24 | done);; 25 | 1024 26 | 1025 27 | 1026 28 | 1027 29 | 1028 30 | - : unit = () 31 | ``` 32 | 33 | When the original domain exhausts its chunk, it jumps to the next free chunk: 34 | 35 | ```ocaml 36 | # for _ = 1 to 1024 - 9 do 37 | Eio.Private.Trace.mint_id () |> ignore 38 | done;; 39 | - : unit = () 40 | 41 | # for _ = 1 to 5 do 42 | Printf.printf "%d\n%!" (Eio.Private.Trace.mint_id () :> int) 43 | done;; 44 | 1021 45 | 1022 46 | 1023 47 | 2048 48 | 2049 49 | - : unit = () 50 | ``` 51 | -------------------------------------------------------------------------------- /lib_eio/unix/cap.c: -------------------------------------------------------------------------------- 1 | #include "primitives.h" 2 | 3 | #include 4 | #include 5 | 6 | #ifdef __FreeBSD__ 7 | # define HAVE_CAPSICUM 8 | #endif 9 | 10 | #ifdef HAVE_CAPSICUM 11 | # include 12 | #endif 13 | 14 | #include 15 | #include 16 | 17 | CAMLprim value eio_unix_cap_enter(value v_unit) { 18 | #ifdef HAVE_CAPSICUM 19 | int r = cap_enter(); 20 | if (r == -1 && errno != ENOSYS) 21 | caml_uerror("cap_enter", Nothing); 22 | 23 | return Val_bool(r == 0); 24 | #else 25 | return Val_bool(0); 26 | #endif 27 | } 28 | -------------------------------------------------------------------------------- /lib_eio/unix/cap.ml: -------------------------------------------------------------------------------- 1 | external eio_cap_enter : unit -> bool = "eio_unix_cap_enter" 2 | 3 | let enter () = 4 | if eio_cap_enter () then Ok () 5 | else Error `Not_supported 6 | -------------------------------------------------------------------------------- /lib_eio/unix/cap.mli: -------------------------------------------------------------------------------- 1 | val enter : unit -> (unit, [`Not_supported]) result 2 | (** Call {{:https://man.freebsd.org/cgi/man.cgi?query=cap_enter}cap_enter}. 3 | 4 | Once in capability mode, access to global name spaces, such as file system 5 | or IPC name spaces, is prevented by the operating system. A program can call 6 | this after opening any directories, files or network sockets that it will need, 7 | to prevent accidental access to other resources. 8 | 9 | The standard environment directories {!Eio.Stdenv.fs} and {!Eio.Stdenv.cwd} cannot 10 | be used after calling this, but directories opened from them via {!Eio.Path.with_open_dir} 11 | will continue to work. *) 12 | -------------------------------------------------------------------------------- /lib_eio/unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio_unix) 3 | (public_name eio.unix) 4 | (public_headers include/fork_action.h) 5 | (foreign_stubs 6 | (language c) 7 | (include_dirs include) 8 | (names fork_action stubs cap)) 9 | (libraries eio eio.utils unix threads mtime.clock.os)) 10 | 11 | (rule 12 | (enabled_if %{bin-available:lintcstubs_arity_cmt}) 13 | (action 14 | (with-stdout-to 15 | primitives.h.new 16 | (run %{bin:lintcstubs_arity_cmt} 17 | %{dep:.eio_unix.objs/byte/eio_unix__Fd.cmt} 18 | %{dep:.eio_unix.objs/byte/eio_unix__Private.cmt} 19 | %{dep:.eio_unix.objs/byte/eio_unix__Cap.cmt} 20 | %{dep:.eio_unix.objs/byte/eio_unix__Fork_action.cmt})))) 21 | 22 | (rule 23 | (enabled_if %{bin-available:lintcstubs_arity_cmt}) 24 | (alias runtest) 25 | (action 26 | (diff primitives.h primitives.h.new))) 27 | -------------------------------------------------------------------------------- /lib_eio/unix/eio_unix.ml: -------------------------------------------------------------------------------- 1 | [@@@alert "-unstable"] 2 | 3 | open Eio.Std 4 | 5 | module Fd = Fd 6 | module Resource = Resource 7 | module Private = Private 8 | 9 | include Types 10 | 11 | let await_readable = Private.await_readable 12 | let await_writable = Private.await_writable 13 | let pipe = Private.pipe 14 | 15 | type Eio.Exn.Backend.t += Unix_error of Unix.error * string * string 16 | let () = 17 | Eio.Exn.Backend.register_pp (fun f -> function 18 | | Unix_error (code, name, arg) -> Fmt.pf f "Unix_error (%s, %S, %S)" (Unix.error_message code) name arg; true 19 | | _ -> false 20 | ) 21 | 22 | let sleep d = 23 | Eio.Time.Mono.sleep (Effect.perform Private.Get_monotonic_clock) d 24 | 25 | let run_in_systhread = Thread_pool.run_in_systhread 26 | 27 | module Ipaddr = Net.Ipaddr 28 | 29 | module Process = Process 30 | module Net = Net 31 | module Cap = Cap 32 | module Pi = Pi 33 | 34 | module Stdenv = struct 35 | type base = < 36 | stdin : source_ty r; 37 | stdout : sink_ty r; 38 | stderr : sink_ty r; 39 | net : [`Unix | `Generic] Eio.Net.ty r; 40 | domain_mgr : Eio.Domain_manager.ty r; 41 | process_mgr : Process.mgr_ty r; 42 | clock : float Eio.Time.clock_ty r; 43 | mono_clock : Eio.Time.Mono.ty r; 44 | fs : Eio.Fs.dir_ty Eio.Path.t; 45 | cwd : Eio.Fs.dir_ty Eio.Path.t; 46 | secure_random : Eio.Flow.source_ty r; 47 | debug : Eio.Debug.t; 48 | backend_id: string; 49 | > 50 | end 51 | -------------------------------------------------------------------------------- /lib_eio/unix/fork_action.ml: -------------------------------------------------------------------------------- 1 | type c_action = Obj.t 2 | 3 | type t = { run : 'a. ((c_action -> 'a) -> 'a) } [@@unboxed] 4 | 5 | (* A [fork_fn] is a C function that can be executed after forking. It cannot call OCaml code or 6 | run the OCaml GC. It is passed a [Unix.file_descr] for errors and a pointer 7 | to a [c_action]. On success it should write nothing to the error stream and 8 | return 0. On error, it should write a message to the error FD and return a 9 | non-zero value for the exit status (e.g. 1). *) 10 | type fork_fn 11 | 12 | let rec with_actions actions fn = 13 | match actions with 14 | | [] -> fn [] 15 | | { run } :: xs -> 16 | run @@ fun c_action -> 17 | with_actions xs @@ fun c_actions -> 18 | fn (c_action :: c_actions) 19 | 20 | type c_array 21 | external make_string_array : int -> c_array = "eio_unix_make_string_array" 22 | external action_execve : unit -> fork_fn = "eio_unix_fork_execve" 23 | let action_execve = action_execve () 24 | let execve path ~argv ~env = 25 | let argv_c_array = make_string_array (Array.length argv) in 26 | let env_c_array = make_string_array (Array.length env) in 27 | { run = fun k -> k (Obj.repr (action_execve, path, argv_c_array, argv, env_c_array, env)) } 28 | 29 | external action_chdir : unit -> fork_fn = "eio_unix_fork_chdir" 30 | let action_chdir = action_chdir () 31 | let chdir path = { run = fun k -> k (Obj.repr (action_chdir, path)) } 32 | 33 | external action_fchdir : unit -> fork_fn = "eio_unix_fork_fchdir" 34 | let action_fchdir = action_fchdir () 35 | let fchdir fd = { 36 | run = fun k -> 37 | Fd.use_exn "fchdir" fd @@ fun fd -> 38 | k (Obj.repr (action_fchdir, fd)) } 39 | 40 | let int_of_fd : Unix.file_descr -> int = Obj.magic 41 | 42 | type action = Inherit_fds.action = { src : int; dst : int } 43 | 44 | let rec with_fds mapping k = 45 | match mapping with 46 | | [] -> k [] 47 | | (dst, src, _) :: xs -> 48 | Fd.use_exn "inherit_fds" src @@ fun src -> 49 | with_fds xs @@ fun xs -> 50 | k ((dst, int_of_fd src) :: xs) 51 | 52 | type blocking = [ 53 | | `Blocking 54 | | `Nonblocking 55 | | `Preserve_blocking 56 | ] 57 | 58 | external action_dups : unit -> fork_fn = "eio_unix_fork_dups" 59 | let action_dups = action_dups () 60 | let inherit_fds m = 61 | let blocking = m |> List.filter_map (fun (dst, _, flags) -> 62 | match flags with 63 | | `Blocking -> Some (dst, true) 64 | | `Nonblocking -> Some (dst, false) 65 | | `Preserve_blocking -> None 66 | ) 67 | in 68 | with_fds m @@ fun m -> 69 | let plan : action list = Inherit_fds.plan m in 70 | { run = fun k -> k (Obj.repr (action_dups, plan, blocking)) } 71 | -------------------------------------------------------------------------------- /lib_eio/unix/fork_action.mli: -------------------------------------------------------------------------------- 1 | (** Actions to perform after forking a child process. 2 | 3 | To spawn a child executable on Unix, the parent forks a copy of itself, 4 | then has the child copy set up the environment for the new program and 5 | execute it. 6 | 7 | However, we cannot run any OCaml code in the forked child process. This is 8 | because `fork` only duplicates its own domain. To the child, it appears 9 | that all other domains have stopped responding and if it tries to e.g. 10 | perform a GC then the child process will hang. 11 | 12 | Therefore, the fork call and all child actions need to be written in C. 13 | This module provides some support code for doing that. 14 | Individual backends will wrap these actions with higher-level APIs and 15 | can also add their own platform-specific actions. 16 | 17 | @canonical Eio_unix.Private.Fork_action *) 18 | 19 | type fork_fn 20 | (** A C function, as defined in "include/fork_action.h". *) 21 | 22 | type c_action = Obj.t 23 | (** An action to be performed in a child process after forking. 24 | This must be a tuple whose first field is a [fork_fn]. *) 25 | 26 | type t = { run : 'a. ((c_action -> 'a) -> 'a) } [@@unboxed] 27 | (** An action that calls [run k] in the parent process to create the C action. 28 | [run] passes the action to [k], which forks the child and runs it. When [k] 29 | returns, [run] can free any resources used. *) 30 | 31 | val with_actions : t list -> (c_action list -> 'a) -> 'a 32 | 33 | (** {2 Actions} *) 34 | 35 | val execve : string -> argv:string array -> env:string array -> t 36 | (** See [execve(2)]. 37 | 38 | This replaces the current executable, 39 | so it only makes sense as the last action to be performed. *) 40 | 41 | val chdir : string -> t 42 | (** [chdir path] changes directory to [path]. *) 43 | 44 | val fchdir : Fd.t -> t 45 | (** [fchdir fd] changes directory to [fd]. *) 46 | 47 | type blocking = [ 48 | | `Blocking (** Clear the [O_NONBLOCK] flag in the child process. *) 49 | | `Nonblocking (** Set the [O_NONBLOCK] flag in the child process. *) 50 | | `Preserve_blocking (** Don't change the blocking mode of the FD. *) 51 | ] 52 | 53 | val inherit_fds : (int * Fd.t * [< blocking]) list -> t 54 | (** [inherit_fds mapping] marks file descriptors as not close-on-exec and renumbers them. 55 | 56 | For each (fd, src, flags) in [mapping], we use [dup2] to duplicate [src] as [fd]. 57 | If there are cycles in [mapping], a temporary FD is used to break the cycle. 58 | A mapping from an FD to itself simply clears the close-on-exec flag. 59 | 60 | After this, the new FDs may also be set as blocking or non-blocking, depending on [flags]. *) 61 | -------------------------------------------------------------------------------- /lib_eio/unix/include/fork_action.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | /* A function that runs in the forked child process. 5 | * It must not run any OCaml code, invoke the GC, or even call [malloc]. 6 | * If the action fails then it writes an error message to the FD [errors] and calls [_exit]. 7 | * v_args is the c_action tuple (where field 0 is the function itself). 8 | */ 9 | typedef void fork_fn(int errors, value v_args); 10 | 11 | Caml_inline value Val_fork_fn(fork_fn *fn) { 12 | return caml_copy_nativeint((intnat) fn); 13 | } 14 | 15 | /* Run each C action in the list [v_actions]. 16 | * Sets [errors] to be blocking. Never returns. 17 | */ 18 | void eio_unix_run_fork_actions(int errors, value v_actions); 19 | 20 | /* Write "$fn: $msg" to fd. 21 | * fd must be blocking. 22 | * Ignores failure. */ 23 | void eio_unix_fork_error(int fd, char *fn, char *msg); 24 | -------------------------------------------------------------------------------- /lib_eio/unix/inherit_fds.mli: -------------------------------------------------------------------------------- 1 | (** Plan how to renumber FDs in a child process. *) 2 | 3 | type action = { src : int; dst : int } 4 | (** [{ src; dst}] is (roughly) a request to [dup2(src, dst)]. 5 | 6 | [dst] should not be marked as close-on-exec. 7 | If [src = dst] then simply clear the close-on-exec flag for the FD. 8 | 9 | An FD of -1 means to use a temporary FD (e.g. use [dup] the first time, 10 | with close-on-exec true). This is needed if there are cycles (e.g. we want 11 | to switch FDs 1 and 2). Only one temporary FD is needed at a time, so it 12 | can be reused as necessary. *) 13 | 14 | val plan : (int * int) list -> action list 15 | (** [plan mapping] calculates a sequence of operations to renumber file descriptors so that 16 | FD x afterwards refers to the object that [List.assoc x mapping] referred to at the start. 17 | 18 | It returns a list of actions to be performed in sequence. 19 | Example: [plan [1, 2]] is just [[(2, 1)]]. *) 20 | -------------------------------------------------------------------------------- /lib_eio/unix/pi.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | module type STREAM_SOCKET = sig 4 | include Eio.Net.Pi.STREAM_SOCKET 5 | 6 | val send_msg : t -> fds:Fd.t list -> Cstruct.t list -> int 7 | val recv_msg_with_fds : t -> sw:Switch.t -> max_fds:int -> Cstruct.t list -> int * Fd.t list 8 | 9 | val fd : t -> Fd.t 10 | end 11 | 12 | type (_, _, _) Eio.Resource.pi += 13 | | Stream_socket : ('t, (module STREAM_SOCKET with type t = 't), [> `Platform of [> `Unix] | `Socket | `Stream]) Eio.Resource.pi 14 | 15 | module type FLOW = sig 16 | include Eio.File.Pi.WRITE 17 | include STREAM_SOCKET with type t := t 18 | end 19 | 20 | let flow_handler (type t tag) (module X : FLOW with type t = t and type tag = tag) : (t, _) Eio.Resource.handler = 21 | Eio.Resource.handler @@ 22 | Eio.Resource.bindings (Eio.Net.Pi.stream_socket (module X)) @ 23 | Eio.Resource.bindings (Eio.File.Pi.rw (module X)) @ [ 24 | H (Resource.T, X.fd); 25 | H (Stream_socket, (module X)); 26 | ] 27 | 28 | module type DATAGRAM_SOCKET = sig 29 | include Eio.Net.Pi.DATAGRAM_SOCKET 30 | 31 | val fd : t -> Fd.t 32 | end 33 | 34 | let datagram_handler (type t tag) (module X : DATAGRAM_SOCKET with type t = t and type tag = tag) : (t, _) Eio.Resource.handler = 35 | Eio.Resource.handler @@ 36 | Eio.Resource.bindings (Eio.Net.Pi.datagram_socket (module X)) @ [ 37 | H (Resource.T, X.fd); 38 | ] 39 | 40 | module type LISTENING_SOCKET = sig 41 | include Eio.Net.Pi.LISTENING_SOCKET 42 | 43 | val fd : t -> Fd.t 44 | end 45 | 46 | let listening_socket_handler (type t tag) (module X : LISTENING_SOCKET with type t = t and type tag = tag) 47 | : (t, _) Eio.Resource.handler = 48 | Eio.Resource.handler @@ 49 | Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module X)) @ [ 50 | H (Resource.T, X.fd); 51 | ] 52 | -------------------------------------------------------------------------------- /lib_eio/unix/pi.mli: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | module type STREAM_SOCKET = sig 4 | include Eio.Net.Pi.STREAM_SOCKET 5 | 6 | val send_msg : t -> fds:Fd.t list -> Cstruct.t list -> int 7 | val recv_msg_with_fds : t -> sw:Switch.t -> max_fds:int -> Cstruct.t list -> int * Fd.t list 8 | 9 | val fd : t -> Fd.t 10 | end 11 | 12 | type (_, _, _) Eio.Resource.pi += 13 | | Stream_socket : ('t, (module STREAM_SOCKET with type t = 't), [> `Platform of [> `Unix] | `Socket | `Stream]) Eio.Resource.pi 14 | 15 | module type FLOW = sig 16 | include Eio.File.Pi.WRITE 17 | include STREAM_SOCKET with type t := t 18 | end 19 | 20 | val flow_handler : 21 | (module FLOW with type t = 't and type tag = 'tag) -> 22 | ('t, [`Unix_fd | 'tag Eio.Net.stream_socket_ty | Eio.File.rw_ty]) Eio.Resource.handler 23 | 24 | module type DATAGRAM_SOCKET = sig 25 | include Eio.Net.Pi.DATAGRAM_SOCKET 26 | 27 | val fd : t -> Fd.t 28 | end 29 | 30 | val datagram_handler : 31 | (module DATAGRAM_SOCKET with type t = 't and type tag = 'tag) -> 32 | ('t, [`Unix_fd | 'tag Eio.Net.datagram_socket_ty]) Eio.Resource.handler 33 | 34 | module type LISTENING_SOCKET = sig 35 | include Eio.Net.Pi.LISTENING_SOCKET 36 | 37 | val fd : t -> Fd.t 38 | end 39 | 40 | val listening_socket_handler : 41 | (module LISTENING_SOCKET with type t = 't and type tag = 'tag) -> 42 | ('t, [`Unix_fd | 'tag Eio.Net.listening_socket_ty]) Eio.Resource.handler 43 | -------------------------------------------------------------------------------- /lib_eio/unix/primitives.h: -------------------------------------------------------------------------------- 1 | /* AUTOGENERATED FILE, DO NOT EDIT */ 2 | #define CAML_NAME_SPACE 3 | #define _GNU_SOURCE 4 | #include 5 | CAMLprim value eio_unix_make_string_array(value); 6 | CAMLprim value eio_unix_fork_execve(value); 7 | CAMLprim value eio_unix_fork_chdir(value); 8 | CAMLprim value eio_unix_fork_fchdir(value); 9 | CAMLprim value eio_unix_fork_dups(value); 10 | CAMLprim value eio_unix_cap_enter(value); 11 | CAMLprim value eio_unix_readlinkat(value, value, value); 12 | CAMLprim value eio_unix_is_blocking(value); 13 | -------------------------------------------------------------------------------- /lib_eio/unix/private.ml: -------------------------------------------------------------------------------- 1 | [@@@alert "-unstable"] 2 | 3 | open Eio.Std 4 | open Types 5 | 6 | type _ Effect.t += 7 | | Await_readable : Unix.file_descr -> unit Effect.t 8 | | Await_writable : Unix.file_descr -> unit Effect.t 9 | | Get_monotonic_clock : Eio.Time.Mono.ty r Effect.t 10 | | Pipe : Switch.t -> (source_ty r * sink_ty r) Effect.t 11 | 12 | let await_readable fd = Effect.perform (Await_readable fd) 13 | let await_writable fd = Effect.perform (Await_writable fd) 14 | 15 | let pipe sw = Effect.perform (Pipe sw) 16 | 17 | module Rcfd = Rcfd 18 | module Fork_action = Fork_action 19 | module Thread_pool = Thread_pool 20 | 21 | external eio_readlinkat : Unix.file_descr -> string -> Cstruct.t -> int = "eio_unix_readlinkat" 22 | 23 | let read_link_unix fd path = 24 | match fd with 25 | | None -> Unix.readlink path 26 | | Some fd -> 27 | let rec aux size = 28 | let buf = Cstruct.create_unsafe size in 29 | let len = eio_readlinkat fd path buf in 30 | if len < size then Cstruct.to_string ~len buf 31 | else aux (size * 4) 32 | in 33 | aux 1024 34 | 35 | let read_link fd path = Fd.use_exn_opt "readlink" fd (fun fd -> read_link_unix fd path) 36 | -------------------------------------------------------------------------------- /lib_eio/unix/process.mli: -------------------------------------------------------------------------------- 1 | (** This extends the {!Eio.Process} API with more control over file-descriptors. *) 2 | 3 | open Eio.Std 4 | 5 | (** {2 Types} 6 | 7 | These extend the types in {!Eio.Process} with support for file descriptors. *) 8 | 9 | type ty = [ `Generic | `Unix ] Eio.Process.ty 10 | type 'a t = ([> ty] as 'a) r 11 | 12 | type mgr_ty = [`Generic | `Unix] Eio.Process.mgr_ty 13 | type 'a mgr = ([> mgr_ty] as 'a) r 14 | 15 | module Pi : sig 16 | module type MGR = sig 17 | include Eio.Process.Pi.MGR 18 | 19 | val spawn_unix : 20 | t -> 21 | sw:Switch.t -> 22 | ?cwd:Eio.Fs.dir_ty Eio.Path.t -> 23 | env:string array -> 24 | fds:(int * Fd.t * Fork_action.blocking) list -> 25 | executable:string -> 26 | string list -> 27 | ty r 28 | end 29 | 30 | type (_, _, _) Eio.Resource.pi += 31 | | Mgr_unix : ('t, (module MGR with type t = 't), [> mgr_ty]) Eio.Resource.pi 32 | 33 | val mgr_unix : 34 | (module MGR with type t = 't and type tag = 'tag) -> 35 | ('t, 'tag Eio.Process.mgr_ty) Eio.Resource.handler 36 | end 37 | 38 | module Make_mgr (X : sig 39 | type t 40 | 41 | val spawn_unix : 42 | t -> 43 | sw:Switch.t -> 44 | ?cwd:Eio.Fs.dir_ty Eio.Path.t -> 45 | env:string array -> 46 | fds:(int * Fd.t * Fork_action.blocking) list -> 47 | executable:string -> 48 | string list -> 49 | ty r 50 | end) : Pi.MGR with type t = X.t and type tag = [`Generic | `Unix] 51 | 52 | val spawn_unix : 53 | sw:Switch.t -> 54 | _ mgr -> 55 | ?cwd:Eio.Fs.dir_ty Eio.Path.t -> 56 | fds:(int * Fd.t * Fork_action.blocking) list -> 57 | ?env:string array -> 58 | ?executable:string -> 59 | string list -> 60 | ty r 61 | (** [spawn_unix ~sw mgr ~fds args] spawns a child process running the command [args]. 62 | 63 | The arguments are as for {!Eio.Process.spawn}, 64 | except that it takes a list of FD mappings for {!Fork_action.inherit_fds} 65 | directly, rather than just flows for the standard streams. *) 66 | 67 | val sigchld : Eio.Condition.t 68 | (** {b If} an Eio backend installs a SIGCHLD handler, the handler will broadcast on this condition. 69 | 70 | This allows non-Eio libraries (such as Lwt) to share its signal handler. 71 | 72 | Note: Not all backends install a handler (e.g. eio_linux uses process descriptors instead), 73 | so be sure to call {!install_sigchld_handler} if you need to use this. *) 74 | 75 | val install_sigchld_handler : unit -> unit 76 | (** [install_sigchld_handler ()] sets the signal handler for SIGCHLD to broadcast {!sigchld}. *) 77 | -------------------------------------------------------------------------------- /lib_eio/unix/resource.ml: -------------------------------------------------------------------------------- 1 | type 'a t = ([> `Unix_fd] as 'a) Eio.Resource.t 2 | 3 | type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi 4 | let fd (Eio.Resource.T (t, ops)) = Eio.Resource.get ops T t 5 | 6 | let fd_opt (Eio.Resource.T (t, ops)) = 7 | match Eio.Resource.get_opt ops T with 8 | | Some f -> Some (f t) 9 | | None -> None 10 | -------------------------------------------------------------------------------- /lib_eio/unix/stubs.c: -------------------------------------------------------------------------------- 1 | #include "primitives.h" 2 | 3 | #include 4 | #include 5 | #include 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | static void caml_stat_free_preserving_errno(void *ptr) { 13 | int saved = errno; 14 | caml_stat_free(ptr); 15 | errno = saved; 16 | } 17 | 18 | CAMLprim value eio_unix_is_blocking(value v_fd) { 19 | #ifdef _WIN32 20 | // We should not call this function from Windows 21 | caml_unix_error(EOPNOTSUPP, "Unsupported blocking check on Windows", Nothing); 22 | #else 23 | int fd = Int_val(v_fd); 24 | int r = fcntl(fd, F_GETFL, 0); 25 | if (r == -1) 26 | caml_uerror("fcntl", Nothing); 27 | 28 | return Val_bool((r & O_NONBLOCK) == 0); 29 | #endif 30 | } 31 | 32 | CAMLprim value eio_unix_readlinkat(value v_fd, value v_path, value v_cs) { 33 | #ifdef _WIN32 34 | caml_unix_error(EOPNOTSUPP, "readlinkat not supported on Windows", v_path); 35 | #else 36 | CAMLparam2(v_path, v_cs); 37 | char *path; 38 | value v_ba = Field(v_cs, 0); 39 | value v_off = Field(v_cs, 1); 40 | value v_len = Field(v_cs, 2); 41 | char *buf = (char *)Caml_ba_data_val(v_ba) + Long_val(v_off); 42 | size_t buf_size = Long_val(v_len); 43 | int fd = Int_val(v_fd); 44 | int ret; 45 | caml_unix_check_path(v_path, "readlinkat"); 46 | path = caml_stat_strdup(String_val(v_path)); 47 | caml_enter_blocking_section(); 48 | ret = readlinkat(fd, path, buf, buf_size); 49 | caml_leave_blocking_section(); 50 | caml_stat_free_preserving_errno(path); 51 | if (ret == -1) caml_uerror("readlinkat", v_path); 52 | CAMLreturn(Val_int(ret)); 53 | #endif 54 | } 55 | -------------------------------------------------------------------------------- /lib_eio/unix/thread_pool.mli: -------------------------------------------------------------------------------- 1 | (** A pool of systhreads, to avoid the overhead of creating a new thread for each operation. *) 2 | 3 | type t 4 | 5 | val create : sleep_q:Eio_utils.Zzz.t -> t 6 | (** [create ~sleep_q] is a new thread pool. 7 | 8 | [sleep_q] is used to register a clean-up task to finish idle threads. *) 9 | 10 | val run : t -> (unit -> 'a) -> 'a 11 | (** [run t fn] runs [fn ()] and then marks [t] as closed, releasing all idle threads. *) 12 | 13 | val submit : 14 | t -> 15 | ctx:Eio.Private.Fiber_context.t -> 16 | enqueue:(('a, Eio.Exn.with_bt) result -> unit) -> 17 | (unit -> 'a) -> 18 | unit 19 | (** [submit t ~ctx ~enqueue fn] starts running [fn] in a sys-thread, which uses [enqueue] to return the result. 20 | 21 | If [ctx] is already cancelled then the error is passed to [enqueue] immediately. 22 | Systhreads do not respond to cancellation once running. *) 23 | 24 | type _ Effect.t += Run_in_systhread : (unit -> 'a) -> (('a, Eio.Exn.with_bt) result * t) Effect.t 25 | val run_in_systhread : ?label:string -> (unit -> 'a) -> 'a 26 | -------------------------------------------------------------------------------- /lib_eio/unix/types.ml: -------------------------------------------------------------------------------- 1 | type source_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.source_ty] 2 | type sink_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.sink_ty] 3 | type 'a source = ([> source_ty] as 'a) Eio.Resource.t 4 | type 'a sink = ([> sink_ty] as 'a) Eio.Resource.t 5 | -------------------------------------------------------------------------------- /lib_eio/utils/dla.ml: -------------------------------------------------------------------------------- 1 | let prepare_for_await () = 2 | let state = Atomic.make `Init in 3 | let release () = 4 | if Atomic.get state != `Released then 5 | match Atomic.exchange state `Released with 6 | | `Awaiting enqueue -> enqueue (Ok ()) 7 | | _ -> () 8 | and await () = 9 | if Atomic.get state != `Released then 10 | Eio.Private.Suspend.enter "domain-local-await" @@ fun ctx enqueue -> 11 | let awaiting = `Awaiting enqueue in 12 | if Atomic.compare_and_set state `Init awaiting then ( 13 | Eio.Private.Fiber_context.set_cancel_fn ctx (fun ex -> 14 | if Atomic.compare_and_set state awaiting `Released then ( 15 | enqueue (Error ex) 16 | ) 17 | ) 18 | ) else ( 19 | enqueue (Ok ()) 20 | ) 21 | in 22 | Domain_local_await.{ release; await } 23 | -------------------------------------------------------------------------------- /lib_eio/utils/dla.mli: -------------------------------------------------------------------------------- 1 | val prepare_for_await : unit -> Domain_local_await.t 2 | -------------------------------------------------------------------------------- /lib_eio/utils/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio_utils) 3 | (public_name eio.utils) 4 | (libraries eio psq fmt optint domain-local-await)) 5 | -------------------------------------------------------------------------------- /lib_eio/utils/eio_utils.ml: -------------------------------------------------------------------------------- 1 | (** Utilities for implementing Eio event loops. 2 | 3 | These aren't intended for users of Eio. *) 4 | 5 | module Lf_queue = Lf_queue 6 | module Suspended = Suspended 7 | module Zzz = Zzz 8 | module Dla = Dla 9 | -------------------------------------------------------------------------------- /lib_eio/utils/lf_queue.ml: -------------------------------------------------------------------------------- 1 | (* A lock-free multi-producer, single-consumer, thread-safe queue without support for cancellation. 2 | This makes a good data structure for a scheduler's run queue. 3 | 4 | Based on Vesa Karvonen's examaple at: 5 | https://github.com/ocaml-multicore/picos/blob/07d6c2d391e076b490098c0379d01208b3a9cc96/test/lib/foundation/mpsc_queue.ml 6 | *) 7 | 8 | exception Closed 9 | 10 | (* A list where the end indicates whether the queue is closed. *) 11 | type 'a clist = 12 | | (::) of 'a * 'a clist 13 | | Open 14 | | Closed 15 | 16 | (* [rev_append l1 l2] is like [rev l1 @ l2] *) 17 | let rec rev_append l1 l2 = 18 | match l1 with 19 | | a :: l -> rev_append l (a :: l2) 20 | | Open -> l2 21 | | Closed -> assert false 22 | 23 | let[@tail_mod_cons] rec ( @ ) l1 l2 = 24 | match l1 with 25 | | h1 :: tl -> h1 :: (tl @ l2) 26 | | Open -> l2 27 | | Closed -> assert false 28 | 29 | (* The queue contains [head @ rev tail]. 30 | If [tail] is non-empty then it ends in [Open]. *) 31 | type 'a t = { 32 | mutable head : 'a clist; 33 | tail : 'a clist Atomic.t; 34 | } 35 | 36 | let rec push t x = 37 | match Atomic.get t.tail with 38 | | Closed -> raise Closed 39 | | before -> 40 | let after = x :: before in 41 | if not (Atomic.compare_and_set t.tail before after) then 42 | push t x 43 | 44 | let push_head t x = 45 | match t.head with 46 | | Closed -> raise Closed 47 | | before -> t.head <- x :: before 48 | 49 | let rec pop t = 50 | match t.head with 51 | | x :: xs -> t.head <- xs; Some x 52 | | Closed -> raise Closed 53 | | Open -> 54 | (* We know the tail is open because we just saw the head was open 55 | and we don't run concurrently with [close]. *) 56 | match Atomic.exchange t.tail Open with 57 | | Closed -> assert false 58 | | Open -> None (* Optimise the common case *) 59 | | tail -> 60 | t.head <- rev_append tail Open; 61 | pop t 62 | 63 | let close t = 64 | match Atomic.exchange t.tail Closed with 65 | | Closed -> invalid_arg "Lf_queue already closed!" 66 | | xs -> t.head <- t.head @ rev_append xs Closed 67 | 68 | let is_empty t = 69 | match t.head with 70 | | _ :: _ -> false 71 | | Closed -> raise Closed 72 | | Open -> 73 | match Atomic.get t.tail with 74 | | _ :: _ -> false 75 | | _ -> true 76 | 77 | let create () = { 78 | head = Open; 79 | tail = Atomic.make Open; 80 | } 81 | -------------------------------------------------------------------------------- /lib_eio/utils/lf_queue.mli: -------------------------------------------------------------------------------- 1 | (** A lock-free multi-producer, single-consumer, thread-safe queue without support for cancellation. 2 | This makes a good data structure for a scheduler's run queue. *) 3 | 4 | type 'a t 5 | (** A queue of items of type ['a]. *) 6 | 7 | exception Closed 8 | 9 | val create : unit -> 'a t 10 | (** [create ()] is a new empty queue. *) 11 | 12 | val push : 'a t -> 'a -> unit 13 | (** [push t x] adds [x] to the tail of the queue. 14 | This can be used safely by multiple producer domains, in parallel with the other operations. 15 | @raise Closed if [t] is closed. *) 16 | 17 | val push_head : 'a t -> 'a -> unit 18 | (** [push_head t x] inserts [x] at the head of the queue. 19 | This can only be used by the consumer (if run in parallel with {!pop}, the item might be skipped). 20 | @raise Closed if [t] is closed and empty. *) 21 | 22 | val pop : 'a t -> 'a option 23 | (** [pop t] removes the head item from [t] and returns it. 24 | Returns [None] if [t] is currently empty. 25 | @raise Closed if [t] has been closed and is empty. *) 26 | 27 | val is_empty : 'a t -> bool 28 | (** [is_empty t] is [true] if calling [pop] would return [None]. 29 | @raise Closed if [t] has been closed and is empty. *) 30 | 31 | val close : 'a t -> unit 32 | (** [close t] marks [t] as closed, preventing any further items from being pushed. *) 33 | -------------------------------------------------------------------------------- /lib_eio/utils/suspended.ml: -------------------------------------------------------------------------------- 1 | (** A suspended fiber with its context. *) 2 | 3 | open Effect.Deep 4 | module Trace = Eio.Private.Trace 5 | 6 | type 'a t = { 7 | fiber : Eio.Private.Fiber_context.t; 8 | k : ('a, [`Exit_scheduler]) continuation; 9 | } 10 | 11 | let tid t = Eio.Private.Fiber_context.tid t.fiber 12 | 13 | let continue t v = 14 | Trace.fiber (tid t); 15 | continue t.k v 16 | 17 | let discontinue t ex = 18 | Trace.fiber (tid t); 19 | discontinue t.k ex 20 | -------------------------------------------------------------------------------- /lib_eio/utils/zzz.ml: -------------------------------------------------------------------------------- 1 | module Key = struct 2 | type t = Optint.Int63.t 3 | let compare = Optint.Int63.compare 4 | end 5 | 6 | type item = 7 | | Fiber of unit Suspended.t 8 | | Fn of (unit -> unit) 9 | 10 | module Job = struct 11 | type t = { 12 | time : Mtime.t; 13 | item : item; 14 | } 15 | 16 | let compare a b = Mtime.compare a.time b.time 17 | end 18 | 19 | module Q = Psq.Make(Key)(Job) 20 | 21 | type t = { 22 | mutable sleep_queue: Q.t; 23 | mutable next_id : Optint.Int63.t; 24 | } 25 | 26 | let create () = { sleep_queue = Q.empty; next_id = Optint.Int63.zero } 27 | 28 | let add t time item = 29 | let id = t.next_id in 30 | t.next_id <- Optint.Int63.succ t.next_id; 31 | let sleeper = { Job.time; item } in 32 | t.sleep_queue <- Q.add id sleeper t.sleep_queue; 33 | id 34 | 35 | let remove t id = 36 | t.sleep_queue <- Q.remove id t.sleep_queue 37 | 38 | let pop t ~now = 39 | match Q.min t.sleep_queue with 40 | | Some (_, { Job.time; item }) when time <= now -> 41 | begin 42 | match item with 43 | | Fiber k -> Eio.Private.Fiber_context.clear_cancel_fn k.fiber 44 | | Fn _ -> () 45 | end; 46 | t.sleep_queue <- Option.get (Q.rest t.sleep_queue); 47 | `Due item 48 | | Some (_, { Job.time; _ }) -> `Wait_until time 49 | | None -> `Nothing 50 | -------------------------------------------------------------------------------- /lib_eio/utils/zzz.mli: -------------------------------------------------------------------------------- 1 | (** A set of timers. *) 2 | 3 | (** A handle to a registered timer. *) 4 | module Key : sig 5 | type t 6 | end 7 | 8 | type t 9 | (** A set of timers (implemented as a priority queue). *) 10 | 11 | type item = 12 | | Fiber of unit Suspended.t 13 | | Fn of (unit -> unit) 14 | 15 | val create : unit -> t 16 | (** [create ()] is a fresh empty queue. *) 17 | 18 | val add : t -> Mtime.t -> item -> Key.t 19 | (** [add t time item] adds a new event, due at [time], and returns its ID. 20 | 21 | If [item] is a {!Fiber}, 22 | you must use {!Eio.Private.Fiber_context.set_cancel_fn} on it before calling {!pop}. 23 | Your cancel function should call {!remove} (in addition to resuming it). *) 24 | 25 | val remove : t -> Key.t -> unit 26 | (** [remove t key] removes an event previously added with [add]. *) 27 | 28 | val pop : t -> now:Mtime.t -> [`Due of item | `Wait_until of Mtime.t | `Nothing] 29 | (** [pop ~now t] removes and returns the earliest item due by [now]. 30 | For fibers, it also clears the thread's cancel function. 31 | If no item is due yet, it returns the time the earliest item becomes due. *) 32 | -------------------------------------------------------------------------------- /lib_eio/waiters.ml: -------------------------------------------------------------------------------- 1 | type 'a waiter = { 2 | finished : bool Atomic.t; 3 | enqueue : ('a, exn) result -> unit; 4 | } 5 | 6 | type 'a t = 'a waiter Lwt_dllist.t 7 | 8 | let create = Lwt_dllist.create 9 | 10 | let add_waiter_protected ~mutex t cb = 11 | let w = Lwt_dllist.add_l cb t in 12 | Hook.Node_with_mutex (w, mutex) 13 | 14 | let add_waiter t cb = 15 | let w = Lwt_dllist.add_l cb t in 16 | Hook.Node w 17 | 18 | (* Wake a waiter with the result. 19 | Returns [false] if the waiter got cancelled while we were trying to wake it. *) 20 | let wake { enqueue; finished } r = 21 | if Atomic.compare_and_set finished false true then (enqueue (Ok r); true) 22 | else false (* [cancel] gets called and we enqueue an error *) 23 | 24 | let wake_all (t:_ t) v = 25 | try 26 | while true do 27 | let waiter = Lwt_dllist.take_r t in 28 | ignore (wake waiter v : bool) 29 | done 30 | with Lwt_dllist.Empty -> () 31 | 32 | let rec wake_one t v = 33 | match Lwt_dllist.take_opt_r t with 34 | | None -> `Queue_empty 35 | | Some waiter -> 36 | if wake waiter v then `Ok 37 | else wake_one t v 38 | 39 | let is_empty = Lwt_dllist.is_empty 40 | 41 | let await_internal ~mutex (t:'a t) ctx enqueue = 42 | match Fiber_context.get_error ctx with 43 | | Some ex -> 44 | Option.iter Mutex.unlock mutex; 45 | enqueue (Error ex) 46 | | None -> 47 | let resolved_waiter = ref Hook.null in 48 | let finished = Atomic.make false in 49 | let cancel ex = 50 | if Atomic.compare_and_set finished false true then ( 51 | Hook.remove !resolved_waiter; 52 | enqueue (Error ex) 53 | ) 54 | in 55 | Fiber_context.set_cancel_fn ctx cancel; 56 | let waiter = { enqueue; finished } in 57 | match mutex with 58 | | None -> 59 | resolved_waiter := add_waiter t waiter 60 | | Some mutex -> 61 | resolved_waiter := add_waiter_protected ~mutex t waiter; 62 | Mutex.unlock mutex 63 | 64 | (* Returns a result if the wait succeeds, or raises if cancelled. *) 65 | let await ~mutex op waiters = 66 | Suspend.enter_unchecked op (await_internal ~mutex waiters) 67 | -------------------------------------------------------------------------------- /lib_eio/waiters.mli: -------------------------------------------------------------------------------- 1 | (** A queue of fibers waiting for an event. *) 2 | type 'a t 3 | (* A queue of fibers waiting for something. 4 | Note: an [_ t] is not thread-safe itself. 5 | To use share it between domains, the user is responsible for wrapping it in a mutex. *) 6 | 7 | val create : unit -> 'a t 8 | 9 | val wake_all : 'a t -> 'a -> unit 10 | (** [wake_all t] calls (and removes) all the functions waiting on [t]. 11 | If [t] is shared between domains, the caller must hold the mutex while calling this. *) 12 | 13 | val wake_one : 'a t -> 'a -> [`Ok | `Queue_empty] 14 | (** [wake_one t] is like {!wake_all}, but only calls (and removes) the first waiter in the queue. 15 | If [t] is shared between domains, the caller must hold the mutex while calling this. *) 16 | 17 | val is_empty : 'a t -> bool 18 | (** [is_empty t] checks whether there are any functions waiting on [t]. 19 | If [t] is shared between domains, the caller must hold the mutex while calling this, 20 | and the result is valid until the mutex is released. *) 21 | 22 | val await : 23 | mutex:Mutex.t option -> 24 | string -> 25 | 'a t -> 'a 26 | (** [await ~mutex op t] suspends the current fiber and adds its continuation to [t]. 27 | When the waiter is woken, the fiber is resumed and returns the result. 28 | If [t] can be used from multiple domains: 29 | - [mutex] must be set to the mutex to use to unlock it. 30 | - [mutex] must be already held when calling this function, which will unlock it before blocking. 31 | When [await] returns, [mutex] will have been unlocked. 32 | @raise Cancel.Cancelled if the fiber's context is cancelled *) 33 | 34 | val await_internal : 35 | mutex:Mutex.t option -> 36 | 'a t -> Fiber_context.t -> 37 | (('a, exn) result -> unit) -> unit 38 | (** [await_internal ~mutex t ctx enqueue] is like [await], but the caller has to suspend the fiber. 39 | This also allows wrapping the [enqueue] function. 40 | Calls [enqueue (Error (Cancelled _))] if cancelled. 41 | Note: [enqueue] is called from the triggering domain, 42 | which is currently calling {!wake_one} or {!wake_all} 43 | and must therefore be holding [mutex]. *) 44 | -------------------------------------------------------------------------------- /lib_eio_linux/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio_linux) 3 | (public_name eio_linux) 4 | (enabled_if ; See https://github.com/ocaml/dune/issues/4895 5 | (or (= %{system} "linux") ; Historically, just Linux-x86 6 | (= %{system} "linux_eabihf") ; Historically, Linux-arm32 7 | (= %{system} "linux_elf") ; Historically, Linux-x86_32 8 | (= %{system} "elf"))) ; Historically, Linux-ppc64 9 | (foreign_stubs 10 | (language c) 11 | (flags :standard -D_LARGEFILE64_SOURCE) 12 | (include_dirs ../lib_eio/unix/include) 13 | (names eio_stubs)) 14 | (libraries eio eio.utils eio.unix uring fmt)) 15 | 16 | (rule 17 | (enabled_if 18 | (and 19 | %{bin-available:lintcstubs_arity_cmt} 20 | (or (= %{system} "linux") ; Historically, just Linux-x86 21 | (= %{system} "linux_eabihf") ; Historically, Linux-arm32 22 | (= %{system} "linux_elf") ; Historically, Linux-x86_32 23 | (= %{system} "elf")))) ; Historically, Linux-ppc64 24 | (action 25 | (with-stdout-to 26 | primitives.h.new 27 | (run %{bin:lintcstubs_arity_cmt} %{dep:.eio_linux.objs/byte/eio_linux__Low_level.cmt} %{dep:.eio_linux.objs/byte/eio_linux__Sched.cmt})))) 28 | 29 | (rule 30 | (enabled_if 31 | (and 32 | %{bin-available:lintcstubs_arity_cmt} 33 | (or (= %{system} "linux") ; Historically, just Linux-x86 34 | (= %{system} "linux_eabihf") ; Historically, Linux-arm32 35 | (= %{system} "linux_elf") ; Historically, Linux-x86_32 36 | (= %{system} "elf")))) ; Historically, Linux-ppc64 37 | (alias runtest) 38 | (action 39 | (diff primitives.h primitives.h.new))) 40 | -------------------------------------------------------------------------------- /lib_eio_linux/eio_linux.mli: -------------------------------------------------------------------------------- 1 | (** Eio backend using Linux's io_uring. 2 | 3 | You will normally not use this module directly. 4 | Instead, use {!Eio_main.run} to start an event loop and then use the API in the {!Eio} module. 5 | 6 | However, it is possible to use this module directly if you only want to support recent versions of Linux. *) 7 | 8 | (* 9 | * Copyright (C) 2020-2021 Anil Madhavapeddy 10 | * 11 | * Permission to use, copy, modify, and distribute this software for any 12 | * purpose with or without fee is hereby granted, provided that the above 13 | * copyright notice and this permission notice appear in all copies. 14 | * 15 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 16 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 17 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 18 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 19 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 20 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 21 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 22 | *) 23 | 24 | (** {1 Main Loop} *) 25 | 26 | type stdenv = Eio_unix.Stdenv.base 27 | 28 | val run : 29 | ?queue_depth:int -> 30 | ?n_blocks:int -> 31 | ?block_size:int -> 32 | ?polling_timeout:int -> 33 | ?fallback:([`Msg of string] -> 'a) -> 34 | (stdenv -> 'a) -> 'a 35 | (** Run an event loop using io_uring. 36 | 37 | Uses {!Uring.create} to create the io_uring, 38 | and {!Uring.set_fixed_buffer} to set a [block_size * n_blocks] fixed buffer. 39 | 40 | Note that if Linux resource limits prevent the requested fixed buffer from being allocated 41 | then [run] will continue without one (and log a warning). 42 | 43 | For portable code, you should use {!Eio_main.run} instead, which will use this automatically 44 | if running on Linux with a recent-enough kernel version. 45 | 46 | @param fallback Call this instead if io_uring is not available for some reason. 47 | The argument is a message describing the problem (for logging). 48 | The default simply raises an exception. *) 49 | 50 | module Low_level = Low_level 51 | -------------------------------------------------------------------------------- /lib_eio_linux/err.ml: -------------------------------------------------------------------------------- 1 | let unclassified e = Eio.Exn.create (Eio.Exn.X e) 2 | 3 | let wrap code name arg = 4 | let ex = Eio_unix.Unix_error (code, name, arg) in 5 | match code with 6 | | ECONNREFUSED -> Eio.Net.err (Connection_failure (Refused ex)) 7 | | ECONNRESET | EPIPE -> Eio.Net.err (Connection_reset ex) 8 | | _ -> unclassified ex 9 | 10 | let wrap_fs code name arg = 11 | let e = Eio_unix.Unix_error (code, name, arg) in 12 | match code with 13 | | Unix.EEXIST -> Eio.Fs.err (Already_exists e) 14 | | Unix.ENOENT -> Eio.Fs.err (Not_found e) 15 | | Unix.EXDEV | EPERM | EACCES -> Eio.Fs.err (Permission_denied e) 16 | | _ -> wrap code name arg 17 | -------------------------------------------------------------------------------- /lib_eio_linux/flow.mli: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | val of_fd : Eio_unix.Fd.t -> [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r 4 | 5 | val stdin : Eio_unix.source_ty r 6 | val stdout : Eio_unix.sink_ty r 7 | val stderr : Eio_unix.sink_ty r 8 | 9 | val secure_random : Eio.Flow.source_ty r 10 | -------------------------------------------------------------------------------- /lib_eio_linux/primitives.h: -------------------------------------------------------------------------------- 1 | /* AUTOGENERATED FILE, DO NOT EDIT */ 2 | #define CAML_NAME_SPACE 3 | #define _GNU_SOURCE 4 | #include 5 | CAMLprim value caml_eio_eventfd(value); 6 | CAMLprim value caml_eio_mkdirat(value, value, value); 7 | CAMLprim value caml_eio_renameat(value, value, value, value); 8 | CAMLprim value caml_eio_symlinkat(value, value, value); 9 | CAMLprim value caml_eio_getrandom(value, value, value); 10 | CAMLprim value caml_eio_getdents(value); 11 | CAMLprim value caml_eio_clone3(value, value); 12 | CAMLprim value caml_eio_pidfd_send_signal(value, value); 13 | -------------------------------------------------------------------------------- /lib_eio_linux/tests/basic_eio_linux.ml: -------------------------------------------------------------------------------- 1 | (* basic tests using effects *) 2 | 3 | open Eio_linux.Low_level 4 | open Eio.Std 5 | module Int63 = Optint.Int63 6 | 7 | let setup_log level = 8 | Fmt_tty.setup_std_outputs (); 9 | Logs.set_level level; 10 | Logs.set_reporter (Logs_fmt.reporter ()) 11 | 12 | let () = 13 | setup_log (Some Logs.Debug); 14 | Eio_linux.run @@ fun _stdenv -> 15 | Switch.run @@ fun sw -> 16 | let fd = 17 | openat2 "test.txt" 18 | ~sw 19 | ~access:`R 20 | ~perm:0 21 | ~flags:Uring.Open_flags.empty 22 | ~resolve:Uring.Resolve.empty 23 | in 24 | let buf = alloc_fixed_or_wait () in 25 | let _ = read_exactly fd buf 5 in 26 | print_endline (Uring.Region.to_string ~len:5 buf); 27 | let _ = read_exactly fd ~file_offset:(Int63.of_int 3) buf 3 in 28 | print_endline (Uring.Region.to_string ~len:3 buf); 29 | free_fixed buf; 30 | (* With a sleep: *) 31 | let buf = alloc_fixed_or_wait () in 32 | let _ = read_exactly fd buf 5 in 33 | Logs.debug (fun l -> l "sleeping at %f" (Unix.gettimeofday ())); 34 | sleep_until (Mtime.add_span (Mtime_clock.now ()) Mtime.Span.s |> Option.get); 35 | print_endline (Uring.Region.to_string ~len:5 buf); 36 | let _ = read_exactly fd ~file_offset:(Int63.of_int 3) buf 3 in 37 | print_endline (Uring.Region.to_string ~len:3 buf); 38 | free_fixed buf 39 | -------------------------------------------------------------------------------- /lib_eio_linux/tests/bench_noop.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let n_fibers = [1; 2; 3; 4; 5; 10; 20; 30; 40; 50; 100; 500; 1000; 10000] 4 | 5 | let main ~clock = 6 | Printf.printf "n_fibers, ns/iter, promoted/iter\n%!"; 7 | n_fibers |> List.iter (fun n_fibers -> 8 | let n_iters = 1000000 / n_fibers in 9 | Gc.full_major (); 10 | let _minor0, prom0, _major0 = Gc.counters () in 11 | let t0 = Eio.Time.now clock in 12 | Switch.run (fun sw -> 13 | for _ = 1 to n_fibers do 14 | Fiber.fork ~sw (fun () -> 15 | for _ = 1 to n_iters do 16 | Eio_linux.Low_level.noop () 17 | done 18 | ) 19 | done 20 | ); 21 | let t1 = Eio.Time.now clock in 22 | let time_total = t1 -. t0 in 23 | let n_total = n_fibers * n_iters in 24 | let time_per_iter = time_total /. float n_total in 25 | let _minor1, prom1, _major1 = Gc.counters () in 26 | let prom = prom1 -. prom0 in 27 | Printf.printf "%5d, %.2f, %7.4f\n%!" n_fibers (1e9 *. time_per_iter) (prom /. float n_total) 28 | ) 29 | 30 | let () = 31 | Eio_linux.run @@ fun env -> 32 | main ~clock:(Eio.Stdenv.clock env) 33 | -------------------------------------------------------------------------------- /lib_eio_linux/tests/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eurcp_lib) 3 | (enabled_if ; See https://github.com/ocaml/dune/issues/4895 4 | (or (= %{system} "linux") ; Historically, just Linux-x86 5 | (= %{system} "linux_eabihf") ; Historically, Linux-arm32 6 | (= %{system} "linux_elf") ; Historically, Linux-x86_32 7 | (= %{system} "elf"))) ; Historically, Linux-ppc64 8 | (modules eurcp_lib) 9 | (libraries eio_linux logs)) 10 | 11 | (executable 12 | (name eurcp) 13 | (enabled_if ; See https://github.com/ocaml/dune/issues/4895 14 | (or (= %{system} "linux") ; Historically, just Linux-x86 15 | (= %{system} "linux_eabihf") ; Historically, Linux-arm32 16 | (= %{system} "linux_elf") ; Historically, Linux-x86_32 17 | (= %{system} "elf"))) ; Historically, Linux-ppc64 18 | (modules eurcp) 19 | (libraries cmdliner logs.cli logs.fmt fmt.tty fmt.cli eurcp_lib)) 20 | 21 | (executable 22 | (name basic_eio_linux) 23 | (enabled_if ; See https://github.com/ocaml/dune/issues/4895 24 | (or (= %{system} "linux") ; Historically, just Linux-x86 25 | (= %{system} "linux_eabihf") ; Historically, Linux-arm32 26 | (= %{system} "linux_elf") ; Historically, Linux-x86_32 27 | (= %{system} "elf"))) ; Historically, Linux-ppc64 28 | (modules basic_eio_linux) 29 | (libraries logs.fmt fmt.tty eurcp_lib)) 30 | 31 | (executables 32 | (names bench_noop) 33 | (enabled_if ; See https://github.com/ocaml/dune/issues/4895 34 | (or (= %{system} "linux") ; Historically, just Linux-x86 35 | (= %{system} "linux_eabihf") ; Historically, Linux-arm32 36 | (= %{system} "linux_elf") ; Historically, Linux-x86_32 37 | (= %{system} "elf"))) ; Historically, Linux-ppc64 38 | (modules bench_noop) 39 | (libraries eio_linux)) 40 | 41 | (test 42 | (name test) 43 | (package eio_linux) 44 | (build_if ; See https://github.com/ocaml/dune/issues/4895 45 | (or (= %{system} "linux") ; Historically, just Linux-x86 46 | (= %{system} "linux_eabihf") ; Historically, Linux-arm32 47 | (= %{system} "linux_elf") ; Historically, Linux-x86_32 48 | (= %{system} "elf"))) ; Historically, Linux-ppc64 49 | (modules test) 50 | (libraries alcotest eio_linux logs)) 51 | 52 | (mdx 53 | (package eio_linux) 54 | (enabled_if ; See https://github.com/ocaml/dune/issues/4895 55 | (or (= %{system} "linux") ; Historically, just Linux-x86 56 | (= %{system} "linux_eabihf") ; Historically, Linux-arm32 57 | (= %{system} "linux_elf") ; Historically, Linux-x86_32 58 | (= %{system} "elf"))) ; Historically, Linux-ppc64 59 | (deps (package eio_linux))) 60 | -------------------------------------------------------------------------------- /lib_eio_linux/tests/eurcp.ml: -------------------------------------------------------------------------------- 1 | let setup_log style_renderer level = 2 | Fmt_tty.setup_std_outputs ?style_renderer (); 3 | Logs.set_level level; 4 | Logs.set_reporter (Logs_fmt.reporter ()) 5 | 6 | open Cmdliner 7 | 8 | let cmd = 9 | let setup_log = 10 | Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) in 11 | let infile = 12 | let doc = "Source filename to copy from" in 13 | Arg.(required & pos 0 (some file) None & info [] ~docv:"SOURCE_FILE" ~doc) in 14 | let outfile = 15 | let doc = "Target filename to copy to" in 16 | Arg.(required & pos 1 (some string) None & info [] ~docv:"TARGET_FILE" ~doc) in 17 | let block_size = 18 | let doc = "Block size per chunk in bytes" in 19 | Arg.(value & opt int (32 * 1024) & info ["block-size"] ~docv:"BYTES" ~doc) in 20 | let queue_depth = 21 | let doc = "Number of async requests in parallel" in 22 | Arg.(value & opt int 64 & info ["queue-depth"] ~docv:"ENTRIES" ~doc) in 23 | let doc = "copy a file using async effect-based io_uring" in 24 | let man = 25 | [ 26 | `S "DESCRIPTION"; 27 | `P "$(tname) copies a file using Linux io_uring."; 28 | ] 29 | in 30 | let info = Cmd.info "eurcp" ~version:"1.0.0" ~doc ~man in 31 | Cmd.v info Term.(const Eurcp_lib.run_cp $ block_size $ queue_depth $ infile $ outfile $ setup_log) 32 | 33 | let () = 34 | match Cmd.eval cmd with 35 | | 0 -> exit (if Logs.err_count () > 0 then 1 else 0) 36 | | _ -> exit 1 37 | -------------------------------------------------------------------------------- /lib_eio_linux/tests/eurcp_lib.ml: -------------------------------------------------------------------------------- 1 | (* cp(1) built with effects. *) 2 | 3 | open Eio.Std 4 | 5 | module U = Eio_linux.Low_level 6 | module Int63 = Optint.Int63 7 | 8 | let read_then_write_chunk infd outfd file_offset len = 9 | let buf = U.alloc_fixed_or_wait () in 10 | Logs.debug (fun l -> l "r/w start %a (%d)" Int63.pp file_offset len); 11 | U.read_exactly ~file_offset infd buf len; 12 | U.write ~file_offset outfd buf len; 13 | Logs.debug (fun l -> l "r/w done %a (%d)" Int63.pp file_offset len); 14 | U.free_fixed buf 15 | 16 | let copy_file infd outfd insize block_size = 17 | Switch.run @@ fun sw -> 18 | let rec copy_block file_offset = 19 | let remaining = Int63.(sub insize file_offset) in 20 | if remaining <> Int63.zero then ( 21 | let len = Int63.to_int (min (Int63.of_int block_size) remaining) in 22 | Fiber.fork ~sw (fun () -> read_then_write_chunk infd outfd file_offset len); 23 | copy_block Int63.(add file_offset (of_int len)) 24 | ) 25 | in 26 | copy_block Int63.zero 27 | 28 | let run_cp block_size queue_depth infile outfile () = 29 | Eio_linux.run ~queue_depth ~n_blocks:queue_depth ~block_size @@ fun _stdenv -> 30 | Switch.run @@ fun sw -> 31 | let infd = 32 | U.openat2 infile 33 | ~sw ~seekable:true 34 | ~access:`R 35 | ~flags:Uring.Open_flags.empty 36 | ~perm:0 37 | ~resolve:Uring.Resolve.empty 38 | in 39 | let outfd = 40 | U.openat2 outfile 41 | ~sw 42 | ~seekable:true 43 | ~access:`RW 44 | ~flags:Uring.Open_flags.(creat + trunc) 45 | ~resolve:Uring.Resolve.empty 46 | ~perm:0o644 47 | in 48 | let insize = (U.fstat infd).size in 49 | Logs.debug (fun l -> l "eurcp: %s -> %s size %a queue %d bs %d" 50 | infile 51 | outfile 52 | Int63.pp insize 53 | queue_depth 54 | block_size); 55 | copy_file infd outfd insize block_size; 56 | Logs.debug (fun l -> l "eurcp: done") 57 | -------------------------------------------------------------------------------- /lib_eio_linux/tests/fd_sharing.md: -------------------------------------------------------------------------------- 1 | # Setting up the environment 2 | 3 | ```ocaml 4 | # #require "eio_linux";; 5 | ``` 6 | 7 | ```ocaml 8 | open Eio.Std 9 | ``` 10 | 11 | # Tests 12 | 13 | One domain closes an FD after another domain has enqueued a uring operation mentioning it. 14 | 15 | ```ocaml 16 | # Eio_linux.run @@ fun env -> 17 | let dm = env#domain_mgr in 18 | Switch.run @@ fun sw -> 19 | let m = Mutex.create () in 20 | Mutex.lock m; 21 | let r, w = Eio_unix.pipe sw in 22 | let ready, set_ready = Promise.create () in 23 | Fiber.both 24 | (fun () -> 25 | Eio.Domain_manager.run dm (fun () -> 26 | Fiber.both 27 | (fun () -> 28 | traceln "Domain 1 enqueuing read on FD"; 29 | let buf = Cstruct.create 1 in 30 | match Eio.Flow.single_read r buf with 31 | | _ -> assert false 32 | | exception End_of_file -> traceln "Read EOF" 33 | ) 34 | (fun () -> 35 | (* We have enqueued a read request, but not yet submitted it to Linux. 36 | Wait for [m] to prevent submission until the main domain is ready. *) 37 | traceln "Waiting for domain 0..."; 38 | Promise.resolve set_ready (); 39 | Mutex.lock m; 40 | traceln "Domain 1 flushing queue" 41 | ) 42 | ) 43 | ) 44 | (fun () -> 45 | Promise.await ready; 46 | traceln "Domain 0 closing FD"; 47 | Eio.Flow.close r; 48 | Fiber.yield (); 49 | traceln "Domain 0 closed FD; waking domain 1"; 50 | Mutex.unlock m; 51 | (* Allow the read to complete. *) 52 | Eio.Flow.close w 53 | );; 54 | +Domain 1 enqueuing read on FD 55 | +Waiting for domain 0... 56 | +Domain 0 closing FD 57 | +Domain 0 closed FD; waking domain 1 58 | +Domain 1 flushing queue 59 | +Read EOF 60 | - : unit = () 61 | ``` 62 | -------------------------------------------------------------------------------- /lib_eio_posix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio_posix) 3 | (public_name eio_posix) 4 | (enabled_if (= %{os_type} "Unix")) 5 | (foreign_stubs 6 | (language c) 7 | (flags :standard -D_LARGEFILE64_SOURCE) 8 | (include_dirs ../lib_eio/unix/include) 9 | (names eio_posix_stubs)) 10 | (libraries eio eio.utils eio.unix fmt iomux)) 11 | 12 | (rule 13 | (targets config.ml) 14 | (enabled_if (= %{os_type} "Unix")) 15 | (action (run ./include/discover.exe))) 16 | 17 | (rule 18 | (enabled_if (and (= %{os_type} "Unix") %{bin-available:lintcstubs_arity_cmt})) 19 | (action 20 | (with-stdout-to 21 | primitives.h.new 22 | (run %{bin:lintcstubs_arity_cmt} %{dep:.eio_posix.objs/byte/eio_posix__Low_level.cmt})))) 23 | 24 | (rule 25 | (enabled_if (and (= %{os_type} "Unix") %{bin-available:lintcstubs_arity_cmt})) 26 | (alias runtest) 27 | (action 28 | (diff primitives.h primitives.h.new))) 29 | -------------------------------------------------------------------------------- /lib_eio_posix/eio_posix.ml: -------------------------------------------------------------------------------- 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 | module Low_level = Low_level 18 | 19 | type stdenv = Eio_unix.Stdenv.base 20 | 21 | let run main = 22 | (* SIGPIPE makes no sense in a modern application. *) 23 | Sys.(set_signal sigpipe Signal_ignore); 24 | Eio_unix.Process.install_sigchld_handler (); 25 | let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> _ Eio_unix.source) in 26 | let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> _ Eio_unix.sink) in 27 | let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> _ Eio_unix.sink) in 28 | Domain_mgr.run_event_loop main @@ object (_ : stdenv) 29 | method stdin = stdin 30 | method stdout = stdout 31 | method stderr = stderr 32 | method debug = Eio.Private.Debug.v 33 | method clock = Time.clock 34 | method mono_clock = Time.mono_clock 35 | method net = Net.v 36 | method process_mgr = Process.mgr 37 | method domain_mgr = Domain_mgr.v 38 | method cwd = ((Fs.cwd, "") :> Eio.Fs.dir_ty Eio.Path.t) 39 | method fs = ((Fs.fs, "") :> Eio.Fs.dir_ty Eio.Path.t) 40 | method secure_random = Flow.secure_random 41 | method backend_id = "posix" 42 | end 43 | -------------------------------------------------------------------------------- /lib_eio_posix/eio_posix.mli: -------------------------------------------------------------------------------- 1 | (** Fallback Eio backend for POSIX systems. *) 2 | 3 | type stdenv = Eio_unix.Stdenv.base 4 | (** The type of the standard set of resources available on POSIX systems. *) 5 | 6 | val run : (stdenv -> 'a) -> 'a 7 | (** [run main] runs an event loop and calls [main stdenv] inside it. 8 | 9 | For portable code, you should use {!Eio_main.run} instead, which will call this for you if appropriate. *) 10 | 11 | module Low_level = Low_level 12 | (** Low-level API for making POSIX calls directly. *) 13 | -------------------------------------------------------------------------------- /lib_eio_posix/err.ml: -------------------------------------------------------------------------------- 1 | type Eio.Exn.Backend.t += 2 | | Outside_sandbox of string 3 | | Absolute_path 4 | | Invalid_leaf of string 5 | 6 | let unclassified_error e = Eio.Exn.create (Eio.Exn.X e) 7 | 8 | let () = 9 | Eio.Exn.Backend.register_pp (fun f -> function 10 | | Outside_sandbox path -> Fmt.pf f "Outside_sandbox (%S)" path; true 11 | | Absolute_path -> Fmt.pf f "Absolute_path"; true 12 | | Invalid_leaf x -> Fmt.pf f "Invalid_leaf %S" x; true 13 | | _ -> false 14 | ) 15 | 16 | let wrap code name arg = 17 | let e = Eio_unix.Unix_error (code, name, arg) in 18 | match code with 19 | | EEXIST -> Eio.Fs.err (Already_exists e) 20 | | ENOENT -> Eio.Fs.err (Not_found e) 21 | | EXDEV | EACCES | EPERM -> Eio.Fs.err (Permission_denied e) 22 | | ECONNREFUSED -> Eio.Net.err (Connection_failure (Refused e)) 23 | | ECONNRESET | EPIPE -> Eio.Net.err (Connection_reset e) 24 | | _ -> unclassified_error e 25 | 26 | let run fn x = 27 | try fn x 28 | with Unix.Unix_error (code, name, arg) -> 29 | raise (wrap code name arg) 30 | -------------------------------------------------------------------------------- /lib_eio_posix/include/discover.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let optional_flags = [ 4 | "O_DSYNC"; 5 | "O_RESOLVE_BENEATH"; 6 | "O_PATH"; 7 | ] 8 | 9 | let () = 10 | C.main ~name:"discover" (fun c -> 11 | let c_flags = ["-D_LARGEFILE64_SOURCE"; "-D_XOPEN_SOURCE=700"; "-D_DARWIN_C_SOURCE"; "-D_GNU_SOURCE"; "-D_BSD_SOURCE"] in 12 | let includes = ["sys/types.h"; "sys/stat.h"; "fcntl.h"] in 13 | let extra_flags, missing_defs = 14 | C.C_define.import c ~c_flags ~includes 15 | C.C_define.Type.(List.map (fun name -> name, Switch) optional_flags) 16 | |> List.partition_map (function 17 | | name, C.C_define.Value.Switch true -> Left (name, C.C_define.Type.Int) 18 | | name, Switch false -> 19 | Right (Printf.sprintf "let %s = None" (String.lowercase_ascii name)) 20 | | _ -> assert false 21 | ) 22 | in 23 | let present_defs = 24 | C.C_define.import c ~c_flags 25 | ~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"; "limits.h"] 26 | C.C_define.Type.(extra_flags @ [ 27 | "O_RDONLY", Int; 28 | "O_RDWR", Int; 29 | "O_WRONLY", Int; 30 | 31 | "O_APPEND", Int; 32 | "O_CLOEXEC", Int; 33 | "O_CREAT", Int; 34 | "O_DIRECTORY", Int; 35 | "O_EXCL", Int; 36 | "O_NOCTTY", Int; 37 | "O_NOFOLLOW", Int; 38 | "O_NONBLOCK", Int; 39 | "O_SYNC", Int; 40 | "O_TRUNC", Int; 41 | 42 | "AT_FDCWD", Int; 43 | "AT_SYMLINK_NOFOLLOW", Int; 44 | 45 | "IOV_MAX", Int; 46 | ]) 47 | |> List.map (function 48 | | name, C.C_define.Value.Int v when List.mem name optional_flags -> 49 | Printf.sprintf "let %s = Some 0x%x" (String.lowercase_ascii name) v 50 | | name, C.C_define.Value.Int v -> 51 | Printf.sprintf "let %s = 0x%x" (String.lowercase_ascii name) v 52 | | _ -> assert false 53 | ) 54 | in 55 | let defs = present_defs @ missing_defs in 56 | C.Flags.write_lines "config.ml" defs 57 | ) 58 | -------------------------------------------------------------------------------- /lib_eio_posix/include/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (modules discover) 4 | (libraries dune-configurator)) 5 | -------------------------------------------------------------------------------- /lib_eio_posix/path.ml: -------------------------------------------------------------------------------- 1 | type token = 2 | | Empty 3 | | DotDot 4 | | String of string 5 | 6 | let rec tokenise = function 7 | | [] -> [] 8 | | ["."] -> [Empty] (* "path/." is the same as "path/" *) 9 | | "." :: xs -> tokenise xs (* Skip dot if not at end *) 10 | | "" :: xs -> Empty :: tokenise xs 11 | | ".." :: xs -> DotDot :: tokenise xs 12 | | x :: xs -> String x :: tokenise xs 13 | 14 | module Rel = struct 15 | type t = 16 | | Leaf of { basename : string; trailing_slash : bool } 17 | | Self (* A final "." *) 18 | | Child of string * t 19 | | Parent of t 20 | 21 | let rec parse = function 22 | | [] -> Self 23 | | [String basename; Empty] -> Leaf { basename; trailing_slash = true } 24 | | [String basename] -> Leaf { basename; trailing_slash = false } 25 | | [DotDot] -> Parent Self 26 | | DotDot :: xs -> Parent (parse xs) 27 | | String s :: xs -> Child (s, parse xs) 28 | | Empty :: xs -> parse xs 29 | 30 | let parse s = parse (tokenise s) 31 | 32 | let rec concat a b = 33 | match a with 34 | | Leaf { basename; trailing_slash = _ } -> Child (basename, b) 35 | | Child (name, xs) -> Child (name, concat xs b) 36 | | Parent xs -> Parent (concat xs b) 37 | | Self -> b 38 | 39 | let rec dump f = function 40 | | Child (x, xs) -> Fmt.pf f "%S / %a" x dump xs 41 | | Parent xs -> Fmt.pf f ".. / %a" dump xs 42 | | Self -> Fmt.pf f "." 43 | | Leaf { basename; trailing_slash } -> 44 | Fmt.pf f "%S" basename; 45 | if trailing_slash then Fmt.pf f " /" 46 | 47 | let rec segs = function 48 | | Leaf { basename; trailing_slash } -> [if trailing_slash then basename ^ "/" else basename] 49 | | Self -> [""] 50 | | Child (x, xs) -> x :: segs xs 51 | | Parent Self -> [".."] 52 | | Parent xs -> ".." :: segs xs 53 | 54 | let to_string = function 55 | | Self -> "." 56 | | t -> String.concat "/" (segs t) 57 | end 58 | 59 | type t = 60 | | Relative of Rel.t 61 | | Absolute of Rel.t 62 | 63 | let rec parse_abs = function 64 | | "" :: [] -> Absolute Self 65 | | "" :: xs -> parse_abs xs 66 | | xs -> Absolute (Rel.parse xs) 67 | 68 | let parse = function 69 | | "" -> Relative Self 70 | | s -> 71 | match String.split_on_char '/' s with 72 | | "" :: path -> parse_abs path 73 | | path -> Relative (Rel.parse path) 74 | 75 | let dump f = function 76 | | Relative r -> Rel.dump f r 77 | | Absolute r -> Fmt.pf f "/ %a" Rel.dump r 78 | 79 | let to_string = function 80 | | Relative r -> Rel.to_string r 81 | | Absolute r -> String.concat "/" ("" :: Rel.segs r) 82 | -------------------------------------------------------------------------------- /lib_eio_posix/path.mli: -------------------------------------------------------------------------------- 1 | module Rel : sig 2 | type t = 3 | | Leaf of { basename : string; trailing_slash : bool } 4 | | Self (* A final "." *) 5 | | Child of string * t 6 | | Parent of t 7 | 8 | val concat : t -> t -> t 9 | 10 | val to_string : t -> string 11 | 12 | val dump : t Fmt.t 13 | end 14 | 15 | type t = 16 | | Relative of Rel.t 17 | | Absolute of Rel.t 18 | 19 | val parse : string -> t 20 | (** Note: 21 | [parse "" = Relative Self] 22 | [parse ".." = Relative (Parent Self)] *) 23 | 24 | val to_string : t -> string 25 | 26 | val dump : t Fmt.t 27 | -------------------------------------------------------------------------------- /lib_eio_posix/process.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | module Process_impl = struct 4 | type t = Low_level.Process.t 5 | type tag = [ `Generic | `Unix ] 6 | 7 | let pid = Low_level.Process.pid 8 | 9 | let await t = 10 | match Eio.Promise.await @@ Low_level.Process.exit_status t with 11 | | Unix.WEXITED i -> `Exited i 12 | | Unix.WSIGNALED i -> `Signaled i 13 | | Unix.WSTOPPED _ -> assert false 14 | 15 | let signal = Low_level.Process.signal 16 | end 17 | 18 | let process = 19 | let handler = Eio.Process.Pi.process (module Process_impl) in 20 | fun proc -> Eio.Resource.T (proc, handler) 21 | 22 | module Impl = struct 23 | module T = struct 24 | type t = unit 25 | 26 | let spawn_unix () ~sw ?cwd ~env ~fds ~executable args = 27 | let actions = Low_level.Process.Fork_action.[ 28 | inherit_fds fds; 29 | execve executable ~argv:(Array.of_list args) ~env 30 | ] in 31 | let with_actions cwd fn = match cwd with 32 | | None -> fn actions 33 | | Some ((dir, path) : Eio.Fs.dir_ty Eio.Path.t) -> 34 | match Fs.as_posix_dir dir with 35 | | None -> Fmt.invalid_arg "cwd is not an OS directory!" 36 | | Some dirfd -> 37 | Switch.run ~name:"spawn_unix" @@ fun launch_sw -> 38 | let cwd = Low_level.openat ~sw:launch_sw ~mode:0 dirfd path Low_level.Open_flags.(rdonly + directory) in 39 | fn (Low_level.Process.Fork_action.fchdir cwd :: actions) 40 | in 41 | with_actions cwd @@ fun actions -> 42 | process (Low_level.Process.spawn ~sw actions) 43 | end 44 | 45 | include Eio_unix.Process.Make_mgr (T) 46 | end 47 | 48 | let mgr : Eio_unix.Process.mgr_ty r = 49 | let h = Eio_unix.Process.Pi.mgr_unix (module Impl) in 50 | Eio.Resource.T ((), h) 51 | -------------------------------------------------------------------------------- /lib_eio_posix/sched.mli: -------------------------------------------------------------------------------- 1 | (** The scheduler keeps track of all suspended fibers and resumes them as appropriate. 2 | 3 | Each Eio domain has one scheduler, which keeps a queue of runnable 4 | processes plus a record of all fibers waiting for IO operations to complete. *) 5 | 6 | type t 7 | 8 | type exit 9 | (** This is equivalent to [unit], but indicates that a function returning this will call {!next} 10 | and so does not return until the whole event loop is finished. Such functions should normally 11 | be called in tail position. *) 12 | 13 | val with_sched : (t -> 'a) -> 'a 14 | (** [with_sched fn] sets up a scheduler and calls [fn t]. 15 | Typically [fn] will call {!run}. 16 | When [fn] returns, the scheduler's resources are freed. *) 17 | 18 | val run : 19 | extra_effects:exit Effect.Deep.effect_handler -> 20 | t -> ('a -> 'b) -> 'a -> 'b [@@alert "-unstable"] 21 | (** [run ~extra_effects t f x] starts an event loop using [t] and runs [f x] as the root fiber within it. 22 | 23 | Unknown effects are passed to [extra_effects]. *) 24 | 25 | val next : t -> exit 26 | (** [next t] asks the scheduler to transfer control to the next runnable fiber, 27 | or wait for an event from the OS if there is none. This should normally be 28 | called in tail position from an effect handler. *) 29 | 30 | val await_readable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit 31 | (** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for reading. *) 32 | 33 | val await_writable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit 34 | (** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for writing. *) 35 | 36 | val await_timeout : t -> unit Eio_utils.Suspended.t -> Mtime.t -> exit 37 | (** [await_timeout t k time] adds [time, k] to the timer. 38 | 39 | When [time] is reached, [k] is resumed. Cancelling [k] removes the entry from the timer. *) 40 | 41 | val enter : string -> (t -> 'a Eio_utils.Suspended.t -> exit) -> 'a 42 | (** [enter op fn] suspends the current fiber and runs [fn t k] in the scheduler's context. 43 | 44 | [fn] should either resume [k] immediately itself, or call one of the [await_*] functions above. 45 | 46 | [op] is used when tracing. *) 47 | -------------------------------------------------------------------------------- /lib_eio_posix/test/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package eio_posix) 3 | (enabled_if (= %{os_type} "Unix")) 4 | (deps (package eio_posix))) 5 | 6 | (tests 7 | (names open_beneath test_await) 8 | (package eio_posix) 9 | (build_if (= %{os_type} "Unix")) 10 | (libraries eio_posix)) 11 | -------------------------------------------------------------------------------- /lib_eio_posix/test/path.md: -------------------------------------------------------------------------------- 1 | ```ocaml 2 | # #require "eio_posix" 3 | ``` 4 | ```ocaml 5 | module P = Eio_posix__Path 6 | 7 | let dump f p = 8 | Fmt.pf f "%a (%S)" P.dump p (P.to_string p) 9 | ``` 10 | 11 | ```ocaml 12 | # #install_printer dump;; 13 | 14 | # P.parse "foo" 15 | - : P.t = "foo" ("foo") 16 | 17 | # P.parse "foo/bar" 18 | - : P.t = "foo" / "bar" ("foo/bar") 19 | 20 | # P.parse "foo//bar/" 21 | - : P.t = "foo" / "bar" / ("foo/bar/") 22 | 23 | # P.parse "foo/." 24 | - : P.t = "foo" / ("foo/") 25 | 26 | # P.parse "foo/./" 27 | - : P.t = "foo" / ("foo/") 28 | 29 | # P.parse "" 30 | - : P.t = . (".") 31 | 32 | # P.parse "." 33 | - : P.t = . (".") 34 | 35 | # P.parse ".." 36 | - : P.t = .. / . ("..") 37 | 38 | # P.parse "./../.././.." 39 | - : P.t = .. / .. / .. / . ("../../..") 40 | 41 | # P.parse "/" 42 | - : P.t = / . ("/") 43 | 44 | # P.parse "/etc" 45 | - : P.t = / "etc" ("/etc") 46 | 47 | # P.parse "/etc/passwd" 48 | - : P.t = / "etc" / "passwd" ("/etc/passwd") 49 | 50 | # P.parse "/." 51 | - : P.t = / . ("/") 52 | 53 | # P.parse "/.." 54 | - : P.t = / .. / . ("/..") 55 | 56 | # P.parse "//../" 57 | - : P.t = / .. / . ("/..") 58 | ``` 59 | -------------------------------------------------------------------------------- /lib_eio_posix/test/poll.md: -------------------------------------------------------------------------------- 1 | ```ocaml 2 | # #require "eio_posix";; 3 | ``` 4 | 5 | ```ocaml 6 | open Eio.Std 7 | ``` 8 | 9 | ## Closing an FD removes it from the multiplexer 10 | 11 | Closing an FD automatically removes it from epoll's set, meaning that you have 12 | to re-add it using `EPOLL_CTL_ADD`, not `EPOLL_CTL_MOD`. 13 | 14 | ```ocaml 15 | # Eio_posix.run @@ fun _env -> 16 | Switch.run (fun sw -> 17 | let r, w = Eio_unix.pipe sw in 18 | Eio_unix.Fd.use_exn "await_writable" (Eio_unix.Resource.fd w) @@ fun fd -> 19 | Eio_unix.await_writable fd 20 | ); 21 | (* [r] and [w] are now closed. We'll likely allocate the same FD numbers the second time. 22 | Check we don't get confused and try to [EPOLL_CTL_MOD] them. *) 23 | Switch.run (fun sw -> 24 | let r, w = Eio_unix.pipe sw in 25 | Eio_unix.Fd.use_exn "await_writable" (Eio_unix.Resource.fd w) @@ fun fd -> 26 | Eio_unix.await_writable fd 27 | );; 28 | - : unit = () 29 | ``` 30 | -------------------------------------------------------------------------------- /lib_eio_posix/test/test_await.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let () = 4 | Eio_posix.run @@ fun _ -> 5 | let a, b = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in 6 | (* Start awaiting readable/writable state, but cancel immediately. *) 7 | try 8 | Eio.Cancel.sub (fun cc -> 9 | Fiber.all [ 10 | (fun () -> Eio_unix.await_readable a); 11 | (fun () -> Eio_unix.await_writable b); 12 | (fun () -> Eio.Cancel.cancel cc Exit); 13 | ]; 14 | assert false 15 | ) 16 | with Eio.Cancel.Cancelled _ -> 17 | (* Now wait for something else. Will fail if the old FDs are still being waited on. *) 18 | let c, d = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in 19 | Unix.close a; 20 | Unix.close b; 21 | Fiber.first 22 | (fun () -> Eio_unix.await_readable c) 23 | (fun () -> Eio_unix.await_writable d); 24 | Unix.close c; 25 | Unix.close d 26 | -------------------------------------------------------------------------------- /lib_eio_posix/time.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | module Mono_clock = struct 4 | type t = unit 5 | type time = Mtime.t 6 | 7 | let now () = Mtime_clock.now () 8 | let sleep_until () time = Low_level.sleep_until time 9 | end 10 | 11 | let mono_clock : Mtime.t Eio.Time.clock_ty r = 12 | let handler = Eio.Time.Pi.clock (module Mono_clock) in 13 | Eio.Resource.T ((), handler) 14 | 15 | module Clock = struct 16 | type t = unit 17 | type time = float 18 | 19 | let now () = Unix.gettimeofday () 20 | 21 | let sleep_until () time = 22 | (* todo: use the realtime clock directly instead of converting to monotonic time. 23 | That is needed to handle adjustments to the system clock correctly. *) 24 | let d = time -. Unix.gettimeofday () in 25 | Eio.Time.Mono.sleep mono_clock d 26 | end 27 | 28 | let clock : float Eio.Time.clock_ty r = 29 | let handler = Eio.Time.Pi.clock (module Clock) in 30 | Eio.Resource.T ((), handler) 31 | -------------------------------------------------------------------------------- /lib_eio_windows/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio_windows) 3 | (public_name eio_windows) 4 | (library_flags :standard -cclib -lbcrypt -cclib -lntdll) 5 | (enabled_if (= %{os_type} "Win32")) 6 | (foreign_stubs 7 | (language c) 8 | (include_dirs ../lib_eio/unix/include) 9 | (names eio_windows_stubs)) 10 | (c_library_flags :standard -lbcrypt -lntdll) 11 | (libraries eio eio.unix eio.utils fmt)) 12 | 13 | (rule 14 | (targets config.ml) 15 | (enabled_if (= %{os_type} "Win32")) 16 | (action (run ./include/discover.exe))) 17 | -------------------------------------------------------------------------------- /lib_eio_windows/eio_windows.ml: -------------------------------------------------------------------------------- 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 | module Low_level = Low_level 18 | 19 | type stdenv = Eio_unix.Stdenv.base 20 | 21 | let run main = 22 | let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> _ Eio_unix.source) in 23 | let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> _ Eio_unix.sink) in 24 | let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> _ Eio_unix.sink) in 25 | Domain_mgr.run_event_loop main @@ object (_ : stdenv) 26 | method stdin = stdin 27 | method stdout = stdout 28 | method stderr = stderr 29 | method debug = Eio.Private.Debug.v 30 | method clock = Time.clock 31 | method mono_clock = Time.mono_clock 32 | method net = Net.v 33 | method domain_mgr = Domain_mgr.v 34 | method cwd = ((Fs.cwd, "") :> Eio.Fs.dir_ty Eio.Path.t) 35 | method fs = ((Fs.fs, "") :> Eio.Fs.dir_ty Eio.Path.t) 36 | method process_mgr = failwith "process operations not supported on Windows yet" 37 | method secure_random = Flow.secure_random 38 | method backend_id = "windows" 39 | end 40 | -------------------------------------------------------------------------------- /lib_eio_windows/eio_windows.mli: -------------------------------------------------------------------------------- 1 | (** Fallback Eio backend for Windows using OCaml's [Unix.select]. *) 2 | 3 | type stdenv = Eio_unix.Stdenv.base 4 | (** An extended version of {!Eio.Stdenv.base} with some extra features available on Windows. *) 5 | 6 | val run : (stdenv -> 'a) -> 'a 7 | (** [run main] runs an event loop and calls [main stdenv] inside it. 8 | 9 | For portable code, you should use {!Eio_main.run} instead, which will call this for you if appropriate. *) 10 | 11 | module Low_level = Low_level 12 | (** Low-level API. *) 13 | -------------------------------------------------------------------------------- /lib_eio_windows/err.ml: -------------------------------------------------------------------------------- 1 | type Eio.Exn.Backend.t += 2 | | Outside_sandbox of string * string 3 | | Absolute_path 4 | | Invalid_leaf of string 5 | 6 | let unclassified_error e = Eio.Exn.create (Eio.Exn.X e) 7 | 8 | let () = 9 | Eio.Exn.Backend.register_pp (fun f -> function 10 | | Outside_sandbox (path, dir) -> Fmt.pf f "Outside_sandbox (%S, %S)" path dir; true 11 | | Absolute_path -> Fmt.pf f "Absolute_path"; true 12 | | Invalid_leaf x -> Fmt.pf f "Invalid_leaf %S" x; true 13 | | _ -> false 14 | ) 15 | 16 | let wrap code name arg = 17 | let e = Eio_unix.Unix_error (code, name, arg) in 18 | match code with 19 | | EEXIST -> Eio.Fs.err (Already_exists e) 20 | | ENOENT -> Eio.Fs.err (Not_found e) 21 | | EXDEV | EACCES | EPERM -> Eio.Fs.err (Permission_denied e) 22 | | ECONNREFUSED -> Eio.Net.err (Connection_failure (Refused e)) 23 | | ECONNRESET | EPIPE | ECONNABORTED -> Eio.Net.err (Connection_reset e) 24 | | _ -> unclassified_error e 25 | 26 | let run fn x = 27 | try fn x 28 | with Unix.Unix_error (code, name, arg) -> 29 | raise (wrap code name arg) 30 | -------------------------------------------------------------------------------- /lib_eio_windows/include/discover.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let () = 4 | C.main ~name:"discover" (fun c -> 5 | let defs = 6 | C.C_define.import c ~c_flags:["-D_LARGEFILE64_SOURCE"] 7 | ~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"; "winternl.h"; "ntdef.h"] 8 | C.C_define.Type.[ 9 | "_O_RDONLY", Int; 10 | "_O_RDWR", Int; 11 | "_O_WRONLY", Int; 12 | "_O_APPEND", Int; 13 | "_O_CREAT", Int; 14 | "_O_NOINHERIT", Int; 15 | "_O_TRUNC", Int; 16 | "_O_EXCL", Int; 17 | 18 | (* Desired Access *) 19 | "GENERIC_READ", Int; 20 | "GENERIC_WRITE", Int; 21 | "SYNCHRONIZE", Int; 22 | "FILE_APPEND_DATA", Int; 23 | 24 | (* Create Disposition *) 25 | "FILE_SUPERSEDE", Int; 26 | "FILE_CREATE", Int; 27 | "FILE_OPEN", Int; 28 | "FILE_OPEN_IF", Int; 29 | "FILE_OVERWRITE", Int; 30 | "FILE_OVERWRITE_IF", Int; 31 | 32 | (* Create Options *) 33 | "FILE_DIRECTORY_FILE", Int; 34 | "FILE_NON_DIRECTORY_FILE", Int; 35 | "FILE_NO_INTERMEDIATE_BUFFERING", Int; 36 | "FILE_WRITE_THROUGH", Int; 37 | "FILE_SEQUENTIAL_ONLY", Int; 38 | ] 39 | |> List.map (function 40 | | name, C.C_define.Value.Int v -> 41 | let name = 42 | if name.[0] = '_' then 43 | let name_length = String.length name in 44 | String.sub name 1 (name_length - 1) 45 | else name 46 | in 47 | Printf.sprintf "let %s = 0x%x" (String.lowercase_ascii name) v 48 | | _ -> assert false 49 | ) 50 | in 51 | C.Flags.write_lines "config.ml" defs 52 | ) 53 | -------------------------------------------------------------------------------- /lib_eio_windows/include/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (modules discover) 4 | (libraries dune-configurator)) 5 | -------------------------------------------------------------------------------- /lib_eio_windows/sched.mli: -------------------------------------------------------------------------------- 1 | (** The scheduler keeps track of all suspended fibers and resumes them as appropriate. 2 | 3 | Each Eio domain has one scheduler, which keeps a queue of runnable 4 | processes plus a record of all fibers waiting for IO operations to complete. *) 5 | 6 | type t 7 | 8 | type exit 9 | (** This is equivalent to [unit], but indicates that a function returning this will call {!next} 10 | and so does not return until the whole event loop is finished. Such functions should normally 11 | be called in tail position. *) 12 | 13 | val with_sched : (t -> 'a) -> 'a 14 | (** [with_sched fn] sets up a scheduler and calls [fn t]. 15 | Typically [fn] will call {!run}. 16 | When [fn] returns, the scheduler's resources are freed. *) 17 | 18 | val run : 19 | extra_effects:exit Effect.Deep.effect_handler -> 20 | t -> ('a -> 'b) -> 'a -> 'b [@@alert "-unstable"] 21 | (** [run ~extra_effects t f x] starts an event loop using [t] and runs [f x] as the root fiber within it. 22 | 23 | Unknown effects are passed to [extra_effects]. *) 24 | 25 | val next : t -> exit 26 | (** [next t] asks the scheduler to transfer control to the next runnable fiber, 27 | or wait for an event from the OS if there is none. This should normally be 28 | called in tail position from an effect handler. *) 29 | 30 | val await_readable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit 31 | (** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for reading. *) 32 | 33 | val await_writable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit 34 | (** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for writing. *) 35 | 36 | val await_timeout : t -> unit Eio_utils.Suspended.t -> Mtime.t -> exit 37 | (** [await_timeout t k time] adds [time, k] to the timer. 38 | 39 | When [time] is reached, [k] is resumed. Cancelling [k] removes the entry from the timer. *) 40 | 41 | val enter : (t -> 'a Eio_utils.Suspended.t -> exit) -> 'a 42 | (** [enter fn] suspends the current fiber and runs [fn t k] in the scheduler's context. 43 | 44 | [fn] should either resume [k] immediately itself, or call one of the [await_*] functions above. *) 45 | -------------------------------------------------------------------------------- /lib_eio_windows/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package eio_windows) 4 | (build_if (= %{os_type} "Win32")) 5 | (libraries alcotest kcas eio.mock eio_windows)) 6 | -------------------------------------------------------------------------------- /lib_eio_windows/test/test.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | module Timeout = struct 4 | let test clock () = 5 | let t0 = Unix.gettimeofday () in 6 | Eio.Time.sleep clock 0.01; 7 | let t1 = Unix.gettimeofday () in 8 | let diff = t1 -. t0 in 9 | if diff >= 0.01 then () else Alcotest.failf "Expected bigger difference than %f" diff 10 | 11 | 12 | let tests env = [ 13 | "timeout", `Quick, test env#clock 14 | ] 15 | end 16 | 17 | module Random = struct 18 | let test_random env () = 19 | let src = Eio.Stdenv.secure_random env in 20 | let b1 = Cstruct.create 8 in 21 | let b2 = Cstruct.create 8 in 22 | Eio.Flow.read_exact src b1; 23 | Eio.Flow.read_exact src b2; 24 | Alcotest.(check bool) "different random" (not (Cstruct.equal b1 b2)) true 25 | 26 | let tests env = [ 27 | "different", `Quick, test_random env 28 | ] 29 | end 30 | 31 | module Dla = struct 32 | 33 | let test_dla () = 34 | let open Kcas in 35 | let x = Loc.make 0 in 36 | let y = Loc.make 0 in 37 | let foreign_domain = Domain.spawn @@ fun () -> 38 | let x = Loc.get_as (fun x -> Retry.unless (x <> 0); x) x in 39 | Loc.set y 22; 40 | x 41 | in 42 | Loc.set x 20; 43 | let y' = Loc.get_as (fun y -> Retry.unless (y <> 0); y) y in 44 | Alcotest.(check int) "correct y" y' 22; 45 | let ans = y' + Domain.join foreign_domain in 46 | Alcotest.(check int) "answer" ans 42 47 | 48 | let tests = [ 49 | "dla", `Quick, test_dla 50 | ] 51 | end 52 | 53 | module Await_fd = struct 54 | let test_cancel () = 55 | let a, b = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in 56 | (* Start awaiting readable/writable state, but cancel immediately. *) 57 | try 58 | Eio.Cancel.sub (fun cc -> 59 | Fiber.all [ 60 | (fun () -> Eio_unix.await_readable a); 61 | (fun () -> Eio_unix.await_writable b); 62 | (fun () -> Eio.Cancel.cancel cc Exit); 63 | ]; 64 | assert false 65 | ) 66 | with Eio.Cancel.Cancelled _ -> 67 | (* Now wait for something else. Will fail if the old FDs are still being waited on. *) 68 | let c, d = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in 69 | Unix.close a; 70 | Unix.close b; 71 | Fiber.first 72 | (fun () -> Eio_unix.await_readable c) 73 | (fun () -> Eio_unix.await_writable d); 74 | Unix.close c; 75 | Unix.close d 76 | 77 | let tests = [ 78 | "cancel", `Quick, test_cancel; 79 | ] 80 | end 81 | 82 | 83 | let () = 84 | Eio_windows.run @@ fun env -> 85 | Alcotest.run ~bail:true "eio_windows" [ 86 | "net", Test_net.tests env; 87 | "fs", Test_fs.tests env; 88 | "timeout", Timeout.tests env; 89 | "random", Random.tests env; 90 | "dla", Dla.tests; 91 | "await", Await_fd.tests; 92 | ] 93 | -------------------------------------------------------------------------------- /lib_eio_windows/time.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | module Mono_clock = struct 4 | type t = unit 5 | type time = Mtime.t 6 | 7 | let now () = Mtime_clock.now () 8 | let sleep_until () time = Low_level.sleep_until time 9 | end 10 | 11 | let mono_clock : Mtime.t Eio.Time.clock_ty r = 12 | let handler = Eio.Time.Pi.clock (module Mono_clock) in 13 | Eio.Resource.T ((), handler) 14 | 15 | module Clock = struct 16 | type t = unit 17 | type time = float 18 | 19 | let now () = Unix.gettimeofday () 20 | 21 | let sleep_until () time = 22 | (* todo: use the realtime clock directly instead of converting to monotonic time. 23 | That is needed to handle adjustments to the system clock correctly. *) 24 | let d = time -. Unix.gettimeofday () in 25 | Eio.Time.Mono.sleep mono_clock d 26 | end 27 | 28 | let clock : float Eio.Time.clock_ty r = 29 | let handler = Eio.Time.Pi.clock (module Clock) in 30 | Eio.Resource.T ((), handler) 31 | -------------------------------------------------------------------------------- /lib_eio_windows/unix_cstruct.ml: -------------------------------------------------------------------------------- 1 | (* See the end of the file for the license *) 2 | external stub_write : Unix.file_descr -> Cstruct.t -> int = "eio_windows_cstruct_write" 3 | 4 | let rec write fd buf = 5 | if Cstruct.length buf > 0 then begin 6 | let n = stub_write fd buf in 7 | write fd @@ Cstruct.shift buf n 8 | end 9 | 10 | let writev fd bufs = List.iter (write fd) bufs 11 | 12 | external read : Unix.file_descr -> Cstruct.t -> int = "eio_windows_cstruct_read" 13 | 14 | (* From mirage/ocaml-cstruct 15 | Copyright (c) 2012 Anil Madhavapeddy 16 | Copyright (c) 2012 Pierre Chambart 17 | Copyright (c) Christiano F. Haesbaert 18 | Copyright (c) Citrix Inc 19 | Copyright (c) David Sheets 20 | Copyright (c) Drup 21 | Copyright (c) Hannes Mehnert 22 | Copyright (c) Jeremy Yallop 23 | Copyright (c) Mindy Preston 24 | Copyright (c) Nicolas Ojeda Bar 25 | Copyright (c) Richard Mortier 26 | Copyright (c) Rudi Grinberg 27 | Copyright (c) Thomas Gazagnaire 28 | Copyright (c) Thomas Leonard 29 | Copyright (c) Vincent Bernardoff 30 | Copyright (c) pqwy 31 | 32 | Permission to use, copy, modify, and distribute this software for any 33 | purpose with or without fee is hereby granted, provided that the above 34 | copyright notice and this permission notice appear in all copies. 35 | 36 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 37 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 38 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 39 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 40 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 41 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 42 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -------------------------------------------------------------------------------- /lib_main/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name eio_main) 3 | (public_name eio_main) 4 | (libraries 5 | (select linux_backend.ml from 6 | (eio_linux -> linux_backend.enabled.ml) 7 | ( -> linux_backend.disabled.ml)) 8 | (select posix_backend.ml from 9 | (eio_posix -> posix_backend.enabled.ml) 10 | ( -> posix_backend.disabled.ml)) 11 | (select windows_backend.ml from 12 | (eio_windows -> windows_backend.enabled.ml) 13 | ( -> windows_backend.disabled.ml)) 14 | )) 15 | -------------------------------------------------------------------------------- /lib_main/eio_main.ml: -------------------------------------------------------------------------------- 1 | let force run fn = 2 | run ~fallback:(fun (`Msg msg) -> failwith msg) fn 3 | 4 | let run fn = 5 | match Sys.getenv_opt "EIO_BACKEND" with 6 | | Some ("io-uring" | "linux") -> force Linux_backend.run fn 7 | | Some "posix" -> force Posix_backend.run fn 8 | | Some "windows" -> force Windows_backend.run fn 9 | | None | Some "" -> 10 | Linux_backend.run fn ~fallback:(fun _ -> 11 | Posix_backend.run fn ~fallback:(fun _ -> 12 | force Windows_backend.run fn 13 | ) 14 | ) 15 | | Some x -> Fmt.failwith "Unknown Eio backend %S (from $EIO_BACKEND)" x 16 | -------------------------------------------------------------------------------- /lib_main/eio_main.mli: -------------------------------------------------------------------------------- 1 | (** Select a suitable event loop for Eio. *) 2 | 3 | val run : (Eio_unix.Stdenv.base -> 'a) -> 'a 4 | (** [run fn] runs an event loop and then calls [fn env] within it. 5 | 6 | [env] provides access to the process's environment (file-system, network, etc). 7 | [env] itself and the resources inside it can be shared safely between Eio domains. 8 | 9 | When [fn] ends, the event loop finishes. 10 | 11 | This should be called once, at the entry point of an application. 12 | It {b must not} be called by libraries. 13 | Doing so would force the library to depend on Unix 14 | (making it unusable from unikernels or browsers), 15 | prevent the user from choosing their own event loop, 16 | and prevent using the library with other Eio libraries. 17 | 18 | [run] will select an appropriate event loop for the current platform. 19 | On many systems, it will use {!Eio_posix.run}. 20 | 21 | On recent-enough versions of Linux, it will use {!Eio_linux.run}. 22 | You can override this by setting the $EIO_BACKEND environment variable to 23 | either "linux", "posix" or "windows". *) 24 | -------------------------------------------------------------------------------- /lib_main/linux_backend.disabled.ml: -------------------------------------------------------------------------------- 1 | let run ~fallback _ = fallback (`Msg "The io_uring backend was disabled at compile-time") 2 | -------------------------------------------------------------------------------- /lib_main/linux_backend.enabled.ml: -------------------------------------------------------------------------------- 1 | let run ~fallback fn = Eio_linux.run ~fallback (fun env -> fn (env :> Eio_unix.Stdenv.base)) 2 | -------------------------------------------------------------------------------- /lib_main/posix_backend.disabled.ml: -------------------------------------------------------------------------------- 1 | let run ~fallback _ = fallback (`Msg "The POSIX backend was disabled at compile-time") 2 | -------------------------------------------------------------------------------- /lib_main/posix_backend.enabled.ml: -------------------------------------------------------------------------------- 1 | let run ~fallback:_ fn = Eio_posix.run (fun env -> fn (env :> Eio_unix.Stdenv.base)) 2 | -------------------------------------------------------------------------------- /lib_main/windows_backend.disabled.ml: -------------------------------------------------------------------------------- 1 | let run ~fallback _ = fallback (`Msg "The Windows backend was disabled at compile-time") 2 | -------------------------------------------------------------------------------- /lib_main/windows_backend.enabled.ml: -------------------------------------------------------------------------------- 1 | let run ~fallback:_ fn = Eio_windows.run (fun env -> fn (env :> Eio_unix.Stdenv.base)) 2 | -------------------------------------------------------------------------------- /stress/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names stress_semaphore stress_proc stress_release) 3 | (libraries eio_main)) 4 | -------------------------------------------------------------------------------- /stress/stress_proc.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let n_domains = 4 4 | let n_rounds = 100 5 | let n_procs_per_round_per_domain = 100 / n_domains 6 | 7 | let run_in_domain mgr = 8 | let echo n = Eio.Process.parse_out mgr Eio.Buf_read.line ["sh"; "-c"; "echo " ^ string_of_int n] in 9 | Switch.run @@ fun sw -> 10 | for j = 1 to n_procs_per_round_per_domain do 11 | Fiber.fork ~sw (fun () -> 12 | let result = echo j in 13 | assert (int_of_string result = j); 14 | (* traceln "OK: %d" j *) 15 | ) 16 | done 17 | 18 | let main ~dm mgr = 19 | let t0 = Unix.gettimeofday () in 20 | for i = 1 to n_rounds do 21 | Switch.run ~name:"round" (fun sw -> 22 | for _ = 1 to n_domains - 1 do 23 | Fiber.fork ~sw (fun () -> Eio.Domain_manager.run dm (fun () -> run_in_domain mgr)) 24 | done; 25 | Fiber.fork ~sw (fun () -> run_in_domain mgr); 26 | ); 27 | if true then traceln "Finished round %d/%d" i n_rounds 28 | done; 29 | let t1 = Unix.gettimeofday () in 30 | let n_procs = n_rounds * n_procs_per_round_per_domain * n_domains in 31 | traceln "Finished process stress test: ran %d processes in %.2fs (using %d domains)" n_procs (t1 -. t0) n_domains 32 | 33 | let () = 34 | Eio_main.run @@ fun env -> 35 | main ~dm:env#domain_mgr env#process_mgr 36 | -------------------------------------------------------------------------------- /stress/stress_release.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | let n_domains = 3 4 | let n_rounds = 1000 5 | 6 | (* Each worker domain loops, creating resources and attaching them to the 7 | shared switch [sw]. It also randomly close resources, cancelling the hook. 8 | The main domain finishes the switch while this is happening, freeing all 9 | registered resources. At the end, we check that the number of resources 10 | allocated matches the number freed. *) 11 | let[@warning "-52"] run_domain ~sw ~hooks resources = 12 | try 13 | while true do 14 | Atomic.incr resources; 15 | let hook = Switch.on_release_cancellable sw (fun () -> Atomic.decr resources) in 16 | if Random.bool () then ( 17 | (* Manually close an existing resource. *) 18 | let i = Random.int (Array.length hooks) in 19 | if Switch.try_remove_hook hooks.(i) then 20 | Atomic.decr resources 21 | ); 22 | if Random.bool () then ( 23 | let i = Random.int (Array.length hooks) in 24 | hooks.(i) <- hook; 25 | ) 26 | done 27 | with Invalid_argument "Switch finished!" -> 28 | () 29 | 30 | let main ~pool = 31 | let resources = Array.init n_domains (fun _ -> Atomic.make 0) in 32 | (* Keep up to 10 hooks so we can cancel them randomly too. *) 33 | let hooks = Array.make 10 Switch.null_hook in 34 | for _ = 1 to n_rounds do 35 | (* if i mod 1000 = 0 then traceln "Round %d" i; *) 36 | Switch.run (fun domains_sw -> 37 | Switch.run (fun sw -> 38 | resources |> Array.iter (fun resources -> 39 | Fiber.fork ~sw:domains_sw (fun () -> 40 | Eio.Executor_pool.submit_exn pool ~weight:1.0 (fun () -> run_domain ~sw ~hooks resources) 41 | ) 42 | ); 43 | (* traceln "Wait for domains to start"; *) 44 | while Atomic.get (resources.(n_domains - 1)) < 20 do 45 | Domain.cpu_relax () 46 | done; 47 | ); 48 | (* The child domains will start to finish as they find that 49 | [sw] is not accepting new resources. They may each still 50 | create one last resource. *) 51 | ); 52 | (* All child domains are now finished. *) 53 | let x = Array.fold_left (fun acc resources -> acc + Atomic.get resources) 0 resources in 54 | if x <> 0 then Fmt.failwith "%d resources still open at end!" x 55 | done 56 | 57 | let () = 58 | Eio_main.run @@ fun env -> 59 | let domain_mgr = Eio.Stdenv.domain_mgr env in 60 | Switch.run @@ fun sw -> 61 | let pool = Eio.Executor_pool.create ~sw ~domain_count:n_domains domain_mgr in 62 | main ~pool 63 | -------------------------------------------------------------------------------- /stress/stress_semaphore.ml: -------------------------------------------------------------------------------- 1 | open Eio.Std 2 | 3 | (* Three domains fighting over 2 semaphore tokens, 4 | with domains cancelling if they don't get served quickly. *) 5 | 6 | let n_domains = 3 7 | let n_tokens = 2 8 | let n_iters = 100_000 9 | 10 | let main ~domain_mgr = 11 | let sem = Eio.Semaphore.make n_tokens in 12 | Switch.run (fun sw -> 13 | for _ = 1 to n_domains do 14 | Fiber.fork ~sw (fun () -> 15 | Eio.Domain_manager.run domain_mgr (fun () -> 16 | let i = ref 0 in 17 | while !i < n_iters do 18 | let got = ref false in 19 | Fiber.first 20 | (fun () -> Eio.Semaphore.acquire sem; got := true) 21 | (fun () -> Fiber.yield ()); 22 | if !got then ( 23 | incr i; 24 | Eio.Semaphore.release sem; 25 | ) else ( 26 | (* traceln "yield" *) 27 | ) 28 | done 29 | ) 30 | ) 31 | done; 32 | ); 33 | assert (Eio.Semaphore.get_value sem = n_tokens); 34 | print_endline "OK" 35 | 36 | let () = 37 | Eio_main.run @@ fun env -> 38 | main ~domain_mgr:(Eio.Stdenv.domain_mgr env) 39 | -------------------------------------------------------------------------------- /tests/debug.md: -------------------------------------------------------------------------------- 1 | # Setting up the environment 2 | 3 | ```ocaml 4 | # #require "eio_main";; 5 | # open Eio.Std;; 6 | ``` 7 | 8 | ## Overriding tracing 9 | 10 | ```ocaml 11 | # Eio_main.run @@ fun env -> 12 | let debug = Eio.Stdenv.debug env in 13 | let my_traceln = { 14 | Eio.Debug.traceln = fun ?__POS__:_ fmt -> Fmt.epr ("++" ^^ fmt ^^ "@.") 15 | } in 16 | Fiber.both 17 | (fun () -> 18 | Fiber.with_binding debug#traceln my_traceln @@ fun () -> 19 | Fiber.both 20 | (fun () -> traceln "a") 21 | (fun () -> Fiber.yield (); traceln "b") 22 | ) 23 | (fun () -> traceln "c");; 24 | ++a 25 | +c 26 | ++b 27 | - : unit = () 28 | ``` 29 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package eio_main) 3 | (enabled_if (<> %{os_type} "Win32")) 4 | (deps 5 | (env_var "EIO_BACKEND") 6 | (package eio_main))) 7 | -------------------------------------------------------------------------------- /tests/exn.md: -------------------------------------------------------------------------------- 1 | # Setting up the environment 2 | 3 | ```ocaml 4 | # #require "eio.mock";; 5 | ``` 6 | 7 | Adjust this to test backtrace printing: 8 | ```ocaml 9 | let () = Printexc.record_backtrace false 10 | ``` 11 | 12 | ```ocaml 13 | let non_io a = 14 | try failwith a 15 | with ex -> ex, Printexc.get_raw_backtrace () 16 | 17 | let not_found = 18 | try raise @@ Eio.Fs.err (Not_found Eio_mock.Simulated_failure) 19 | with ex -> 20 | let bt = Printexc.get_raw_backtrace () in 21 | let ex = Eio.Exn.add_context ex "opening file 'foo'" in 22 | ex, bt 23 | 24 | let denied = 25 | try raise @@ Eio.Fs.err (Permission_denied Eio_mock.Simulated_failure) 26 | with ex -> 27 | let bt = Printexc.get_raw_backtrace () in 28 | let ex = Eio.Exn.add_context ex "saving file 'bar'" in 29 | ex, bt 30 | 31 | let combine a b = 32 | fst @@ Eio.Exn.combine a b 33 | ``` 34 | 35 | ## Combining exceptions 36 | 37 | Combining regular exceptions: 38 | 39 | ```ocaml 40 | # raise @@ combine (non_io "a") (non_io "b");; 41 | Exception: Multiple exceptions: 42 | - Failure("a") 43 | - Failure("b") 44 | ``` 45 | 46 | An IO error and a regular exception becomes a regular (non-IO) multiple exception: 47 | 48 | ```ocaml 49 | # raise @@ combine (non_io "a") not_found;; 50 | Exception: 51 | Multiple exceptions: 52 | - Failure("a") 53 | - Eio.Io Fs Not_found Simulated_failure, 54 | opening file 'foo' 55 | ``` 56 | 57 | Combining IO exceptions produces another IO exception, 58 | so that if you want to e.g. log all IO errors and continue then that still works: 59 | 60 | ```ocaml 61 | # Fmt.pr "%a@." Eio.Exn.pp (combine denied not_found);; 62 | Eio.Io Multiple_io 63 | - Fs Permission_denied Simulated_failure, saving file 'bar' 64 | - Fs Not_found Simulated_failure, opening file 'foo' 65 | - : unit = () 66 | ``` 67 | 68 | They form a tree, because the context information may be useful too: 69 | 70 | ```ocaml 71 | let combined = 72 | let e = Eio.Exn.combine denied not_found in 73 | let ex = Eio.Exn.add_context (fst e) "processing request" in 74 | ex, snd e 75 | ``` 76 | 77 | ```ocaml 78 | # Fmt.pr "%a@." Eio.Exn.pp (combine combined not_found);; 79 | Eio.Io Multiple_io 80 | - Multiple_io 81 | - Fs Permission_denied Simulated_failure, saving file 'bar' 82 | - Fs Not_found Simulated_failure, opening file 'foo', processing request 83 | - Fs Not_found Simulated_failure, opening file 'foo' 84 | - : unit = () 85 | ``` 86 | -------------------------------------------------------------------------------- /tests/fd_passing.md: -------------------------------------------------------------------------------- 1 | # Setting up the environment 2 | 3 | ```ocaml 4 | # #require "eio_main";; 5 | ``` 6 | 7 | ```ocaml 8 | open Eio.Std 9 | 10 | let ( / ) = Eio.Path.( / ) 11 | 12 | let run ?clear:(paths = []) fn = 13 | Eio_main.run @@ fun env -> 14 | let cwd = Eio.Stdenv.cwd env in 15 | List.iter (fun p -> Eio.Path.rmtree ~missing_ok:true (cwd / p)) paths; 16 | fn env 17 | ``` 18 | 19 | ```ocaml 20 | (* Send [to_send] to [w] and get it from [r], then read it. *) 21 | let test ~to_send r w = 22 | Switch.run @@ fun sw -> 23 | Fiber.both 24 | (fun () -> Eio_unix.Net.send_msg w [Cstruct.of_string "x"] ~fds:to_send) 25 | (fun () -> 26 | let buf = Cstruct.of_string "?" in 27 | let got, fds = Eio_unix.Net.recv_msg_with_fds ~sw r ~max_fds:2 [buf] in 28 | let msg = Cstruct.to_string buf ~len:got in 29 | traceln "Got: %S plus %d FDs" msg (List.length fds); 30 | fds |> List.iter (fun fd -> 31 | Eio_unix.Fd.use_exn "read" fd @@ fun fd -> 32 | let len = Unix.lseek fd 0 Unix.SEEK_CUR in 33 | ignore (Unix.lseek fd 0 Unix.SEEK_SET : int); 34 | traceln "Read: %S" (really_input_string (Unix.in_channel_of_descr fd) len); 35 | ) 36 | ) 37 | 38 | let with_tmp_file dir id fn = 39 | let path = (dir / (Printf.sprintf "tmp-%s.txt" id)) in 40 | Eio.Path.with_open_out path ~create:(`Exclusive 0o600) @@ fun file -> 41 | Fun.protect 42 | (fun () -> 43 | Eio.Flow.copy_string id file; 44 | fn (Option.get (Eio_unix.Resource.fd_opt file)) 45 | ) 46 | ~finally:(fun () -> Eio.Path.unlink path) 47 | ``` 48 | 49 | ## Tests 50 | 51 | Using a socket-pair: 52 | 53 | ```ocaml 54 | # run ~clear:["tmp-foo.txt"; "tmp-bar.txt"] @@ fun env -> 55 | with_tmp_file env#cwd "foo" @@ fun fd1 -> 56 | with_tmp_file env#cwd "bar" @@ fun fd2 -> 57 | Switch.run @@ fun sw -> 58 | let r, w = Eio_unix.Net.socketpair_stream ~sw ~domain:PF_UNIX ~protocol:0 () in 59 | test ~to_send:[fd1; fd2] r w;; 60 | +Got: "x" plus 2 FDs 61 | +Read: "foo" 62 | +Read: "bar" 63 | - : unit = () 64 | ``` 65 | 66 | Using named sockets: 67 | 68 | ```ocaml 69 | # run ~clear:["tmp-foo.txt"] @@ fun env -> 70 | let net = env#net in 71 | with_tmp_file env#cwd "foo" @@ fun fd -> 72 | Switch.run @@ fun sw -> 73 | let addr = `Unix "test.socket" in 74 | let server = Eio.Net.listen ~sw net ~reuse_addr:true ~backlog:1 addr in 75 | let r, w = Fiber.pair 76 | (fun () -> Eio.Net.connect ~sw net addr) 77 | (fun () -> fst (Eio.Net.accept ~sw server)) 78 | in 79 | test ~to_send:[fd] r w;; 80 | +Got: "x" plus 1 FDs 81 | +Read: "foo" 82 | - : unit = () 83 | ``` 84 | -------------------------------------------------------------------------------- /tests/lf_queue.md: -------------------------------------------------------------------------------- 1 | # A lock-free queue for schedulers 2 | 3 | ```ocaml 4 | # #require "eio.utils";; 5 | ``` 6 | 7 | ```ocaml 8 | module Q = Eio_utils.Lf_queue;; 9 | ``` 10 | 11 | ## A basic run 12 | 13 | ```ocaml 14 | # let q : int Q.t = Q.create ();; 15 | val q : int Q.t = 16 | # Q.push q 1;; 17 | - : unit = () 18 | # Q.push q 2;; 19 | - : unit = () 20 | # Q.pop q;; 21 | - : int option = Some 1 22 | # Q.pop q;; 23 | - : int option = Some 2 24 | # Q.pop q;; 25 | - : int option = None 26 | # Q.pop q;; 27 | - : int option = None 28 | # Q.push q 3;; 29 | - : unit = () 30 | # Q.pop q;; 31 | - : int option = Some 3 32 | ``` 33 | 34 | ## Closing the queue 35 | 36 | ```ocaml 37 | # let q : int Q.t = Q.create ();; 38 | val q : int Q.t = 39 | # Q.push q 1;; 40 | - : unit = () 41 | # Q.close q;; 42 | - : unit = () 43 | # Q.push q 2;; 44 | Exception: Eio_utils__Lf_queue.Closed. 45 | # Q.push_head q 3;; 46 | - : unit = () 47 | # Q.pop q;; 48 | - : int option = Some 3 49 | # Q.pop q;; 50 | - : int option = Some 1 51 | # Q.pop q;; 52 | Exception: Eio_utils__Lf_queue.Closed. 53 | # Q.push_head q 4;; 54 | Exception: Eio_utils__Lf_queue.Closed. 55 | ``` 56 | 57 | ## Closing an empty queue 58 | 59 | ```ocaml 60 | # let q = Q.create () in Q.close q; Q.push q 1;; 61 | Exception: Eio_utils__Lf_queue.Closed. 62 | ``` 63 | 64 | ## Empty? 65 | 66 | ```ocaml 67 | # let q : int Q.t = Q.create ();; 68 | val q : int Q.t = 69 | # Q.is_empty q;; 70 | - : bool = true 71 | # Q.push q 1; Q.is_empty q;; 72 | - : bool = false 73 | # Q.pop q;; 74 | - : int option = Some 1 75 | # Q.is_empty q;; 76 | - : bool = true 77 | # Q.close q; Q.is_empty q;; 78 | Exception: Eio_utils__Lf_queue.Closed. 79 | ``` 80 | 81 | ## Pushing to the head 82 | 83 | ```ocaml 84 | # let q : int Q.t = Q.create ();; 85 | val q : int Q.t = 86 | # Q.push_head q 3; Q.push q 4; Q.push_head q 2; Q.push q 5; Q.push_head q 1;; 87 | - : unit = () 88 | # Q.pop q;; 89 | - : int option = Some 1 90 | # Q.pop q;; 91 | - : int option = Some 2 92 | # Q.pop q;; 93 | - : int option = Some 3 94 | # Q.pop q;; 95 | - : int option = Some 4 96 | # Q.pop q;; 97 | - : int option = Some 5 98 | # Q.pop q;; 99 | - : int option = None 100 | ``` 101 | -------------------------------------------------------------------------------- /tests/network.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-multicore/eio/8f7f82d2c12076af8e9b8b365c58ebadaa963b8c/tests/network.md -------------------------------------------------------------------------------- /tests/nounix/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name nounix) 3 | (package eio) 4 | (forbidden_libraries unix) 5 | (libraries eio)) 6 | -------------------------------------------------------------------------------- /tests/nounix/nounix.ml: -------------------------------------------------------------------------------- 1 | (* This module checks that Eio doesn't pull in a dependency on Unix. 2 | See the [dune] file. *) 3 | 4 | let () = 5 | assert (Eio.Buf_read.(parse_string_exn take_all) "hi" = "hi") 6 | -------------------------------------------------------------------------------- /tests/random.md: -------------------------------------------------------------------------------- 1 | # Setting up the environment 2 | 3 | ```ocaml 4 | # #require "eio_main";; 5 | ``` 6 | 7 | ```ocaml 8 | open Eio.Std 9 | ``` 10 | 11 | # Basic check for randomness 12 | 13 | ```ocaml 14 | # Eio_main.run @@ fun env -> 15 | let src = Eio.Stdenv.secure_random env in 16 | let b1 = Cstruct.create 8 in 17 | let b2 = Cstruct.create 8 in 18 | Eio.Flow.read_exact src b1; 19 | Eio.Flow.read_exact src b2; 20 | assert (not (Cstruct.equal b1 b2));; 21 | - : unit = () 22 | ``` 23 | -------------------------------------------------------------------------------- /tests/semaphore.md: -------------------------------------------------------------------------------- 1 | # Setting up the environment 2 | 3 | ```ocaml 4 | # #require "eio.mock";; 5 | ``` 6 | 7 | ```ocaml 8 | open Eio.Std 9 | 10 | module T = Eio.Semaphore 11 | 12 | let run fn = 13 | Eio_mock.Backend.run @@ fun _ -> 14 | fn () 15 | 16 | let acquire t = 17 | traceln "Acquiring"; 18 | T.acquire t; 19 | traceln "Acquired" 20 | 21 | let release t = 22 | traceln "Releasing"; 23 | T.release t; 24 | traceln "Released" 25 | ``` 26 | 27 | # Test cases 28 | 29 | Simple case: 30 | 31 | ```ocaml 32 | # run @@ fun () -> 33 | let t = T.make 1 in 34 | acquire t; 35 | release t; 36 | acquire t; 37 | release t;; 38 | +Acquiring 39 | +Acquired 40 | +Releasing 41 | +Released 42 | +Acquiring 43 | +Acquired 44 | +Releasing 45 | +Released 46 | - : unit = () 47 | ``` 48 | 49 | Concurrent access to the semaphore: 50 | 51 | ```ocaml 52 | # run @@ fun () -> 53 | let t = T.make 2 in 54 | let fn () = 55 | acquire t; 56 | Eio.Fiber.yield (); 57 | release t 58 | in 59 | List.init 4 (fun _ -> fn) 60 | |> Fiber.all;; 61 | +Acquiring 62 | +Acquired 63 | +Acquiring 64 | +Acquired 65 | +Acquiring 66 | +Acquiring 67 | +Releasing 68 | +Released 69 | +Releasing 70 | +Released 71 | +Acquired 72 | +Acquired 73 | +Releasing 74 | +Released 75 | +Releasing 76 | +Released 77 | - : unit = () 78 | ``` 79 | 80 | Cancellation: 81 | 82 | ```ocaml 83 | # run @@ fun () -> 84 | let t = T.make 0 in 85 | Fiber.first 86 | (fun () -> acquire t) 87 | (fun () -> ()); 88 | release t; 89 | acquire t;; 90 | +Acquiring 91 | +Releasing 92 | +Released 93 | +Acquiring 94 | +Acquired 95 | - : unit = () 96 | ``` 97 | -------------------------------------------------------------------------------- /tests/signal.md: -------------------------------------------------------------------------------- 1 | # Setting up the environment 2 | 3 | ```ocaml 4 | # #require "eio_main";; 5 | # open Eio.Std;; 6 | ``` 7 | 8 | # Test cases 9 | 10 | Prove we can catch sigint: 11 | ```ocaml 12 | # Eio_main.run @@ fun _stdenv -> 13 | let interrupted = Eio.Condition.create () in 14 | let old = Sys.signal Sys.sigint 15 | (Signal_handle (fun num -> if num = Sys.sigint then Eio.Condition.broadcast interrupted)) 16 | in 17 | Fiber.both 18 | (fun () -> 19 | Eio.Condition.await_no_mutex interrupted; 20 | traceln "interrupted!"; 21 | ) 22 | (fun () -> 23 | let ppid = Unix.getpid () in 24 | match Unix.fork () with 25 | | 0 -> 26 | Unix.kill ppid Sys.sigint; 27 | Unix._exit 0 28 | | child_pid -> 29 | let rec wait () = 30 | match Unix.waitpid [] child_pid with 31 | | pid, status -> 32 | assert (pid = child_pid); 33 | assert (status = (Unix.WEXITED 0)) 34 | | exception Unix.Unix_error (EINTR, _, _) -> wait () 35 | | exception Unix.Unix_error (ECHILD, _, _) -> () (* Hack until we have a cross-platform process API *) 36 | in 37 | wait () 38 | ); 39 | Sys.set_signal Sys.sigint old;; 40 | +interrupted! 41 | - : unit = () 42 | ``` 43 | -------------------------------------------------------------------------------- /tests/trace.md: -------------------------------------------------------------------------------- 1 | ```ocaml 2 | # #require "eio_main";; 3 | # open Eio.Std;; 4 | # Eio_main.run @@ fun _env -> 5 | traceln "One-line trace"; 6 | traceln "@[A nested list@,Foo@,Bar@]"; 7 | traceln "Trace with position" ~__POS__:("trace.md", 5, 1, 10);; 8 | +One-line trace 9 | +A nested list 10 | + Foo 11 | + Bar 12 | +Trace with position [trace.md:5] 13 | - : unit = () 14 | ``` 15 | --------------------------------------------------------------------------------