diff --git a/.dockerignore b/.dockerignore index 76f12ac13..4cde00750 100644 --- a/.dockerignore +++ b/.dockerignore @@ -1,4 +1,4 @@ -Dockerfile -_build -.git -**/*.swp +Dockerfile +_build +.git +**/*.swp diff --git a/.gitattributes b/.gitattributes index 896234998..47e614370 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,3 +1,3 @@ -# To work around MDX issues -README.md text eol=lf -CHANGES.md whitespace=-blank-at-eol +# To work around MDX issues +README.md text eol=lf +CHANGES.md whitespace=-blank-at-eol diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index a920ba0be..3510ae12e 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -1,66 +1,66 @@ -name: Main workflow - -on: - pull_request: - push: - -jobs: - build: - strategy: - fail-fast: false - matrix: - os: - - macos-latest - ocaml-compiler: - - 5.1.x - local-packages: - - eio eio_posix eio_main - - runs-on: ${{ matrix.os }} - - steps: - - name: Checkout code - uses: actions/checkout@v3 - - - name: Use OCaml ${{ matrix.ocaml-compiler }} - uses: ocaml/setup-ocaml@v2 - with: - ocaml-compiler: ${{ matrix.ocaml-compiler }} - opam-local-packages: - opam-disable-sandboxing: true - - - run: opam --cli=2.1 pin -yn --with-version=dev . - - run: opam install ${{ matrix.local-packages }} --deps-only --with-test - - run: opam install ${{ matrix.local-packages }} --with-test - windows: - runs-on: windows-latest - - steps: - - name: Checkout code - uses: actions/checkout@v3 - - - name: Set-up OCaml - uses: ocaml/setup-ocaml@v2 - with: - opam-pin: false - opam-depext: false - ocaml-compiler: ocaml.5.1.0,ocaml-option-mingw - opam-repositories: | - dra27: https://github.com/dra27/opam-repository.git#windows-5.0 - normal: https://github.com/ocaml/opam-repository.git - # --with-version=dev is not available, and --with-test also tries running tests for packages (like MDX) which fail... - - run: | - opam pin -yn eio.dev . - opam pin -yn eio_windows.dev . - opam pin -yn eio_main.dev . - opam install eio eio_windows eio_main --deps-only --with-test - - run: opam exec -- dune build - - run: opam exec -- dune runtest - - run: opam exec -- dune exec -- ./examples/net/main.exe - - run: opam exec -- dune exec -- ./examples/fs/main.exe - docker: - runs-on: ubuntu-latest - steps: - - uses: actions/checkout@v2 - - name: Build the Docker image - run: docker build . +name: Main workflow + +on: + pull_request: + push: + +jobs: + build: + strategy: + fail-fast: false + matrix: + os: + - macos-latest + ocaml-compiler: + - 5.1.x + local-packages: + - eio eio_posix eio_main + + runs-on: ${{ matrix.os }} + + steps: + - name: Checkout code + uses: actions/checkout@v3 + + - name: Use OCaml ${{ matrix.ocaml-compiler }} + uses: ocaml/setup-ocaml@v2 + with: + ocaml-compiler: ${{ matrix.ocaml-compiler }} + opam-local-packages: + opam-disable-sandboxing: true + + - run: opam --cli=2.1 pin -yn --with-version=dev . + - run: opam install ${{ matrix.local-packages }} --deps-only --with-test + - run: opam install ${{ matrix.local-packages }} --with-test + windows: + runs-on: windows-latest + + steps: + - name: Checkout code + uses: actions/checkout@v3 + + - name: Set-up OCaml + uses: ocaml/setup-ocaml@v2 + with: + opam-pin: false + opam-depext: false + ocaml-compiler: ocaml.5.1.0,ocaml-option-mingw + opam-repositories: | + dra27: https://github.com/dra27/opam-repository.git#windows-5.0 + normal: https://github.com/ocaml/opam-repository.git + # --with-version=dev is not available, and --with-test also tries running tests for packages (like MDX) which fail... + - run: | + opam pin -yn eio.dev . + opam pin -yn eio_windows.dev . + opam pin -yn eio_main.dev . + opam install eio eio_windows eio_main --deps-only --with-test + - run: opam exec -- dune build + - run: opam exec -- dune runtest + - run: opam exec -- dune exec -- ./examples/net/main.exe + - run: opam exec -- dune exec -- ./examples/fs/main.exe + docker: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v2 + - name: Build the Docker image + run: docker build . diff --git a/.gitignore b/.gitignore index 5f1f74725..2f17e681d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,5 @@ -_build -_opam -.ocamlformat -.*.swp -*.install +_build +_opam +.ocamlformat +.*.swp +*.install diff --git a/CHANGES.md b/CHANGES.md index 357de52d3..9f12dfc1c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,874 +1,874 @@ -## v1.1 - -New features: - -- Add `Eio.Path.symlink` (@patricoferris #715, reviewed by @talex5). - -- Add `Eio.Pool.use ~never_block` (@SGrondin #657, reviewed by @talex5). - -- Add `Eio_unix.Net.import_socket_listening` (@alyssais #733). - -- Add `Eio.Time.Timeout.sleep` (@talex5 #726). - -Documentation: - -- Add `examples/fs` showing how to walk a directory tree (@talex5 #730). - -- README: explain that `read_all` reads until shutdown (@talex5 #717, reported by @Wenke-D). - -- Use long dash in README title (@lucperkins #718). - -Linux backend: - -- Require Linux >= 5.15 (@talex5 #720, reviewed by @SGrondin and @avsm). - Removes a work-around that required checking whether every flow was a tty. - -- Don't call submit immediately before wait (@talex5 #728). - This is slightly faster and makes the traces clearer. - -- Don't record submit events when there's nothing to submit (@talex5 #729). - Makes the traces a bit clearer. - -- Split flow into its own file (@talex5 #727). - -- Add work-around for signals race (@talex5 #734). - -POSIX backend: - -- Add `_BSD_SOURCE` flag to fix build on OpenBSD (@prgbln #722). - -- Fix sandboxed path resolution on OpenBSD (@jebrosen #723, reviewed by @talex5). - OpenBSD uses `ELOOP` when opening a symlink with `O_NOFOLLOW`. - -Build and test: - -- Benchmarks: record uname, Eio backend, and number of cores (@talex5 #719). - -- Update to MDX 2.4.1 for OCaml 5.2 (@talex5 #712). - -## v1.0 - -New features: - -- Add `Eio_unix.Cap` module to enable Capsicum mode (@talex5 #697, reviewed by @SGrondin). - -- eio_linux: expose more functions in the `Low_level` module (@talex5 #705, reviewed by @SGrondin). - Add all the functions used by other parts of eio_linux (`openat`, `mkdir`, `read_link`, `unlink`, `rename` and `pipe`). - Tidied the API up a bit too: - - `mkdir_beneath` is now just `mkdir`. - - `statx_confined` is now just `statx`. - - `open_dir` is gone; the single user now calls `openat` directly. - -Documentation: - -- Add README documentation for `Eio.Executor_pool` (@SGrondin @talex5 #707, reviewed by @Sudha247). - -- eio_linux: remove logging (@talex5 #708, requested by @clecat). - There were only two remaining uses of Logs, neither of which has proved useful. - -Build: - -- Add upper-bound on MDX (@talex5 #706). - The new version attempts to execute included blocks. - -- Fix tests to pass with both old and new Kcas (@polytypic #704). - -- Make posix `open_beneath` test idempotent (@SGrondin #703). - -- Executor_pool: mention requested weight in error message (@talex5 #702, reported by @yawaramin). - -## v0.15 - -New features: - -- eio_posix: use directory FDs instead of realpath (@talex5 #694 #696, reviewed by @SGrondin). - Using realpath was an old hack from the libuv days and subject to races. It was also slow. - -- Keep pool of systhreads for blocking operations (@SGrondin @talex5 #681). - This is much faster than creating a new thread for each operation. - It mainly benefits the eio_posix backend, as that uses lots of systhreads. - -- Make `Switch.on_release` thread-safe (@talex5 #684, requested by @art-w and @clecat). - This allows resource pools to be shared between domains easily. - -- Add `Eio.Path.read_link` (@talex5 #686). - -- Add `Eio_unix.Fd.is_open` (@talex5 #690). - -- Include backtrace in systhread errors (@talex5 #688, reviewed by @SGrondin). - Also, add `Eio.Exn.empty_backtrace` as a convenience. - -- eio.mock: add tracing support to mock backend (@talex5 #687). - -- Improve tracing (@talex5 #675 #683 #676, reviewed by @SGrondin). - Update tracing section of README and trace more things - (`run_in_systhread`, `close`, `submit`, `traceln`, cancellation and domain spawning). - -Documentation: - -- Link to verification work in docs (@talex5 #682). - -- Add more trace diagrams to README (@talex5 #698). - -- Adjust COC contacts (@polytypic #685, reviewed by @Sudha247). - -Bug fixes: - -- eio_linux: retry `openat2` on `EAGAIN` (@talex5 #693, reviewed by @SGrondin). - -- eio_posix and eio_windows: check for IO periodically (@talex5 #674). - -- Handle EPERM when trying to initialise uring (@talex5 #691). - This can happen when using a Docker container. - -Build and tests: - -- Benchmark `Eio_unix.run_in_systhread` (@talex5 #678, reviewed by @SGrondin). - -- Enable lintcstubs for `Eio_unix.Private` too (@talex5 #689). - -- Stat benchmark: report cleanup time and optimise (@talex5 #692). - -- Make benchmarks start faster (@talex5 #673). - -- Update build for new eio-trace CLI (@talex5 #699). - -- Expect opam-repo-ci tests to fail on macos (@talex5 #672). - -## v0.14 - -New features / API changes: - -- Add `Eio.Executor_pool` (@SGrondin #639, reviewed by @talex5). - Provides an easy way to distribute jobs across domains. - -- Add `Fiber.first ~combine` and `Fiber.n_any` (@SGrondin @talex5 #587). - Allows keeping both results in the case where multiple fibers succeed. - -- Add `Eio_mock.Backend.run_full` with auto-advancing mock clock (@talex5 #644, reviewed by @SGrondin). - Simplifies testing of code using clocks. - -- Add `Buf_write.printf` (@SGrondin @talex5 #655). - -- Add `Net.listening_addr` (@mefyl #555, reviewed by @patricoferris @talex5). - Useful to get the socket's address if the OS assigns it. - -- Add `Promise.try_resolve` (@talex5 #646). - -- Remove `Cancel_hook_failed` exception (@talex5 #640). - Didn't seem to be used and broke dscheck. - -Tracing: - -- Improve tracing (@TheLortex @patricoferris @talex5 #656). - Trace cancellation contexts and OS operations, and simplify API. - -- Add labels to switches (@talex5 #661, reviewed by @SGrondin). - -- `Fiber.all`: use the parent fiber (@talex5 #665, reviewed by @SGrondin). - Cleans up the traces a bit. - -Performance: - -- Faster and simpler `Lf_queue` (@talex5 #647, based on work by @polytypic). - -- Optimise `Flow.copy` with `Buf_read.as_flow` (@talex5 #663, reviewed by @SGrondin, reported by @leostera). - -Bug fixes: - -- Fix handling of very long IO vectors (@talex5 #653, reported by @Cjen1). - -- eio_posix: use `caml_enter_blocking_section` in more places (@talex5 #654, reviewed by @SGrondin). - -- eio_posix: work around `caml_unix_alloc_sockaddr` bug (@talex5 #651). - -- Remove default backtrace from `Switch.fail` (@talex5 #664). - -Documentation: - -- Organise eio.mli better (@talex5 #667). - -- Fix quoting of quotes in process error messages (@talex5 #666, reviewed by @SGrondin). - -- Mention Path module in File and Fs documentation (@talex5 #659, requested by @clecat). - -- Minor documentation updates (@SGrondin @talex5 #670). - -Build / internals: - -- Allow closing synchronous streams (@talex5 #641, reviewed by @SGrondin). - This isn't currently exposed in the public interface. - -- Fix non-idempotent tests (@SGrondin #662). - -- eio_windows: add explicit fmt dependency (@talex5 #643). - -## v0.13 - -New features / API changes: - -- Add `Flow.read_all` (@SGrondin #596, reviewed by @talex5 @rbjorklin). - -- Add `Path.stat` (@patricoferris @talex5 @avsm #617 #618 #624 #620, reviewed by @SGrondin). - -- Add `Path.rmtree` (@talex5 #627 #628, reviewed by @SGrondin). - -- Add `Path.mkdirs` and `Path.split` (@patricoferris @talex5 #625). - -- Add `Eio.File.{seek,sync,truncate}` (@talex5 #626). - -- Add `Eio.Path.{kind,is_file,is_directory}` (@patricoferris @talex5 #623, reviewed by @avsm). - -- Switch from CTF to OCaml 5.1 runtime events (@TheLortex @patricoferris @talex5 #634 #635, reviewed by @avsm). - This is a minimal initial version. - -Documentation: - -- Document `File.Stat` record fields (@avsm @talex5 #621). - -- Update README section about `env` (@talex5 #614, reported by @jonsterling). - -Build and test changes: - -- Add `File.stat` benchmark (@talex5 #616). - -- Add `Path.stat` benchmark (@patricoferris @talex5 #630). - -- eio_linux: mark as only available on Linux (@talex5 #629). - -- Make MDX tests idempotent (@SGrondin #601, reviewed by @talex5). - -- Allow trailing whitespace in CHANGES.md (@talex5 #632). - -- Update minimum OCaml version to 5.1 (@talex5 #631). - -- Generate prototypes for C stubs from ml files (@talex5 #615). - -- Don't try to compile uring support on centos 7 (@talex5 #638, reported by @zenfey). - -## v0.12 - -New features / API changes: - -- Replace objects with variants (@talex5 @patricoferris #553 #605 #608, reviewed by @avsm). - Some potential users found object types confusing, so we now use an alternative scheme for OS resources. - For users of the resources, the only thing that changes is the types: - - - Instead of taking an argument of type `#foo`, you should now take `_ foo`. - - Instead of returning a value of type `foo`, you should now return `foo_ty Eio.Resource.t`. - - To provide your own implementation of an interface, you now provide a module rather than an object. - For example, to provide your own source flow, use `Eio.Flow.Pi.source (module My_source)`. - - If you want to define your own interfaces, see the `Eio.Resource` module documentation. - -- Add `Eio.Pool` (@talex5 @darrenldl #602, reviewed by @patricoferris). - A lock-free pool of resources. This is similar to `Lwt_pool`. - -- Add `Eio.Lazy` (@talex5 #609, reviewed by @SGrondin). - If one fiber tries to force a lazy value while another is already doing it, - this will wait for the first one to finish rather than raising an exception (as `Stdlib.Lazy` does). - -- Add `Eio.Path.native` (@talex5 #603, reviewed by @patricoferris). - This is useful when interacting with non-Eio libraries, for spawning sub-processes, and for displaying paths to users. - -- Add `Flow.single_write` (@talex5 #598). - -- Add `Eio.Flow.Pi.simple_copy` (@talex5 #611). - Provides an easy way to implement the `copy` operation when making your own sink. - -- Eio_unix: add FD passing (@talex5 #522). - Allows opening a file and passing the handle over a Unix-domain socket. - -- Add `Process.run ?is_success` to control definition of success (@SGrondin #586, reviewed by @talex5). - -- Add `Eio_mock.Domain_manager` (@talex5 #610). - This mock domain manager runs everything in a single domain, allowing tests to remain deterministic. - -- Add `Eio.Debug.with_trace_prefix` (@talex5 #610). - Allows prefixing all `traceln` output. The mock domain manager uses this to indicate which fake domain is running. - -Bug fixes: - -- Fork actions must not allocate (@talex5 #593). - When using multiple domains, child processes could get stuck if they forked while another domain held the malloc lock. - -- eio_posix: ignore some errors writing to the wake-up pipe (@talex5 #600). - If the pipe is full or closed, the wake-up should simply be ignored. - -Build/test fixes: - -- Fix some MDX problems on Windows (@polytypic #597). - -- The README depends on kcas (@talex5 #606). - -- Clarify configuration for lib_eio_linux and enable tests on other arches (@dra27 #592). - -- eio_linux tests: skip fixed buffer test if not available (@talex5 #604). - -- eio_windows: update available line to win32 (@talex5 #588 #591). - - -## v0.11 - -New features / API changes: - -- Extend `Eio.Condition` API (@talex5 #563). - - `loop_no_mutex` is a simpler and more efficient way to way for a condition. - - `register_immediate` allows integration with other IO libraries. - -- Expose `Eio.Stdenv.backend_id` (@bord-o #560, reviewed by @talex5). - Useful in tests to report which backend is being used. - -- Remove deprecated features (@talex5 #552, reviewed by @avsm). - These were all already marked as deprecated in v0.10 and are now gone completely: - - `Fiber.fork_sub` - - `Eio_unix.{FD,Ipaddr,socketpair,getnameinfo}` - - `Eio_linux.{FD,get_fd,get_fd_opt}` - - `Eio_posix.Low_level.Fd` - -- Allow calling `close` more than once (@talex5 #547, requested by @anmonteiro, reviewed by @patricoferris, @avsm). - -- Add `close` to socket type (@talex5 #549). - Simplifies the type signatures a bit by avoiding having to mention this everywhere. - -Bug fixes: - -- Fix handling of empty path strings (@talex5 #569, reported by @SGrondin). - Using "" instead of "." in some places resulted in an error. - -- eio_posix: fix update to watched FDs on cancel (@talex5 #574, reported and reviewed by @quernd). - Cancelling the last watcher of an FD didn't remove it from the set passed to `poll`, - which could result in constant wake-ups. - -- eio_posix: fix `pread` at end-of-file (@talex5 #581, reported by @SGrondin). - It tried to return 0 instead of `End_of_file`, triggering an assertion. - -- eio_posix: don't reap non-Eio child processes (@talex5 #562). - This allows spawning processes with e.g. the stdlib or Lwt - (but see https://github.com/ocaml-multicore/lwt_eio/pull/19 for Lwt support). - -- Preserve backtraces across `Domain_manager.run` (@talex5 #571). - See https://github.com/ocaml/ocaml/issues/12362. - -- Correct the backend selection for Cygwin (@dra27 #557). - Use `eio_posix`, not `eio_windows` in this case. - -Other changes: - -- Simplify dune files with dune 3.9's `build_if` (@talex5 #582). - -- Remove `Waiters` from `Eio_core` (@talex5 #567). - `Eio.Switch` no longer uses this so it can finally be removed. - -- Use `Fmt.Dump.signal` to format signals (@talex5, @MisterDA #543). - -Documentation: - -- Add some notes about thread-safety in the documentation (@talex5 #568). - -## v0.10 - -New features / API changes: - -- Add `Eio.Process` for cross-platform subprocess support (@patricoferris @talex5 #499, reviewed by @anmonteiro @avsm @haesbaert). - -- Add `Eio_unix.Net module` (@talex5 #516, reviewed by @avsm). - The Unix network APIs have been cleaned up and moved here, and some missing datagram operations have been added. - `send` now takes an iovec, not just a single buffer. - -- Add support for domain local await (@polytypic @talex5 #494 #503). - Allows sharing e.g. kcas data-structures across Eio and Domainslib domains. - -- Add initial eio_windows backend (@patricoferris @talex5 #497 #530 #511 #523 #509, reviewed by @avsm @polytypic). - -- Remove eio_luv backend (@talex5 #485). - It was only used on Windows, and has been replaced by eio_windows. - -- Unify `Eio_linux.FD` and `Eio_posix.Fd` as `Eio_unix.Fd` (@talex5 #491). - Now that eio_luv is gone, there is no need for different backends to have different types for wrapped file descriptors. - -- Move `Eio.Stdenv.t` to `Eio_unix.Stdenv.base` (@talex5 #498). - Note that the rest of `Eio.Stdenv` is still there; only the definition of a full Unix-like environment has moved. - -- Deprecation cleanups (@talex5 #508). - Removed some APIs that were already marked as deprecated in Eio 0.8. - -Bug fixes: - -- eio_linux: fall back to `fork` if `clone3` is unavailable (@talex5 #524, reported by @smondet, reviewed by @avsm). - Docker's default security policy blocks `clone3`. - -- Don't call `accept_fork`'s error handler on cancellation (@talex5 #520). - This isn't an error and should not be reported. - -- Fix `eio_unix_is_blocking` C stub (@patricoferris #505, reviewed by @talex5). - -- Fix `Condition.await bug` when cancelling (@polytypic @talex5 #487). - -- Buf_write: fix flush returning too early (@talex5 #539, reported by @cometkim). - -- Ignore `ENOTCONN` errors on socket shutdown (@avsm #533, reported by @patricoferris, reviewed by @talex5). - -Documentation: - -- Link to developer meetings information (@talex5 @Sudha247 #515). - -- Adopt OCaml Code of Conduct (@Sudha247 #501). - -- Add README links to Meio and Lambda Capabilities blog post (@talex5 #496). - -- Document mirage `Ipaddr` conversion (@RyanGibb @patricoferris @talex5 #492). - -- Document how to use Domainslib from Eio (@talex5 #489, reviewed by @polytypic @patricoferris). - -Other changes: - -- Run benchmarks with current-bench (@Sudha247 @talex5 #500). - -- Fix MDX tests on OCaml 5.1 (@talex5 #526). - -- Add stress test for spawning processes (@talex5 #519). - This was an attempt to track down the https://github.com/ocaml/ocaml/issues/12253 signals bug. - -- `Eio.Process.pp_status` should be polymorphic (@talex5 #518). - -- eio_posix: probe for existence of some flags (@talex5 #507, reported by @hannesm). - FreeBSD 12 didn't have `O_DSYNC`. Also, add `O_RESOLVE_BENEATH` and `O_PATH` if available. - -- Fix race in ctf tests (@talex5 #493). - -## v0.9 - -New features: - -- Add eio_posix backend (@talex5 @haesbaert #448 #477, reviewed by @avsm @patricoferris @polytypic). - This replaces eio_luv on all platforms except Windows (which will later switch to its own backend). It is a lot faster, provides access to more modern features (such as `openat`), and can safely share OS resources between domains. - -- Add subprocess support (@patricoferris @talex5 #461 #464 #472, reviewed by @haesbaert @avsm). - This is the low-level API support for eio_linux and eio_posix. A high-level cross-platform API will be added in the next release. - -- Add `Fiber.fork_seq` (@talex5 #460, reviewed by @avsm). - This is a light-weight alternative to using a single-producer, single-consumer, 0-capacity stream, similar to a Python generator function. - -Bug fixes: - -- eio_linux: make it safe to share FDs across domains (@talex5 #440, reviewed by @haesbaert). - It was previously not safe to share file descriptors between domains because if one domain used an FD just as another was closing it, and the FD got reused, then the original operation could act on the wrong file. - -- eio_linux: release uring if Linux is too old (@talex5 #476). - Avoids a small resource leak. - -- eio_linux: improve error handling creating pipes and sockets (@talex5 #474, spotted by @avsm). - If we get an error (e.g. too many FDs) then report it to the calling fiber, instead of exiting the event loop. - -- eio_linux: wait for uring to finish before exiting (@talex5 #470, reviewed by @avsm). - If the main fiber raised an exception then it was possible to exit while a cancellation operation was still in progress. - -- eio_main: make `EIO_BACKEND` handling more uniform (@talex5 #447). - Previously this environment variable was only used on Linux. Now all platforms check it. - -- Tell dune about `EIO_BACKEND` (@talex5 #442). - If this changes, dune needs to re-run the tests. - -- eio_linux: add some missing close-on-execs (@talex5 #441). - -- eio_linux: `read_exactly` fails to update file offset (@talex5 #438). - -- Work around dune `enabled_if` bug on non-Linux systems (@polytypic #475, reviewed by @talex5). - -- Use raw system call of `getrandom` for glibc versions before 2.25 (@zenfey #482). - -Documentation: - -- Add `HACKING.md` with hints for working on Eio (@talex5 #443, reviewed by @avsm @polytypic). - -- Improve worker pool example (@talex5 #454). - -- Add more Conditions documentation (@talex5 #436, reviewed by @haesbaert). - This adds a discussion of conditions to the README and provides examples using them to handle signals. - -- Condition: fix the example in the docstring (@avsm #468). - -Performance: - -- Add a network benchmark using an HTTP-like protocol (@talex5 #478, reviewed by @avsm @patricoferris). - -- Add a benchmark for reading from `/dev/zero` (@talex5 #439). - -Other changes: - -- Add CI for macOS (@talex5 #452). - -- Add tests for `pread`, `pwrite` and `readdir` (@talex5 #451). - -- eio_linux: split into multiple files (@talex5 #465 #466, reviewed by @avsm). - -- Update Dockerfile (@talex5 #471). - -- Use dune.3.7.0 (@patricoferris #457). - -- Mint exclusive IDs across domains (@TheLortex #480, reported by @haesbaert, reviewed by @talex5). - The tracing currently only works with a single domain anyway, but this will change when OCaml 5.1 is released. - - -## v0.8.1 - -Some build fixes: - -- Fix build on various architectures (@talex5 #432). - - Work around dune `%{system}` bug. - - eio_luv: fix `max_luv_buffer_size` on 32-bit platforms. - -- Add missing test-dependency on MDX (@talex5 #430). - -## v0.8 - -New features: - -- Add `Eio.Net.run_server` (@bikallem @talex5 #408). - Runs an accept loop in one or more domains, with cancellation and graceful shutdown, - and an optional maximum number of concurrent connections. - -- Add `Buf_read.BE` and `LE` parsers (@Cjen1 #399). - Parse numbers in various binary formats. - -- Add `Eio.Buf_read.uint8` (@talex5 #418). - -Performance: - -- Make `Eio.Condition` lock-free (@talex5 #397 #381). - In addition to being faster, this allows using conditions in signal handlers. - -- Make `Eio.Semaphore` lock-free (@talex5 @polytypic #398). - -- Make `Eio.Stream` lock-free when the capacity is zero (@talex5 #413 #411). - -- Make `Eio.Promise` lock-free (@talex5 #401). - -Bug fixes: - -- eio_linux: call `Uring.submit` as needed (@talex5 @bikallem #428). - Previously, we could fail to submit a job promptly because the SQE queue was full. - -- Fix luv signals (@haesbaert #412). - `libuv` automatically retries polling if it gets `EINTR`, without giving OCaml signal handlers a chance to run. - -- eio_luv: fix some resource leaks (@talex5 @patricoferris #421). - -- eio_luv: fix "unavailable signal" error on Windows (@talex5 #420, reported by @nojb). - -- Fix `Buf_write.BE.uint48` and `LE.uint48` (@adatario #418). - -Documentation: - -- Add example programs (@talex5 #389). - -- Update network examples to use `run_server` (@talex5 #417). - -- Add a warning to the tutorial about `Fiber.first` (@talex5 #394). - -- Clarify the epoch used for `Eio.Time.now` (@bikallem #395). - -- Describe `secure_random` as an infinite source (@patricoferris #426). - -- Update README for OCaml 5 release (@talex5 #384 #391 #393). - -Other changes: - -- Delay setting `SIGPIPE` handler until the `run` function is called (@talex5 #420). - -- Remove debug-level logging (@talex5 #403). - -- eio-luv: improve `process.md` test (@smondet #414). - -- Update to Dune 3 (@talex5 #410). - -- Remove test dependency on Astring (@talex5 #402 #404). - -- Simplify cancellation logic (@talex5 #396). - -- time: `Mtime.Spand.to_s` has been deprecated in mtime 2.0.0 (@bikallem #385). - -## v0.7 - -API changes: - -- Unify IO errors as `Eio.Io` (@talex5 #378). - This makes it easy to catch and log all IO errors if desired. - The exception payload gives the type and can be used for matching specific errors. - It also allows attaching extra information to exceptions, and various functions were updated to do this. - -- Add `Time.Mono` for monotonic clocks (@bikallem @talex5 #338). - Using the system clock for timeouts, etc can fail if the system time is changed during the wait. - -- Allow datagram sockets to be created without a source address (@bikallem @haesbaert #360). - The kernel will allocate an address in this case. - You can also now control the `reuse_addr` and `reuse_port` options. - -- Add `File.stat` and improve `Path.load` (@haesbaert @talex5 #339). - `Path.load` now uses the file size as the initial buffer size. - -- Add `Eio_unix.pipe` (@patricoferris #350). - This replaces `Eio_linux.pipe`. - -- Avoid short reads from `getrandom(2)` (@haesbaert #344). - Guards against buggy user code that might not handle this correctly. - -- Rename `Flow.read` to `Flow.single_read` (@talex5 #353). - This is a low-level function and it is easy to use it incorrectly by ignoring the possibility of short reads. - -Bug fixes: - -- Eio_luv: Fix non-tail-recursive continue (@talex5 #378). - Affects the `Socket_of_fd` and `Socketpair` effects. - -- Eio_linux: UDP sockets were not created close-on-exec (@talex5 #360). - -- Eio_linux: work around io_uring non-blocking bug (@haesbaert #327 #355). - The proper fix should be in Linux 6.1. - -- `Eio_mock.Backend`: preserve backtraces from `main` (@talex5 #349). - -- Don't lose backtrace in `Switch.run_internal` (@talex5 #369). - -Documentation: - -- Use a proper HTTP response in the README example (@talex5 #377). - -- Document that read_dir excludes "." and ".." (@talex5 #379). - -- Warn about both operations succeeding in `Fiber.first` (@talex5 #358, reported by @iitalics). - -- Update README for OCaml 5.0.0~beta2 (@talex5 #375). - -Backend-specific changes: - -- Eio_luv: add low-level process support (@patricoferris #359). - A future release will add Eio_linux support and a cross-platform API for this. - -- Expose `Eio_luv.Low_level.Stream.write` (@patricoferris #359). - -- Expose `Eio_luv.Low_level.get_loop` (@talex5 #371). - This is needed if you want to create resources directly and then use them with Eio_luv. - -- `Eio_linux.Low_level.openfile` is gone (@talex5 #378). - It was just left-over test code. - - -## v0.6 - -Changes: - -- Update to OCaml 5.0.0~beta1 (@anmonteiro @talex5 #346). - -- Add API for seekable read/writes (@nojb #307). - -- Add `Flow.write` (@haesbaert #318). - This provides an optimised alternative to `copy` in the case where you are writing from a buffer. - -- Add `Net.with_tcp_connect` (@bikallem #302). - Convenience function for opening a TCP connection. - -- Add `Eio.Time.Timeout` (@talex5 #320). - Makes it easier to pass timeouts around. - -- Add `Eio_mock.Clock` (@talex5 #328). - Control time in tests. - -- Add `Buf_read.take_while1` and `skip_while1` (@bikallem #309). - These fail if no characters match. - -- Make the type parameter for `Promise.t` covariant (@anmonteiro #300). - -- Move list functions into a dedicated submodule (@raphael-proust #315). - -- Direct implementation of `Flow.source_string` (@c-cube #317). - Slightly faster. - -Bug fixes: - -- `Condition.broadcast` must interlock as well (@haesbaert #324). - -- Split the reads into no more than 2^32-1 for luv (@haesbaert @talex5 @EduardoRFS #343). - Luv uses a 32 bit int for buffer sizes and wraps if the value passed is too big. - -- eio_luv: allow `Net.connect` to be cancelled (@talex5 @nojb #311). - -- eio_main: Use dedicated log source (@anmonteiro #326). - -- linux_eio: fix kernel version number in log message (@talex5 @nojb #314). - -- Account for stack differences in the socketpair test (issue #312) (@haesbaert #313). - -Documentation: - -- Add Best Practices section to README (@talex5 #299). - -- Documentation improvements (@talex5 #295 #337). - - -## v0.5 - -New features: - -- Add `Eio.Condition` (@TheLortex @talex5 #277). - Allows a fiber to wait for some condition to become true. - -- Add `Eio.Net.getaddrinfo` and `getnameinfo` (@bikallem @talex5 #278 #288 #291). - Convert between host names and addresses. - -- Add `Eio.Debug` (@talex5 #276). - Currently, this allows overriding the `traceln` function. - -- `Buf_write.create`: make switch optional (@talex5 #283). - This makes things easier for people porting code from Faraday. - -Bug fixes: - -- Allow sharing of libuv poll handles (@patricoferris @talex5 #279). - Luv doesn't allow two callers to watch the same file handle, so we need to handle that in Eio. - -Other changes: - -- Upgrade to uring 0.4 (@talex5 #290). - -- Mention `Mutex`, `Semaphore` and `Condition` in the README (@talex5 #281). - -## v0.4 - -Note: Eio 0.4 drops compatibility with OCaml 4.12+domains. Use OCaml 5.0.0~alpha1 instead. - -API changes: - -- `Eio.Dir` has gone. Use `Eio.Path` instead (@talex5 #266 #270). - -- `Eio_unix.FD.{take,peek}` were renamed to `take_opt`/`peek_opt` to make way for non-optional versions. - -New features: - -- Fiber-local storage (@SquidDev #256). - Attach key/value bindings to fibers. These are inherited across forks. - -- `Eio.Path.{unlink,rmdir,rename}` (@talex5 #264 #265). - -- `Eio_main.run` can now return a value (@talex5 #263). - This is useful for e.g. cmdliner. - -- `Eio_unix.socketpair` (@talex5 #260). - -- `Fiber.fork_daemon` (@talex5 #252). - Create a helper fiber that does not prevent the switch from exiting. - -- Add `Fiber.{iter,map,filter,fiter_map}` (@talex5 #248 #250). - These are concurrent versions of the corresponding operations in `List`. - -Bug fixes: - -- Fix scheduling fairness in luv backend (@talex5 #269). - -- Implement remaining shutdown commands for luv (@talex5 #268). - -- Fix IPv6 support with uring backend (@haesbaert #261 #262). - -- Use `Eio.Net.Connection_reset` exception in more places (@talex5 #257). - -- Report use of closed FDs better (@talex5 #255). - Using a closed FD could previously cause the whole event loop to exit. - -- Some fixes for cancellation (@talex5 #254). - -- Ensure `Buf_write` still flushes if an exception is raised (@talex5 #246). - -- Do not allow close on `accept_fork` socket (@talex5 #245). - -Documentation: - -- Document integrations with Unix, Lwt and Async (@talex5 #247). - -- Add a Dockerfile for easy testing (@talex5 #224). - -## v0.3 - -API changes: - -- `Net.accept_sub` is deprecated in favour of `accept_fork` (@talex5 #240). - `Fiber.fork_on_accept`, which it used internally, has been removed. - -- Allow short writes in `Read_source_buffer` (@talex5 #239). - The reader is no longer required to consume all the data in one go. - Also, add `Linux_eio.Low_level.writev_single` to expose this behaviour directly. - -- `Eio.Unix_perm` is now `Eio.Dir.Unix_perm`. - -New features: - -- Add `Eio.Mutex` (@TheLortex @talex5 #223). - -- Add `Eio.Buf_write` (@talex5 #235). - This is a buffered writer for Eio sinks, based on Faraday. - -- Add `Eio_mock` library for testing (@talex5 #228). - At the moment it has mock flows and networks. - -- Add `Eio_mock.Backend` (@talex5 #237 #238). - Allows running tests without needing a dependency on eio_main. - Also, as it is single-threaded, it can detect deadlocks in test code instead of just hanging. - -- Add `Buf_read.{of_buffer, of_string, parse_string{,_exn}, return}` (@talex5 #225). - -- Add `<*>` combinator to `Buf_read.Syntax` (@talex5 #227). - -- Add `Eio.Dir.read_dir` (@patricoferris @talex5 #207 #218 #219) - -Performance: - -- Add `Buf_read` benchmark and optimise it a bit (@talex5 #230). - -- Inline `Buf_read.consume` to improve performance (@talex5 #232). - -Bug fixes / minor changes: - -- Allow IO to happen even if a fiber keeps yielding (@TheLortex @talex5 #213). - -- Fallback for `traceln` without an effect handler (@talex5 #226). - `traceln` now works outside of an event loop too. - -- Check for cancellation when creating a non-protected child context (@talex5 #222). - -- eio_linux: handle EINTR when calling `getrandom` (@bikallem #212). - -- Update to cmdliner.1.1.0 (@talex5 #190). - -## v0.2 - -- Add support for UDP (@patricoferris #171). - -- Rename Fibre to Fiber (@talex5 #195). This is to match the compiler's spelling. - -- Switch to luv backend if uring can't be used (@talex5 #203). - Useful on Windows with WSL, and also in Docker containers on older systems. - -- Eio_linux: cope with lack of fixed chunks (@talex5 #200). - - If we run out of fixed memory, just use regular memory instead of waiting (which might deadlock). - - If we try to allocate a fixed buffer and fail, we now just log a warning and continue without one. - -- Add support for FD passing with Eio_linux (@talex5 #199). - -- Add `Eio_unix.FD.as_socket` (@talex5 #193). - Useful for working with existing libraries that provide a `Unix.file_descr`, or for receiving FDs from elsewhere (e.g. socket activation). - Also, the `Luv.{File,Handle}.of_luv` functions now allow controlling whether to close the wrapped FD. - -- Add `Eio_unix.sleep` (@talex5 #188). Based on feedback that some people don't want to treat time as a capability. Possibly also useful for debugging race conditions. - -- Tidy up forking API (@talex5 #192). Moves some common code out the the individual backends. - -- Improve documentation (@talex5 #197 #194 #186 #185). In particular, explain more low-level details about how cancellation works. - -- Add an example `Eio_null` backend (@talex5 #189). This supports creating fibers, promises and cancellation, but provides no IO operations. - -- `Effect.eff` is now `Effect.t` in OCaml trunk (@talex5 #201). - -## v0.1 - -- Initial release. +## v1.1 + +New features: + +- Add `Eio.Path.symlink` (@patricoferris #715, reviewed by @talex5). + +- Add `Eio.Pool.use ~never_block` (@SGrondin #657, reviewed by @talex5). + +- Add `Eio_unix.Net.import_socket_listening` (@alyssais #733). + +- Add `Eio.Time.Timeout.sleep` (@talex5 #726). + +Documentation: + +- Add `examples/fs` showing how to walk a directory tree (@talex5 #730). + +- README: explain that `read_all` reads until shutdown (@talex5 #717, reported by @Wenke-D). + +- Use long dash in README title (@lucperkins #718). + +Linux backend: + +- Require Linux >= 5.15 (@talex5 #720, reviewed by @SGrondin and @avsm). + Removes a work-around that required checking whether every flow was a tty. + +- Don't call submit immediately before wait (@talex5 #728). + This is slightly faster and makes the traces clearer. + +- Don't record submit events when there's nothing to submit (@talex5 #729). + Makes the traces a bit clearer. + +- Split flow into its own file (@talex5 #727). + +- Add work-around for signals race (@talex5 #734). + +POSIX backend: + +- Add `_BSD_SOURCE` flag to fix build on OpenBSD (@prgbln #722). + +- Fix sandboxed path resolution on OpenBSD (@jebrosen #723, reviewed by @talex5). + OpenBSD uses `ELOOP` when opening a symlink with `O_NOFOLLOW`. + +Build and test: + +- Benchmarks: record uname, Eio backend, and number of cores (@talex5 #719). + +- Update to MDX 2.4.1 for OCaml 5.2 (@talex5 #712). + +## v1.0 + +New features: + +- Add `Eio_unix.Cap` module to enable Capsicum mode (@talex5 #697, reviewed by @SGrondin). + +- eio_linux: expose more functions in the `Low_level` module (@talex5 #705, reviewed by @SGrondin). + Add all the functions used by other parts of eio_linux (`openat`, `mkdir`, `read_link`, `unlink`, `rename` and `pipe`). + Tidied the API up a bit too: + - `mkdir_beneath` is now just `mkdir`. + - `statx_confined` is now just `statx`. + - `open_dir` is gone; the single user now calls `openat` directly. + +Documentation: + +- Add README documentation for `Eio.Executor_pool` (@SGrondin @talex5 #707, reviewed by @Sudha247). + +- eio_linux: remove logging (@talex5 #708, requested by @clecat). + There were only two remaining uses of Logs, neither of which has proved useful. + +Build: + +- Add upper-bound on MDX (@talex5 #706). + The new version attempts to execute included blocks. + +- Fix tests to pass with both old and new Kcas (@polytypic #704). + +- Make posix `open_beneath` test idempotent (@SGrondin #703). + +- Executor_pool: mention requested weight in error message (@talex5 #702, reported by @yawaramin). + +## v0.15 + +New features: + +- eio_posix: use directory FDs instead of realpath (@talex5 #694 #696, reviewed by @SGrondin). + Using realpath was an old hack from the libuv days and subject to races. It was also slow. + +- Keep pool of systhreads for blocking operations (@SGrondin @talex5 #681). + This is much faster than creating a new thread for each operation. + It mainly benefits the eio_posix backend, as that uses lots of systhreads. + +- Make `Switch.on_release` thread-safe (@talex5 #684, requested by @art-w and @clecat). + This allows resource pools to be shared between domains easily. + +- Add `Eio.Path.read_link` (@talex5 #686). + +- Add `Eio_unix.Fd.is_open` (@talex5 #690). + +- Include backtrace in systhread errors (@talex5 #688, reviewed by @SGrondin). + Also, add `Eio.Exn.empty_backtrace` as a convenience. + +- eio.mock: add tracing support to mock backend (@talex5 #687). + +- Improve tracing (@talex5 #675 #683 #676, reviewed by @SGrondin). + Update tracing section of README and trace more things + (`run_in_systhread`, `close`, `submit`, `traceln`, cancellation and domain spawning). + +Documentation: + +- Link to verification work in docs (@talex5 #682). + +- Add more trace diagrams to README (@talex5 #698). + +- Adjust COC contacts (@polytypic #685, reviewed by @Sudha247). + +Bug fixes: + +- eio_linux: retry `openat2` on `EAGAIN` (@talex5 #693, reviewed by @SGrondin). + +- eio_posix and eio_windows: check for IO periodically (@talex5 #674). + +- Handle EPERM when trying to initialise uring (@talex5 #691). + This can happen when using a Docker container. + +Build and tests: + +- Benchmark `Eio_unix.run_in_systhread` (@talex5 #678, reviewed by @SGrondin). + +- Enable lintcstubs for `Eio_unix.Private` too (@talex5 #689). + +- Stat benchmark: report cleanup time and optimise (@talex5 #692). + +- Make benchmarks start faster (@talex5 #673). + +- Update build for new eio-trace CLI (@talex5 #699). + +- Expect opam-repo-ci tests to fail on macos (@talex5 #672). + +## v0.14 + +New features / API changes: + +- Add `Eio.Executor_pool` (@SGrondin #639, reviewed by @talex5). + Provides an easy way to distribute jobs across domains. + +- Add `Fiber.first ~combine` and `Fiber.n_any` (@SGrondin @talex5 #587). + Allows keeping both results in the case where multiple fibers succeed. + +- Add `Eio_mock.Backend.run_full` with auto-advancing mock clock (@talex5 #644, reviewed by @SGrondin). + Simplifies testing of code using clocks. + +- Add `Buf_write.printf` (@SGrondin @talex5 #655). + +- Add `Net.listening_addr` (@mefyl #555, reviewed by @patricoferris @talex5). + Useful to get the socket's address if the OS assigns it. + +- Add `Promise.try_resolve` (@talex5 #646). + +- Remove `Cancel_hook_failed` exception (@talex5 #640). + Didn't seem to be used and broke dscheck. + +Tracing: + +- Improve tracing (@TheLortex @patricoferris @talex5 #656). + Trace cancellation contexts and OS operations, and simplify API. + +- Add labels to switches (@talex5 #661, reviewed by @SGrondin). + +- `Fiber.all`: use the parent fiber (@talex5 #665, reviewed by @SGrondin). + Cleans up the traces a bit. + +Performance: + +- Faster and simpler `Lf_queue` (@talex5 #647, based on work by @polytypic). + +- Optimise `Flow.copy` with `Buf_read.as_flow` (@talex5 #663, reviewed by @SGrondin, reported by @leostera). + +Bug fixes: + +- Fix handling of very long IO vectors (@talex5 #653, reported by @Cjen1). + +- eio_posix: use `caml_enter_blocking_section` in more places (@talex5 #654, reviewed by @SGrondin). + +- eio_posix: work around `caml_unix_alloc_sockaddr` bug (@talex5 #651). + +- Remove default backtrace from `Switch.fail` (@talex5 #664). + +Documentation: + +- Organise eio.mli better (@talex5 #667). + +- Fix quoting of quotes in process error messages (@talex5 #666, reviewed by @SGrondin). + +- Mention Path module in File and Fs documentation (@talex5 #659, requested by @clecat). + +- Minor documentation updates (@SGrondin @talex5 #670). + +Build / internals: + +- Allow closing synchronous streams (@talex5 #641, reviewed by @SGrondin). + This isn't currently exposed in the public interface. + +- Fix non-idempotent tests (@SGrondin #662). + +- eio_windows: add explicit fmt dependency (@talex5 #643). + +## v0.13 + +New features / API changes: + +- Add `Flow.read_all` (@SGrondin #596, reviewed by @talex5 @rbjorklin). + +- Add `Path.stat` (@patricoferris @talex5 @avsm #617 #618 #624 #620, reviewed by @SGrondin). + +- Add `Path.rmtree` (@talex5 #627 #628, reviewed by @SGrondin). + +- Add `Path.mkdirs` and `Path.split` (@patricoferris @talex5 #625). + +- Add `Eio.File.{seek,sync,truncate}` (@talex5 #626). + +- Add `Eio.Path.{kind,is_file,is_directory}` (@patricoferris @talex5 #623, reviewed by @avsm). + +- Switch from CTF to OCaml 5.1 runtime events (@TheLortex @patricoferris @talex5 #634 #635, reviewed by @avsm). + This is a minimal initial version. + +Documentation: + +- Document `File.Stat` record fields (@avsm @talex5 #621). + +- Update README section about `env` (@talex5 #614, reported by @jonsterling). + +Build and test changes: + +- Add `File.stat` benchmark (@talex5 #616). + +- Add `Path.stat` benchmark (@patricoferris @talex5 #630). + +- eio_linux: mark as only available on Linux (@talex5 #629). + +- Make MDX tests idempotent (@SGrondin #601, reviewed by @talex5). + +- Allow trailing whitespace in CHANGES.md (@talex5 #632). + +- Update minimum OCaml version to 5.1 (@talex5 #631). + +- Generate prototypes for C stubs from ml files (@talex5 #615). + +- Don't try to compile uring support on centos 7 (@talex5 #638, reported by @zenfey). + +## v0.12 + +New features / API changes: + +- Replace objects with variants (@talex5 @patricoferris #553 #605 #608, reviewed by @avsm). + Some potential users found object types confusing, so we now use an alternative scheme for OS resources. + For users of the resources, the only thing that changes is the types: + + - Instead of taking an argument of type `#foo`, you should now take `_ foo`. + - Instead of returning a value of type `foo`, you should now return `foo_ty Eio.Resource.t`. + + To provide your own implementation of an interface, you now provide a module rather than an object. + For example, to provide your own source flow, use `Eio.Flow.Pi.source (module My_source)`. + + If you want to define your own interfaces, see the `Eio.Resource` module documentation. + +- Add `Eio.Pool` (@talex5 @darrenldl #602, reviewed by @patricoferris). + A lock-free pool of resources. This is similar to `Lwt_pool`. + +- Add `Eio.Lazy` (@talex5 #609, reviewed by @SGrondin). + If one fiber tries to force a lazy value while another is already doing it, + this will wait for the first one to finish rather than raising an exception (as `Stdlib.Lazy` does). + +- Add `Eio.Path.native` (@talex5 #603, reviewed by @patricoferris). + This is useful when interacting with non-Eio libraries, for spawning sub-processes, and for displaying paths to users. + +- Add `Flow.single_write` (@talex5 #598). + +- Add `Eio.Flow.Pi.simple_copy` (@talex5 #611). + Provides an easy way to implement the `copy` operation when making your own sink. + +- Eio_unix: add FD passing (@talex5 #522). + Allows opening a file and passing the handle over a Unix-domain socket. + +- Add `Process.run ?is_success` to control definition of success (@SGrondin #586, reviewed by @talex5). + +- Add `Eio_mock.Domain_manager` (@talex5 #610). + This mock domain manager runs everything in a single domain, allowing tests to remain deterministic. + +- Add `Eio.Debug.with_trace_prefix` (@talex5 #610). + Allows prefixing all `traceln` output. The mock domain manager uses this to indicate which fake domain is running. + +Bug fixes: + +- Fork actions must not allocate (@talex5 #593). + When using multiple domains, child processes could get stuck if they forked while another domain held the malloc lock. + +- eio_posix: ignore some errors writing to the wake-up pipe (@talex5 #600). + If the pipe is full or closed, the wake-up should simply be ignored. + +Build/test fixes: + +- Fix some MDX problems on Windows (@polytypic #597). + +- The README depends on kcas (@talex5 #606). + +- Clarify configuration for lib_eio_linux and enable tests on other arches (@dra27 #592). + +- eio_linux tests: skip fixed buffer test if not available (@talex5 #604). + +- eio_windows: update available line to win32 (@talex5 #588 #591). + + +## v0.11 + +New features / API changes: + +- Extend `Eio.Condition` API (@talex5 #563). + - `loop_no_mutex` is a simpler and more efficient way to way for a condition. + - `register_immediate` allows integration with other IO libraries. + +- Expose `Eio.Stdenv.backend_id` (@bord-o #560, reviewed by @talex5). + Useful in tests to report which backend is being used. + +- Remove deprecated features (@talex5 #552, reviewed by @avsm). + These were all already marked as deprecated in v0.10 and are now gone completely: + - `Fiber.fork_sub` + - `Eio_unix.{FD,Ipaddr,socketpair,getnameinfo}` + - `Eio_linux.{FD,get_fd,get_fd_opt}` + - `Eio_posix.Low_level.Fd` + +- Allow calling `close` more than once (@talex5 #547, requested by @anmonteiro, reviewed by @patricoferris, @avsm). + +- Add `close` to socket type (@talex5 #549). + Simplifies the type signatures a bit by avoiding having to mention this everywhere. + +Bug fixes: + +- Fix handling of empty path strings (@talex5 #569, reported by @SGrondin). + Using "" instead of "." in some places resulted in an error. + +- eio_posix: fix update to watched FDs on cancel (@talex5 #574, reported and reviewed by @quernd). + Cancelling the last watcher of an FD didn't remove it from the set passed to `poll`, + which could result in constant wake-ups. + +- eio_posix: fix `pread` at end-of-file (@talex5 #581, reported by @SGrondin). + It tried to return 0 instead of `End_of_file`, triggering an assertion. + +- eio_posix: don't reap non-Eio child processes (@talex5 #562). + This allows spawning processes with e.g. the stdlib or Lwt + (but see https://github.com/ocaml-multicore/lwt_eio/pull/19 for Lwt support). + +- Preserve backtraces across `Domain_manager.run` (@talex5 #571). + See https://github.com/ocaml/ocaml/issues/12362. + +- Correct the backend selection for Cygwin (@dra27 #557). + Use `eio_posix`, not `eio_windows` in this case. + +Other changes: + +- Simplify dune files with dune 3.9's `build_if` (@talex5 #582). + +- Remove `Waiters` from `Eio_core` (@talex5 #567). + `Eio.Switch` no longer uses this so it can finally be removed. + +- Use `Fmt.Dump.signal` to format signals (@talex5, @MisterDA #543). + +Documentation: + +- Add some notes about thread-safety in the documentation (@talex5 #568). + +## v0.10 + +New features / API changes: + +- Add `Eio.Process` for cross-platform subprocess support (@patricoferris @talex5 #499, reviewed by @anmonteiro @avsm @haesbaert). + +- Add `Eio_unix.Net module` (@talex5 #516, reviewed by @avsm). + The Unix network APIs have been cleaned up and moved here, and some missing datagram operations have been added. + `send` now takes an iovec, not just a single buffer. + +- Add support for domain local await (@polytypic @talex5 #494 #503). + Allows sharing e.g. kcas data-structures across Eio and Domainslib domains. + +- Add initial eio_windows backend (@patricoferris @talex5 #497 #530 #511 #523 #509, reviewed by @avsm @polytypic). + +- Remove eio_luv backend (@talex5 #485). + It was only used on Windows, and has been replaced by eio_windows. + +- Unify `Eio_linux.FD` and `Eio_posix.Fd` as `Eio_unix.Fd` (@talex5 #491). + Now that eio_luv is gone, there is no need for different backends to have different types for wrapped file descriptors. + +- Move `Eio.Stdenv.t` to `Eio_unix.Stdenv.base` (@talex5 #498). + Note that the rest of `Eio.Stdenv` is still there; only the definition of a full Unix-like environment has moved. + +- Deprecation cleanups (@talex5 #508). + Removed some APIs that were already marked as deprecated in Eio 0.8. + +Bug fixes: + +- eio_linux: fall back to `fork` if `clone3` is unavailable (@talex5 #524, reported by @smondet, reviewed by @avsm). + Docker's default security policy blocks `clone3`. + +- Don't call `accept_fork`'s error handler on cancellation (@talex5 #520). + This isn't an error and should not be reported. + +- Fix `eio_unix_is_blocking` C stub (@patricoferris #505, reviewed by @talex5). + +- Fix `Condition.await bug` when cancelling (@polytypic @talex5 #487). + +- Buf_write: fix flush returning too early (@talex5 #539, reported by @cometkim). + +- Ignore `ENOTCONN` errors on socket shutdown (@avsm #533, reported by @patricoferris, reviewed by @talex5). + +Documentation: + +- Link to developer meetings information (@talex5 @Sudha247 #515). + +- Adopt OCaml Code of Conduct (@Sudha247 #501). + +- Add README links to Meio and Lambda Capabilities blog post (@talex5 #496). + +- Document mirage `Ipaddr` conversion (@RyanGibb @patricoferris @talex5 #492). + +- Document how to use Domainslib from Eio (@talex5 #489, reviewed by @polytypic @patricoferris). + +Other changes: + +- Run benchmarks with current-bench (@Sudha247 @talex5 #500). + +- Fix MDX tests on OCaml 5.1 (@talex5 #526). + +- Add stress test for spawning processes (@talex5 #519). + This was an attempt to track down the https://github.com/ocaml/ocaml/issues/12253 signals bug. + +- `Eio.Process.pp_status` should be polymorphic (@talex5 #518). + +- eio_posix: probe for existence of some flags (@talex5 #507, reported by @hannesm). + FreeBSD 12 didn't have `O_DSYNC`. Also, add `O_RESOLVE_BENEATH` and `O_PATH` if available. + +- Fix race in ctf tests (@talex5 #493). + +## v0.9 + +New features: + +- Add eio_posix backend (@talex5 @haesbaert #448 #477, reviewed by @avsm @patricoferris @polytypic). + This replaces eio_luv on all platforms except Windows (which will later switch to its own backend). It is a lot faster, provides access to more modern features (such as `openat`), and can safely share OS resources between domains. + +- Add subprocess support (@patricoferris @talex5 #461 #464 #472, reviewed by @haesbaert @avsm). + This is the low-level API support for eio_linux and eio_posix. A high-level cross-platform API will be added in the next release. + +- Add `Fiber.fork_seq` (@talex5 #460, reviewed by @avsm). + This is a light-weight alternative to using a single-producer, single-consumer, 0-capacity stream, similar to a Python generator function. + +Bug fixes: + +- eio_linux: make it safe to share FDs across domains (@talex5 #440, reviewed by @haesbaert). + It was previously not safe to share file descriptors between domains because if one domain used an FD just as another was closing it, and the FD got reused, then the original operation could act on the wrong file. + +- eio_linux: release uring if Linux is too old (@talex5 #476). + Avoids a small resource leak. + +- eio_linux: improve error handling creating pipes and sockets (@talex5 #474, spotted by @avsm). + If we get an error (e.g. too many FDs) then report it to the calling fiber, instead of exiting the event loop. + +- eio_linux: wait for uring to finish before exiting (@talex5 #470, reviewed by @avsm). + If the main fiber raised an exception then it was possible to exit while a cancellation operation was still in progress. + +- eio_main: make `EIO_BACKEND` handling more uniform (@talex5 #447). + Previously this environment variable was only used on Linux. Now all platforms check it. + +- Tell dune about `EIO_BACKEND` (@talex5 #442). + If this changes, dune needs to re-run the tests. + +- eio_linux: add some missing close-on-execs (@talex5 #441). + +- eio_linux: `read_exactly` fails to update file offset (@talex5 #438). + +- Work around dune `enabled_if` bug on non-Linux systems (@polytypic #475, reviewed by @talex5). + +- Use raw system call of `getrandom` for glibc versions before 2.25 (@zenfey #482). + +Documentation: + +- Add `HACKING.md` with hints for working on Eio (@talex5 #443, reviewed by @avsm @polytypic). + +- Improve worker pool example (@talex5 #454). + +- Add more Conditions documentation (@talex5 #436, reviewed by @haesbaert). + This adds a discussion of conditions to the README and provides examples using them to handle signals. + +- Condition: fix the example in the docstring (@avsm #468). + +Performance: + +- Add a network benchmark using an HTTP-like protocol (@talex5 #478, reviewed by @avsm @patricoferris). + +- Add a benchmark for reading from `/dev/zero` (@talex5 #439). + +Other changes: + +- Add CI for macOS (@talex5 #452). + +- Add tests for `pread`, `pwrite` and `readdir` (@talex5 #451). + +- eio_linux: split into multiple files (@talex5 #465 #466, reviewed by @avsm). + +- Update Dockerfile (@talex5 #471). + +- Use dune.3.7.0 (@patricoferris #457). + +- Mint exclusive IDs across domains (@TheLortex #480, reported by @haesbaert, reviewed by @talex5). + The tracing currently only works with a single domain anyway, but this will change when OCaml 5.1 is released. + + +## v0.8.1 + +Some build fixes: + +- Fix build on various architectures (@talex5 #432). + - Work around dune `%{system}` bug. + - eio_luv: fix `max_luv_buffer_size` on 32-bit platforms. + +- Add missing test-dependency on MDX (@talex5 #430). + +## v0.8 + +New features: + +- Add `Eio.Net.run_server` (@bikallem @talex5 #408). + Runs an accept loop in one or more domains, with cancellation and graceful shutdown, + and an optional maximum number of concurrent connections. + +- Add `Buf_read.BE` and `LE` parsers (@Cjen1 #399). + Parse numbers in various binary formats. + +- Add `Eio.Buf_read.uint8` (@talex5 #418). + +Performance: + +- Make `Eio.Condition` lock-free (@talex5 #397 #381). + In addition to being faster, this allows using conditions in signal handlers. + +- Make `Eio.Semaphore` lock-free (@talex5 @polytypic #398). + +- Make `Eio.Stream` lock-free when the capacity is zero (@talex5 #413 #411). + +- Make `Eio.Promise` lock-free (@talex5 #401). + +Bug fixes: + +- eio_linux: call `Uring.submit` as needed (@talex5 @bikallem #428). + Previously, we could fail to submit a job promptly because the SQE queue was full. + +- Fix luv signals (@haesbaert #412). + `libuv` automatically retries polling if it gets `EINTR`, without giving OCaml signal handlers a chance to run. + +- eio_luv: fix some resource leaks (@talex5 @patricoferris #421). + +- eio_luv: fix "unavailable signal" error on Windows (@talex5 #420, reported by @nojb). + +- Fix `Buf_write.BE.uint48` and `LE.uint48` (@adatario #418). + +Documentation: + +- Add example programs (@talex5 #389). + +- Update network examples to use `run_server` (@talex5 #417). + +- Add a warning to the tutorial about `Fiber.first` (@talex5 #394). + +- Clarify the epoch used for `Eio.Time.now` (@bikallem #395). + +- Describe `secure_random` as an infinite source (@patricoferris #426). + +- Update README for OCaml 5 release (@talex5 #384 #391 #393). + +Other changes: + +- Delay setting `SIGPIPE` handler until the `run` function is called (@talex5 #420). + +- Remove debug-level logging (@talex5 #403). + +- eio-luv: improve `process.md` test (@smondet #414). + +- Update to Dune 3 (@talex5 #410). + +- Remove test dependency on Astring (@talex5 #402 #404). + +- Simplify cancellation logic (@talex5 #396). + +- time: `Mtime.Spand.to_s` has been deprecated in mtime 2.0.0 (@bikallem #385). + +## v0.7 + +API changes: + +- Unify IO errors as `Eio.Io` (@talex5 #378). + This makes it easy to catch and log all IO errors if desired. + The exception payload gives the type and can be used for matching specific errors. + It also allows attaching extra information to exceptions, and various functions were updated to do this. + +- Add `Time.Mono` for monotonic clocks (@bikallem @talex5 #338). + Using the system clock for timeouts, etc can fail if the system time is changed during the wait. + +- Allow datagram sockets to be created without a source address (@bikallem @haesbaert #360). + The kernel will allocate an address in this case. + You can also now control the `reuse_addr` and `reuse_port` options. + +- Add `File.stat` and improve `Path.load` (@haesbaert @talex5 #339). + `Path.load` now uses the file size as the initial buffer size. + +- Add `Eio_unix.pipe` (@patricoferris #350). + This replaces `Eio_linux.pipe`. + +- Avoid short reads from `getrandom(2)` (@haesbaert #344). + Guards against buggy user code that might not handle this correctly. + +- Rename `Flow.read` to `Flow.single_read` (@talex5 #353). + This is a low-level function and it is easy to use it incorrectly by ignoring the possibility of short reads. + +Bug fixes: + +- Eio_luv: Fix non-tail-recursive continue (@talex5 #378). + Affects the `Socket_of_fd` and `Socketpair` effects. + +- Eio_linux: UDP sockets were not created close-on-exec (@talex5 #360). + +- Eio_linux: work around io_uring non-blocking bug (@haesbaert #327 #355). + The proper fix should be in Linux 6.1. + +- `Eio_mock.Backend`: preserve backtraces from `main` (@talex5 #349). + +- Don't lose backtrace in `Switch.run_internal` (@talex5 #369). + +Documentation: + +- Use a proper HTTP response in the README example (@talex5 #377). + +- Document that read_dir excludes "." and ".." (@talex5 #379). + +- Warn about both operations succeeding in `Fiber.first` (@talex5 #358, reported by @iitalics). + +- Update README for OCaml 5.0.0~beta2 (@talex5 #375). + +Backend-specific changes: + +- Eio_luv: add low-level process support (@patricoferris #359). + A future release will add Eio_linux support and a cross-platform API for this. + +- Expose `Eio_luv.Low_level.Stream.write` (@patricoferris #359). + +- Expose `Eio_luv.Low_level.get_loop` (@talex5 #371). + This is needed if you want to create resources directly and then use them with Eio_luv. + +- `Eio_linux.Low_level.openfile` is gone (@talex5 #378). + It was just left-over test code. + + +## v0.6 + +Changes: + +- Update to OCaml 5.0.0~beta1 (@anmonteiro @talex5 #346). + +- Add API for seekable read/writes (@nojb #307). + +- Add `Flow.write` (@haesbaert #318). + This provides an optimised alternative to `copy` in the case where you are writing from a buffer. + +- Add `Net.with_tcp_connect` (@bikallem #302). + Convenience function for opening a TCP connection. + +- Add `Eio.Time.Timeout` (@talex5 #320). + Makes it easier to pass timeouts around. + +- Add `Eio_mock.Clock` (@talex5 #328). + Control time in tests. + +- Add `Buf_read.take_while1` and `skip_while1` (@bikallem #309). + These fail if no characters match. + +- Make the type parameter for `Promise.t` covariant (@anmonteiro #300). + +- Move list functions into a dedicated submodule (@raphael-proust #315). + +- Direct implementation of `Flow.source_string` (@c-cube #317). + Slightly faster. + +Bug fixes: + +- `Condition.broadcast` must interlock as well (@haesbaert #324). + +- Split the reads into no more than 2^32-1 for luv (@haesbaert @talex5 @EduardoRFS #343). + Luv uses a 32 bit int for buffer sizes and wraps if the value passed is too big. + +- eio_luv: allow `Net.connect` to be cancelled (@talex5 @nojb #311). + +- eio_main: Use dedicated log source (@anmonteiro #326). + +- linux_eio: fix kernel version number in log message (@talex5 @nojb #314). + +- Account for stack differences in the socketpair test (issue #312) (@haesbaert #313). + +Documentation: + +- Add Best Practices section to README (@talex5 #299). + +- Documentation improvements (@talex5 #295 #337). + + +## v0.5 + +New features: + +- Add `Eio.Condition` (@TheLortex @talex5 #277). + Allows a fiber to wait for some condition to become true. + +- Add `Eio.Net.getaddrinfo` and `getnameinfo` (@bikallem @talex5 #278 #288 #291). + Convert between host names and addresses. + +- Add `Eio.Debug` (@talex5 #276). + Currently, this allows overriding the `traceln` function. + +- `Buf_write.create`: make switch optional (@talex5 #283). + This makes things easier for people porting code from Faraday. + +Bug fixes: + +- Allow sharing of libuv poll handles (@patricoferris @talex5 #279). + Luv doesn't allow two callers to watch the same file handle, so we need to handle that in Eio. + +Other changes: + +- Upgrade to uring 0.4 (@talex5 #290). + +- Mention `Mutex`, `Semaphore` and `Condition` in the README (@talex5 #281). + +## v0.4 + +Note: Eio 0.4 drops compatibility with OCaml 4.12+domains. Use OCaml 5.0.0~alpha1 instead. + +API changes: + +- `Eio.Dir` has gone. Use `Eio.Path` instead (@talex5 #266 #270). + +- `Eio_unix.FD.{take,peek}` were renamed to `take_opt`/`peek_opt` to make way for non-optional versions. + +New features: + +- Fiber-local storage (@SquidDev #256). + Attach key/value bindings to fibers. These are inherited across forks. + +- `Eio.Path.{unlink,rmdir,rename}` (@talex5 #264 #265). + +- `Eio_main.run` can now return a value (@talex5 #263). + This is useful for e.g. cmdliner. + +- `Eio_unix.socketpair` (@talex5 #260). + +- `Fiber.fork_daemon` (@talex5 #252). + Create a helper fiber that does not prevent the switch from exiting. + +- Add `Fiber.{iter,map,filter,fiter_map}` (@talex5 #248 #250). + These are concurrent versions of the corresponding operations in `List`. + +Bug fixes: + +- Fix scheduling fairness in luv backend (@talex5 #269). + +- Implement remaining shutdown commands for luv (@talex5 #268). + +- Fix IPv6 support with uring backend (@haesbaert #261 #262). + +- Use `Eio.Net.Connection_reset` exception in more places (@talex5 #257). + +- Report use of closed FDs better (@talex5 #255). + Using a closed FD could previously cause the whole event loop to exit. + +- Some fixes for cancellation (@talex5 #254). + +- Ensure `Buf_write` still flushes if an exception is raised (@talex5 #246). + +- Do not allow close on `accept_fork` socket (@talex5 #245). + +Documentation: + +- Document integrations with Unix, Lwt and Async (@talex5 #247). + +- Add a Dockerfile for easy testing (@talex5 #224). + +## v0.3 + +API changes: + +- `Net.accept_sub` is deprecated in favour of `accept_fork` (@talex5 #240). + `Fiber.fork_on_accept`, which it used internally, has been removed. + +- Allow short writes in `Read_source_buffer` (@talex5 #239). + The reader is no longer required to consume all the data in one go. + Also, add `Linux_eio.Low_level.writev_single` to expose this behaviour directly. + +- `Eio.Unix_perm` is now `Eio.Dir.Unix_perm`. + +New features: + +- Add `Eio.Mutex` (@TheLortex @talex5 #223). + +- Add `Eio.Buf_write` (@talex5 #235). + This is a buffered writer for Eio sinks, based on Faraday. + +- Add `Eio_mock` library for testing (@talex5 #228). + At the moment it has mock flows and networks. + +- Add `Eio_mock.Backend` (@talex5 #237 #238). + Allows running tests without needing a dependency on eio_main. + Also, as it is single-threaded, it can detect deadlocks in test code instead of just hanging. + +- Add `Buf_read.{of_buffer, of_string, parse_string{,_exn}, return}` (@talex5 #225). + +- Add `<*>` combinator to `Buf_read.Syntax` (@talex5 #227). + +- Add `Eio.Dir.read_dir` (@patricoferris @talex5 #207 #218 #219) + +Performance: + +- Add `Buf_read` benchmark and optimise it a bit (@talex5 #230). + +- Inline `Buf_read.consume` to improve performance (@talex5 #232). + +Bug fixes / minor changes: + +- Allow IO to happen even if a fiber keeps yielding (@TheLortex @talex5 #213). + +- Fallback for `traceln` without an effect handler (@talex5 #226). + `traceln` now works outside of an event loop too. + +- Check for cancellation when creating a non-protected child context (@talex5 #222). + +- eio_linux: handle EINTR when calling `getrandom` (@bikallem #212). + +- Update to cmdliner.1.1.0 (@talex5 #190). + +## v0.2 + +- Add support for UDP (@patricoferris #171). + +- Rename Fibre to Fiber (@talex5 #195). This is to match the compiler's spelling. + +- Switch to luv backend if uring can't be used (@talex5 #203). + Useful on Windows with WSL, and also in Docker containers on older systems. + +- Eio_linux: cope with lack of fixed chunks (@talex5 #200). + - If we run out of fixed memory, just use regular memory instead of waiting (which might deadlock). + - If we try to allocate a fixed buffer and fail, we now just log a warning and continue without one. + +- Add support for FD passing with Eio_linux (@talex5 #199). + +- Add `Eio_unix.FD.as_socket` (@talex5 #193). + Useful for working with existing libraries that provide a `Unix.file_descr`, or for receiving FDs from elsewhere (e.g. socket activation). + Also, the `Luv.{File,Handle}.of_luv` functions now allow controlling whether to close the wrapped FD. + +- Add `Eio_unix.sleep` (@talex5 #188). Based on feedback that some people don't want to treat time as a capability. Possibly also useful for debugging race conditions. + +- Tidy up forking API (@talex5 #192). Moves some common code out the the individual backends. + +- Improve documentation (@talex5 #197 #194 #186 #185). In particular, explain more low-level details about how cancellation works. + +- Add an example `Eio_null` backend (@talex5 #189). This supports creating fibers, promises and cancellation, but provides no IO operations. + +- `Effect.eff` is now `Effect.t` in OCaml trunk (@talex5 #201). + +## v0.1 + +- Initial release. diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md index 57ae5cbef..ed3f58d48 100644 --- a/CODE_OF_CONDUCT.md +++ b/CODE_OF_CONDUCT.md @@ -1,14 +1,14 @@ -# Code of Conduct - -This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). - -# Enforcement - -This project follows the OCaml Code of Conduct -[enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). - -To report any violations, please contact: - -* Patrick Ferris -* Sudha Parimala -* Thomas Leonard +# Code of Conduct + +This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). + +# Enforcement + +This project follows the OCaml Code of Conduct +[enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). + +To report any violations, please contact: + +* Patrick Ferris +* Sudha Parimala +* Thomas Leonard diff --git a/Dockerfile b/Dockerfile index 6e7f5e508..b660eaae7 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,16 +1,16 @@ -FROM ocaml/opam:debian-11-ocaml-5.2 -# Make sure we're using opam-2.1: -RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam -# Ensure opam-repository is up-to-date: -RUN cd opam-repository && git pull -q origin 97de3378749cf8d2d70a5d710d310e5cc17c9dea && opam update -# Install utop for interactive use: -RUN opam install utop fmt -# Install Eio's dependencies (adding just the opam files first to help with caching): -RUN mkdir eio -WORKDIR eio -COPY *.opam ./ -RUN opam pin --with-version=dev . -yn -RUN opam install --deps-only eio_main eio_linux eio -# Build Eio: -COPY . ./ -RUN opam install eio_main +FROM ocaml/opam:debian-11-ocaml-5.2 +# Make sure we're using opam-2.1: +RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam +# Ensure opam-repository is up-to-date: +RUN cd opam-repository && git pull -q origin 97de3378749cf8d2d70a5d710d310e5cc17c9dea && opam update +# Install utop for interactive use: +RUN opam install utop fmt +# Install Eio's dependencies (adding just the opam files first to help with caching): +RUN mkdir eio +WORKDIR eio +COPY *.opam ./ +RUN opam pin --with-version=dev . -yn +RUN opam install --deps-only eio_main eio_linux eio +# Build Eio: +COPY . ./ +RUN opam install eio_main diff --git a/HACKING.md b/HACKING.md index 906d8772f..b7755190d 100644 --- a/HACKING.md +++ b/HACKING.md @@ -1,138 +1,138 @@ -## Installing Eio from Git - -If you want to run the latest development version from Git, run these commands: - -``` -git clone https://github.com/ocaml-multicore/eio.git -cd eio -opam pin -yn . -opam install eio_main -``` - -## Layout of the code - -`lib_eio/core` contains the core logic about fibers, promises, switches, etc. -`lib_eio` extends this with e.g. streams, buffered readers, buffered writers, -and a load of types for OS resources (files, networks, etc). - -There is one directory for each backend (e.g. `eio_linux`). -Each backend provides a scheduler that integrates with a particular platform, -and implements some or all of the cross-platform resource APIs. -For example, `eio_linux` implements the network interface using `io_uring` to send data. - -`lib_main` just selects an appropriate backend for the current system. - -## Writing a backend - -It's best to start by reading `lib_eio/mock/backend.ml`, which implements a mock backend with no actual IO. -You can then read one of the real backends to see how to integrate this with the OS. - -Most backends are built in two layers: - -- A "low-level" module directly wraps the platform's own API, just adding support for suspending fibers for concurrency - and basic safety features (such wrapping `Unix.file_descr` to prevent use-after-close races). - -- An implementation of the cross-platform API (as defined in the `eio` package) that uses the low-level API internally. - This should ensure that errors are reported using the `Eio.Io` exception. - -`eio_posix` is the best one to look at first: - -- `lib_eio_posix/sched.ml` is similar to the mock scheduler, but extended to interact with the OS kernel. -- `lib_eio_posix/low_level.ml` provides fairly direct wrappers of the standard POSIX functions, - but using `sched.ml` to suspend and resume instead of blocking the whole domain. -- `lib_eio_posix/net.ml` implements the cross-platform API using the low-level API. - For example, it converts Eio network addresses to Unix ones. - Likewise, `fs.ml` implements the cross-platform file-system APIs, etc. -- `lib_eio_posix/eio_posix.ml` provides the main `run` function. - It runs the scheduler, passing to the user's `main` function an `env` object for the cross-platform API functions. - -When writing a backend, it's best to write the main loop in OCaml rather than delegate that to a C function. -Some particular things to watch out for: - -- If a system call returns `EINTR`, you must switch back to OCaml - (`caml_leave_blocking_section`) so that the signal can be handled. Some C - libraries just restart the function immediately and this will break signal - handling (on systems that have signals). - -- If C code installs a signal handler, it *must* use the alt stack (`SA_ONSTACK`). - Otherwise, signals handlers will run on the fiber stack, which is too small and will result in memory corruption. - -- Effects cannot be performed over a C function. - So, if the user installs an effect handler and then calls a C mainloop, and the C code invokes a callback, - the callback cannot use the effect handler. - This isn't a problem for Eio itself (Eio's effect handler is installed inside the mainloop), - but it can break programs using effects in other ways. - -## Tests - -Eio has tests in many places... - -### Cross-platform unit tests - -These are in the top-level `tests` directory. -They are run against whichever backend `Eio_main.run` selects, and therefore must get the same result for all backends. - -### Concurrency primitives - -`lib_eio/tests` tests some internal data structures, such as the lock-free cells abstraction. -The `.md` files in that directory provide a simple walk-through to demonstrate the basic operation, -while `lib_eio/tests/dscheck` uses [dscheck][] to perform exhaustive testing of all atomic interleavings. - -At the time of writing, dscheck has some performance problems that make it unusable by default, so -you must use the version in https://github.com/ocaml-multicore/dscheck/pull/22 instead. - -### Benchmarks - -The `bench` directory contains various speed tests. -`make bench` is a convenient way to run all of them. -This is useful to check for regressions. - -If you want to contibute an optimisation, please add a benchmark so that we can measure the improvement. -If you are changing something, make sure the benchmark doesn't get significantly worse. - -### Stress and fuzz testing - -The `fuzz` directory uses afl-fuzz to search for bugs. - -Using it properly requires an instrumented version of the OCaml compiler -(see https://v2.ocaml.org/manual/afl-fuzz.html for instructions). -The `dune` build rules don't use afl-fuzz; they just do a few random tests and then stop. - -To run e.g. the `fuzz_buf_read` tests with afl-fuzz: - -``` -mkdir input -date > input/seed -afl-fuzz -m 1000 -i input -o output ./_build/default/fuzz/fuzz_buf_read.exe @@ -``` - -- `Fork server handshake failed` indicates that you are not using an AFL-enabled version of OCaml. -- `The current memory limit (75.0 MB) is too restrictive` means you forgot to use `-m`. - -The `stress` directory contains stress tests (that try to trigger races by brute force). - -### Backend-specific tests - -There are also backend-specific tests, e.g. - -- `lib_eio_linux/tests` -- `lib_eio_luv/tests` - -Use these for tests that only make sense for one platform. - -### Formal verification - -Some parts of Eio have been formally verified: - -- https://github.com/addap/master-thesis/tree/main/documents [[video](https://discuss.ocaml.org/t/video-verifying-an-effect-based-cooperative-concurrency-scheduler-in-iris-by-adrian-dapprich/13825)] -- https://github.com/clef-men/zebre/tree/main/theories/eio - -## Code formatting - -Eio's code is indented using ocp-indent. -When making PRs, please do not apply other formatting tools to existing code unrelated to your PR. -Try to avoid making unnecessary changes; this makes review harder and clutters up the Git history. -`ocamlformat` may be useful to get badly messed up code to a baseline unformatted state, -from which human formatting can be added where needed. - -[dscheck]: https://github.com/ocaml-multicore/dscheck +## Installing Eio from Git + +If you want to run the latest development version from Git, run these commands: + +``` +git clone https://github.com/ocaml-multicore/eio.git +cd eio +opam pin -yn . +opam install eio_main +``` + +## Layout of the code + +`lib_eio/core` contains the core logic about fibers, promises, switches, etc. +`lib_eio` extends this with e.g. streams, buffered readers, buffered writers, +and a load of types for OS resources (files, networks, etc). + +There is one directory for each backend (e.g. `eio_linux`). +Each backend provides a scheduler that integrates with a particular platform, +and implements some or all of the cross-platform resource APIs. +For example, `eio_linux` implements the network interface using `io_uring` to send data. + +`lib_main` just selects an appropriate backend for the current system. + +## Writing a backend + +It's best to start by reading `lib_eio/mock/backend.ml`, which implements a mock backend with no actual IO. +You can then read one of the real backends to see how to integrate this with the OS. + +Most backends are built in two layers: + +- A "low-level" module directly wraps the platform's own API, just adding support for suspending fibers for concurrency + and basic safety features (such wrapping `Unix.file_descr` to prevent use-after-close races). + +- An implementation of the cross-platform API (as defined in the `eio` package) that uses the low-level API internally. + This should ensure that errors are reported using the `Eio.Io` exception. + +`eio_posix` is the best one to look at first: + +- `lib_eio_posix/sched.ml` is similar to the mock scheduler, but extended to interact with the OS kernel. +- `lib_eio_posix/low_level.ml` provides fairly direct wrappers of the standard POSIX functions, + but using `sched.ml` to suspend and resume instead of blocking the whole domain. +- `lib_eio_posix/net.ml` implements the cross-platform API using the low-level API. + For example, it converts Eio network addresses to Unix ones. + Likewise, `fs.ml` implements the cross-platform file-system APIs, etc. +- `lib_eio_posix/eio_posix.ml` provides the main `run` function. + It runs the scheduler, passing to the user's `main` function an `env` object for the cross-platform API functions. + +When writing a backend, it's best to write the main loop in OCaml rather than delegate that to a C function. +Some particular things to watch out for: + +- If a system call returns `EINTR`, you must switch back to OCaml + (`caml_leave_blocking_section`) so that the signal can be handled. Some C + libraries just restart the function immediately and this will break signal + handling (on systems that have signals). + +- If C code installs a signal handler, it *must* use the alt stack (`SA_ONSTACK`). + Otherwise, signals handlers will run on the fiber stack, which is too small and will result in memory corruption. + +- Effects cannot be performed over a C function. + So, if the user installs an effect handler and then calls a C mainloop, and the C code invokes a callback, + the callback cannot use the effect handler. + This isn't a problem for Eio itself (Eio's effect handler is installed inside the mainloop), + but it can break programs using effects in other ways. + +## Tests + +Eio has tests in many places... + +### Cross-platform unit tests + +These are in the top-level `tests` directory. +They are run against whichever backend `Eio_main.run` selects, and therefore must get the same result for all backends. + +### Concurrency primitives + +`lib_eio/tests` tests some internal data structures, such as the lock-free cells abstraction. +The `.md` files in that directory provide a simple walk-through to demonstrate the basic operation, +while `lib_eio/tests/dscheck` uses [dscheck][] to perform exhaustive testing of all atomic interleavings. + +At the time of writing, dscheck has some performance problems that make it unusable by default, so +you must use the version in https://github.com/ocaml-multicore/dscheck/pull/22 instead. + +### Benchmarks + +The `bench` directory contains various speed tests. +`make bench` is a convenient way to run all of them. +This is useful to check for regressions. + +If you want to contibute an optimisation, please add a benchmark so that we can measure the improvement. +If you are changing something, make sure the benchmark doesn't get significantly worse. + +### Stress and fuzz testing + +The `fuzz` directory uses afl-fuzz to search for bugs. + +Using it properly requires an instrumented version of the OCaml compiler +(see https://v2.ocaml.org/manual/afl-fuzz.html for instructions). +The `dune` build rules don't use afl-fuzz; they just do a few random tests and then stop. + +To run e.g. the `fuzz_buf_read` tests with afl-fuzz: + +``` +mkdir input +date > input/seed +afl-fuzz -m 1000 -i input -o output ./_build/default/fuzz/fuzz_buf_read.exe @@ +``` + +- `Fork server handshake failed` indicates that you are not using an AFL-enabled version of OCaml. +- `The current memory limit (75.0 MB) is too restrictive` means you forgot to use `-m`. + +The `stress` directory contains stress tests (that try to trigger races by brute force). + +### Backend-specific tests + +There are also backend-specific tests, e.g. + +- `lib_eio_linux/tests` +- `lib_eio_luv/tests` + +Use these for tests that only make sense for one platform. + +### Formal verification + +Some parts of Eio have been formally verified: + +- https://github.com/addap/master-thesis/tree/main/documents [[video](https://discuss.ocaml.org/t/video-verifying-an-effect-based-cooperative-concurrency-scheduler-in-iris-by-adrian-dapprich/13825)] +- https://github.com/clef-men/zebre/tree/main/theories/eio + +## Code formatting + +Eio's code is indented using ocp-indent. +When making PRs, please do not apply other formatting tools to existing code unrelated to your PR. +Try to avoid making unnecessary changes; this makes review harder and clutters up the Git history. +`ocamlformat` may be useful to get badly messed up code to a baseline unformatted state, +from which human formatting can be added where needed. + +[dscheck]: https://github.com/ocaml-multicore/dscheck diff --git a/LICENSE.md b/LICENSE.md index 7201397c4..9315adcba 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,70 +1,70 @@ -Copyright (C) 2021 Anil Madhavapeddy -Copyright (C) 2022 Thomas Leonard - -Permission to use, copy, modify, and distribute this software for any -purpose with or without fee is hereby granted, provided that the above -copyright notice and this permission notice appear in all copies. - -THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - - -This project includes some IPv6 code by Hugo Heuzard from ocaml-ipaddr, -which has the following license: - -ISC License - -Copyright (c) 2013-2015 David Sheets -Copyright (c) 2010-2011, 2014 Anil Madhavapeddy - -Permission to use, copy, modify, and distribute this software for any -purpose with or without fee is hereby granted, provided that the above -copyright notice and this permission notice appear in all copies. - -THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - - -The `Eio.Buf_write` module is based on Faraday by Inhabited Type LLC, -which has the following license (BSD-3-clause): - -Copyright (c) 2016, Inhabited Type LLC - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS -OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. +Copyright (C) 2021 Anil Madhavapeddy +Copyright (C) 2022 Thomas Leonard + +Permission to use, copy, modify, and distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + + +This project includes some IPv6 code by Hugo Heuzard from ocaml-ipaddr, +which has the following license: + +ISC License + +Copyright (c) 2013-2015 David Sheets +Copyright (c) 2010-2011, 2014 Anil Madhavapeddy + +Permission to use, copy, modify, and distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + + +The `Eio.Buf_write` module is based on Faraday by Inhabited Type LLC, +which has the following license (BSD-3-clause): + +Copyright (c) 2016, Inhabited Type LLC + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile index b159191e5..1fe072c72 100644 --- a/Makefile +++ b/Makefile @@ -1,25 +1,25 @@ -.PHONY: all bench stress - -all: - dune build @runtest @all - -bench: - dune exec -- ./bench/main.exe - -test_posix: - EIO_BACKEND=posix dune runtest - -dscheck: - dune exec -- ./lib_eio/tests/dscheck/test_condition.exe - dune exec -- ./lib_eio/tests/dscheck/test_rcfd.exe - dune exec -- ./lib_eio/tests/dscheck/test_sync.exe - dune exec -- ./lib_eio/tests/dscheck/test_semaphore.exe - dune exec -- ./lib_eio/tests/dscheck/test_cells.exe - -stress: - dune exec -- ./stress/stress_proc.exe - dune exec -- ./stress/stress_semaphore.exe - dune exec -- ./stress/stress_release.exe - -docker: - docker build -t eio . +.PHONY: all bench stress + +all: + dune build @runtest @all + +bench: + dune exec -- ./bench/main.exe + +test_posix: + EIO_BACKEND=posix dune runtest + +dscheck: + dune exec -- ./lib_eio/tests/dscheck/test_condition.exe + dune exec -- ./lib_eio/tests/dscheck/test_rcfd.exe + dune exec -- ./lib_eio/tests/dscheck/test_sync.exe + dune exec -- ./lib_eio/tests/dscheck/test_semaphore.exe + dune exec -- ./lib_eio/tests/dscheck/test_cells.exe + +stress: + dune exec -- ./stress/stress_proc.exe + dune exec -- ./stress/stress_semaphore.exe + dune exec -- ./stress/stress_release.exe + +docker: + docker build -t eio . diff --git a/bench.Dockerfile b/bench.Dockerfile index a6bf055bb..2a1f63cd3 100644 --- a/bench.Dockerfile +++ b/bench.Dockerfile @@ -1,14 +1,14 @@ -FROM ocaml/opam:debian-11-ocaml-5.2 -# Make sure we're using opam-2.1: -RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam -# Ensure opam-repository is up-to-date: -RUN cd opam-repository && git pull -q origin 97de3378749cf8d2d70a5d710d310e5cc17c9dea && opam update -# Install Eio's dependencies (adding just the opam files first to help with caching): -RUN mkdir eio -WORKDIR eio -COPY *.opam ./ -RUN opam pin --with-version=dev . -yn -RUN opam install eio_main yojson -# Build the benchmarks: -COPY . ./ -RUN opam exec -- dune build ./bench +FROM ocaml/opam:debian-11-ocaml-5.2 +# Make sure we're using opam-2.1: +RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam +# Ensure opam-repository is up-to-date: +RUN cd opam-repository && git pull -q origin 97de3378749cf8d2d70a5d710d310e5cc17c9dea && opam update +# Install Eio's dependencies (adding just the opam files first to help with caching): +RUN mkdir eio +WORKDIR eio +COPY *.opam ./ +RUN opam pin --with-version=dev . -yn +RUN opam install eio_main yojson +# Build the benchmarks: +COPY . ./ +RUN opam exec -- dune build ./bench diff --git a/bench/bench_buf_read.ml b/bench/bench_buf_read.ml index 5ab32f919..ef16cb7a5 100644 --- a/bench/bench_buf_read.ml +++ b/bench/bench_buf_read.ml @@ -1,18 +1,18 @@ -module R = Eio.Buf_read - -let run _env = - let test_data = String.make 100_000_000 'x' in - let r = R.of_string test_data in - let t0 = Unix.gettimeofday () in - let i = ref 0 in - try - while true do - assert (R.any_char r = 'x'); - incr i - done; - assert false - with End_of_file -> - let t1 = Unix.gettimeofday () in - let time = t1 -. t0 in - let bytes_per_second = float (String.length test_data) /. time in - [Metric.create "any_char" (`Float bytes_per_second) "bytes/s" "Parsing a long string one character at a time"] +module R = Eio.Buf_read + +let run _env = + let test_data = String.make 100_000_000 'x' in + let r = R.of_string test_data in + let t0 = Unix.gettimeofday () in + let i = ref 0 in + try + while true do + assert (R.any_char r = 'x'); + incr i + done; + assert false + with End_of_file -> + let t1 = Unix.gettimeofday () in + let time = t1 -. t0 in + let bytes_per_second = float (String.length test_data) /. time in + [Metric.create "any_char" (`Float bytes_per_second) "bytes/s" "Parsing a long string one character at a time"] diff --git a/bench/bench_cancel.ml b/bench/bench_cancel.ml index 064a5712a..43137f32f 100644 --- a/bench/bench_cancel.ml +++ b/bench/bench_cancel.ml @@ -1,59 +1,59 @@ -open Eio.Std - -(* The main domain spawns two other domains, connected to each by a stream. - It keeps reading from whichever stream is ready first, cancelling the other read. - This tests the time needed to set up and tear down cancellation contexts and - tests that cancellation can happen in parallel with success. *) - -let n_iters = 100_000 - -let run_sender stream = - for i = 1 to n_iters do - Eio.Stream.add stream i - done - -let run_bench ?domain_mgr ~clock () = - let stream1 = Eio.Stream.create 1 in - let stream2 = Eio.Stream.create 1 in - let run_sender stream () = - match domain_mgr with - | Some dm -> Eio.Domain_manager.run dm (fun () -> run_sender stream) - | None -> run_sender stream - in - let name str = - match domain_mgr with - | Some _ -> str ^ "/separate domains" - | None -> str ^ "/single domain" - in - Gc.full_major (); - let t0 = Eio.Time.now clock in - try - Switch.run (fun sw -> - Fiber.fork ~sw (run_sender stream1); - Fiber.fork ~sw (run_sender stream2); - for _ = 1 to n_iters do - ignore @@ - Fiber.first - (fun () -> Eio.Stream.take stream1) - (fun () -> Eio.Stream.take stream2) - done; - raise Exit - ) - with Exit -> - let t1 = Eio.Time.now clock in - let time_total = t1 -. t0 in - let time_per_iter = time_total /. float n_iters in - Metric.create - (name "take-first") - (`Float (1e9 *. time_per_iter)) "ns" - "Time to take from one of two streams" - -let main ~domain_mgr ~clock = - let m1 = run_bench ~clock () in - let m2 = run_bench ~domain_mgr ~clock () in - [m1; m2] - -let run env = - main - ~domain_mgr:(Eio.Stdenv.domain_mgr env) - ~clock:(Eio.Stdenv.clock env) +open Eio.Std + +(* The main domain spawns two other domains, connected to each by a stream. + It keeps reading from whichever stream is ready first, cancelling the other read. + This tests the time needed to set up and tear down cancellation contexts and + tests that cancellation can happen in parallel with success. *) + +let n_iters = 100_000 + +let run_sender stream = + for i = 1 to n_iters do + Eio.Stream.add stream i + done + +let run_bench ?domain_mgr ~clock () = + let stream1 = Eio.Stream.create 1 in + let stream2 = Eio.Stream.create 1 in + let run_sender stream () = + match domain_mgr with + | Some dm -> Eio.Domain_manager.run dm (fun () -> run_sender stream) + | None -> run_sender stream + in + let name str = + match domain_mgr with + | Some _ -> str ^ "/separate domains" + | None -> str ^ "/single domain" + in + Gc.full_major (); + let t0 = Eio.Time.now clock in + try + Switch.run (fun sw -> + Fiber.fork ~sw (run_sender stream1); + Fiber.fork ~sw (run_sender stream2); + for _ = 1 to n_iters do + ignore @@ + Fiber.first + (fun () -> Eio.Stream.take stream1) + (fun () -> Eio.Stream.take stream2) + done; + raise Exit + ) + with Exit -> + let t1 = Eio.Time.now clock in + let time_total = t1 -. t0 in + let time_per_iter = time_total /. float n_iters in + Metric.create + (name "take-first") + (`Float (1e9 *. time_per_iter)) "ns" + "Time to take from one of two streams" + +let main ~domain_mgr ~clock = + let m1 = run_bench ~clock () in + let m2 = run_bench ~domain_mgr ~clock () in + [m1; m2] + +let run env = + main + ~domain_mgr:(Eio.Stdenv.domain_mgr env) + ~clock:(Eio.Stdenv.clock env) diff --git a/bench/bench_condition.ml b/bench/bench_condition.ml index 927dd64ff..f6bab5829 100644 --- a/bench/bench_condition.ml +++ b/bench/bench_condition.ml @@ -1,65 +1,65 @@ -open Eio.Std - -(* A publisher keeps updating a counter and signalling a condition. - Two consumers read the counter whenever they get a signal. - The producer stops after signalling [target], and the consumers stop after seeing it. *) - -let n_iters = 100 -let target = 100000 - -let run_publisher cond v = - for i = 1 to target do - Atomic.set v i; - (* traceln "set %d" i; *) - Eio.Condition.broadcast cond - done - -let run_consumer cond v = - try - while true do - Fiber.both - (fun () -> Eio.Condition.await_no_mutex cond) - (fun () -> - let current = Atomic.get v in - (* traceln "saw %d" current; *) - if current = target then raise Exit - ) - done - with Exit -> () - -let run_bench ?domain_mgr ~clock () = - let cond = Eio.Condition.create () in - let v = Atomic.make 0 in - let run_consumer () = - match domain_mgr with - | Some dm -> Eio.Domain_manager.run dm (fun () -> run_consumer cond v) - | None -> run_consumer cond v - in - let name str = - match domain_mgr with - | Some _ -> str ^ "_domain" - | None -> str - in - Gc.full_major (); - let t0 = Eio.Time.now clock in - for _ = 1 to n_iters do - Fiber.all [ - run_consumer; - run_consumer; - (fun () -> run_publisher cond v); - ]; - done; - let t1 = Eio.Time.now clock in - let time_total = t1 -. t0 in - let time_per_iter = time_total /. float n_iters in - Metric.create (name "broadcast") (`Float (1e3 *. time_per_iter)) "ms" "Time to signal a new value" - -let main ~domain_mgr ~clock = [ - run_bench ~clock (); - run_bench ~domain_mgr ~clock (); -] - -let run env = - main - ~domain_mgr:(Eio.Stdenv.domain_mgr env) - ~clock:(Eio.Stdenv.clock env) +open Eio.Std + +(* A publisher keeps updating a counter and signalling a condition. + Two consumers read the counter whenever they get a signal. + The producer stops after signalling [target], and the consumers stop after seeing it. *) + +let n_iters = 100 +let target = 100000 + +let run_publisher cond v = + for i = 1 to target do + Atomic.set v i; + (* traceln "set %d" i; *) + Eio.Condition.broadcast cond + done + +let run_consumer cond v = + try + while true do + Fiber.both + (fun () -> Eio.Condition.await_no_mutex cond) + (fun () -> + let current = Atomic.get v in + (* traceln "saw %d" current; *) + if current = target then raise Exit + ) + done + with Exit -> () + +let run_bench ?domain_mgr ~clock () = + let cond = Eio.Condition.create () in + let v = Atomic.make 0 in + let run_consumer () = + match domain_mgr with + | Some dm -> Eio.Domain_manager.run dm (fun () -> run_consumer cond v) + | None -> run_consumer cond v + in + let name str = + match domain_mgr with + | Some _ -> str ^ "_domain" + | None -> str + in + Gc.full_major (); + let t0 = Eio.Time.now clock in + for _ = 1 to n_iters do + Fiber.all [ + run_consumer; + run_consumer; + (fun () -> run_publisher cond v); + ]; + done; + let t1 = Eio.Time.now clock in + let time_total = t1 -. t0 in + let time_per_iter = time_total /. float n_iters in + Metric.create (name "broadcast") (`Float (1e3 *. time_per_iter)) "ms" "Time to signal a new value" + +let main ~domain_mgr ~clock = [ + run_bench ~clock (); + run_bench ~domain_mgr ~clock (); +] + +let run env = + main + ~domain_mgr:(Eio.Stdenv.domain_mgr env) + ~clock:(Eio.Stdenv.clock env) diff --git a/bench/bench_copy.ml b/bench/bench_copy.ml index 0249bf6e8..091103246 100644 --- a/bench/bench_copy.ml +++ b/bench/bench_copy.ml @@ -1,44 +1,44 @@ -(* A client opens a connection to an echo service and sends a load of data via it. *) - -open Eio.Std - -let chunk_size = 1 lsl 16 -let n_chunks = 10000 -let n_bytes = n_chunks * chunk_size - -let run_client sock = - Fiber.both - (fun () -> - let chunk = Cstruct.create chunk_size in - for _ = 1 to n_chunks do - Eio.Flow.write sock [chunk] - done; - Eio.Flow.shutdown sock `Send - ) - (fun () -> - let chunk = Cstruct.create chunk_size in - for _ = 1 to n_chunks do - Eio.Flow.read_exact sock chunk - done - ) - -let time name service = - Switch.run ~name @@ fun sw -> - let client_sock, server_sock = Eio_unix.Net.socketpair_stream ~sw () in - let t0 = Unix.gettimeofday () in - Fiber.both - (fun () -> service server_sock) - (fun () -> run_client client_sock); - let t1 = Unix.gettimeofday () in - let time = t1 -. t0 in - let bytes_per_second = float n_bytes /. time in - traceln "%s: %.2f MB/s" name (bytes_per_second /. 1024. /. 1024.); - Metric.create name (`Float bytes_per_second) "bytes/s" (name ^ " Flow.copy") - -let run _env = - [ - time "default" (fun sock -> Eio.Flow.copy sock sock); - time "buf_read" (fun sock -> - let r = Eio.Buf_read.of_flow sock ~initial_size:(64 * 1024) ~max_size:(64 * 1024) |> Eio.Buf_read.as_flow in - Eio.Flow.copy r sock); - ] +(* A client opens a connection to an echo service and sends a load of data via it. *) + +open Eio.Std + +let chunk_size = 1 lsl 16 +let n_chunks = 10000 +let n_bytes = n_chunks * chunk_size + +let run_client sock = + Fiber.both + (fun () -> + let chunk = Cstruct.create chunk_size in + for _ = 1 to n_chunks do + Eio.Flow.write sock [chunk] + done; + Eio.Flow.shutdown sock `Send + ) + (fun () -> + let chunk = Cstruct.create chunk_size in + for _ = 1 to n_chunks do + Eio.Flow.read_exact sock chunk + done + ) + +let time name service = + Switch.run ~name @@ fun sw -> + let client_sock, server_sock = Eio_unix.Net.socketpair_stream ~sw () in + let t0 = Unix.gettimeofday () in + Fiber.both + (fun () -> service server_sock) + (fun () -> run_client client_sock); + let t1 = Unix.gettimeofday () in + let time = t1 -. t0 in + let bytes_per_second = float n_bytes /. time in + traceln "%s: %.2f MB/s" name (bytes_per_second /. 1024. /. 1024.); + Metric.create name (`Float bytes_per_second) "bytes/s" (name ^ " Flow.copy") + +let run _env = + [ + time "default" (fun sock -> Eio.Flow.copy sock sock); + time "buf_read" (fun sock -> + let r = Eio.Buf_read.of_flow sock ~initial_size:(64 * 1024) ~max_size:(64 * 1024) |> Eio.Buf_read.as_flow in + Eio.Flow.copy r sock); + ] diff --git a/bench/bench_fd.ml b/bench/bench_fd.ml index f7d8e1b50..94f6d4448 100644 --- a/bench/bench_fd.ml +++ b/bench/bench_fd.ml @@ -1,38 +1,38 @@ -open Eio.Std - -let time label len fn = - let t0 = Unix.gettimeofday () in - fn (); - let t1 = Unix.gettimeofday () in - Metric.create - label - (`Float (float len /. (t1 -. t0) /. (2. ** 30.))) "GB/s" - "Reading from /dev/zero using a single FD" - -let main ~domain_mgr zero = - let iters = 100_000 in - let len = 64 * 1024 in - let n_fibers = 4 in - let n_domains = 4 in - let buf = Cstruct.create len in - let run1 () = - for _ = 1 to iters do Eio.Flow.read_exact zero buf done - in - [time "fibers:1" (iters * len) run1; - time (Fmt.str "fibers:%d" n_fibers) (iters * n_fibers * len) (fun () -> - Switch.run @@ fun sw -> - for _ = 1 to n_fibers do - Fiber.fork ~sw run1 - done - ); - time (Fmt.str "domains:%d" n_domains) (iters * n_domains * len) (fun () -> - Switch.run @@ fun sw -> - for _ = 1 to n_domains do - Fiber.fork ~sw (fun () -> Eio.Domain_manager.run domain_mgr run1) - done - )] - -let ( / ) = Eio.Path.( / ) - -let run env = - Eio.Path.with_open_in (env#fs / "/dev/zero") (main ~domain_mgr:env#domain_mgr) +open Eio.Std + +let time label len fn = + let t0 = Unix.gettimeofday () in + fn (); + let t1 = Unix.gettimeofday () in + Metric.create + label + (`Float (float len /. (t1 -. t0) /. (2. ** 30.))) "GB/s" + "Reading from /dev/zero using a single FD" + +let main ~domain_mgr zero = + let iters = 100_000 in + let len = 64 * 1024 in + let n_fibers = 4 in + let n_domains = 4 in + let buf = Cstruct.create len in + let run1 () = + for _ = 1 to iters do Eio.Flow.read_exact zero buf done + in + [time "fibers:1" (iters * len) run1; + time (Fmt.str "fibers:%d" n_fibers) (iters * n_fibers * len) (fun () -> + Switch.run @@ fun sw -> + for _ = 1 to n_fibers do + Fiber.fork ~sw run1 + done + ); + time (Fmt.str "domains:%d" n_domains) (iters * n_domains * len) (fun () -> + Switch.run @@ fun sw -> + for _ = 1 to n_domains do + Fiber.fork ~sw (fun () -> Eio.Domain_manager.run domain_mgr run1) + done + )] + +let ( / ) = Eio.Path.( / ) + +let run env = + Eio.Path.with_open_in (env#fs / "/dev/zero") (main ~domain_mgr:env#domain_mgr) diff --git a/bench/bench_fstat.ml b/bench/bench_fstat.ml index ba51dea7d..541b2eb4d 100644 --- a/bench/bench_fstat.ml +++ b/bench/bench_fstat.ml @@ -1,26 +1,26 @@ -open Eio.Std - -let ( / ) = Eio.Path.( / ) - -let n_stat = 100000 - -let run_fiber file = - for _ = 1 to n_stat do - let info = (Eio.File.stat file).kind in - assert (info = `Regular_file) - done - -let run env = - Eio.Path.with_open_out ~create:(`If_missing 0o600) (env#cwd / "test-stat") @@ fun file -> - [1; 10] |> List.map (fun par -> - let t0 = Unix.gettimeofday () in - Switch.run (fun sw -> - for _ = 1 to par do - Fiber.fork ~sw (fun () -> run_fiber file) - done - ); - let t1 = Unix.gettimeofday () in - let stat_per_s = float (n_stat * par) /. (t1 -. t0) in - let label = Printf.sprintf "n=%d fibers=%d" n_stat par in - Metric.create label (`Float stat_per_s) "stat/s" "Call fstat on an open file" - ) +open Eio.Std + +let ( / ) = Eio.Path.( / ) + +let n_stat = 100000 + +let run_fiber file = + for _ = 1 to n_stat do + let info = (Eio.File.stat file).kind in + assert (info = `Regular_file) + done + +let run env = + Eio.Path.with_open_out ~create:(`If_missing 0o600) (env#cwd / "test-stat") @@ fun file -> + [1; 10] |> List.map (fun par -> + let t0 = Unix.gettimeofday () in + Switch.run (fun sw -> + for _ = 1 to par do + Fiber.fork ~sw (fun () -> run_fiber file) + done + ); + let t1 = Unix.gettimeofday () in + let stat_per_s = float (n_stat * par) /. (t1 -. t0) in + let label = Printf.sprintf "n=%d fibers=%d" n_stat par in + Metric.create label (`Float stat_per_s) "stat/s" "Call fstat on an open file" + ) diff --git a/bench/bench_http.ml b/bench/bench_http.ml index 7c4dfb91e..f94942e51 100644 --- a/bench/bench_http.ml +++ b/bench/bench_http.ml @@ -1,107 +1,107 @@ -(* A multi-domain server handles HTTP-like requests from many clients running across multiple domains. *) - -open Eio.Std - -(* Note: this is not a real HTTP parser! *) -let key_char = function - | 'A'..'Z' | 'a'..'z' | '-' -> true - | _ -> false - -let parse_headers r = - let len = ref (-1) in - let rec aux () = - let key = Eio.Buf_read.take_while key_char r in - if key = "" then Eio.Buf_read.string "\r\n" r - else ( - Eio.Buf_read.char ':' r; - let value = Eio.Buf_read.line r in - if key = "Content-Length" then len := int_of_string (String.trim value); - aux () - ) - in - aux (); - !len - -let handle_connection conn _addr = - Eio.Buf_write.with_flow conn @@ fun w -> - let rec requests r = - let _req = Eio.Buf_read.line r in - let len = parse_headers r in - let body = Eio.Buf_read.take len r in - let response = body ^ " / received" in - Eio.Buf_write.string w "HTTP/1.1 200 OK\r\n"; - Eio.Buf_write.string w (Printf.sprintf "Content-Length: %d\r\n" (String.length response)); - Eio.Buf_write.string w "\r\n"; - Eio.Buf_write.string w response; - if not (Eio.Buf_read.at_end_of_input r) then requests r - in - Eio.Buf_read.parse_exn requests conn ~max_size:max_int - -let run_client ~n_requests id conn = - let total = ref 0 in - let r = Eio.Buf_read.of_flow conn ~max_size:max_int in - Eio.Buf_write.with_flow conn @@ fun w -> - for i = 1 to n_requests do - let msg = Printf.sprintf "%s / request %d" id i in - Eio.Buf_write.string w "POST / HTTP/1.1\r\n"; - Eio.Buf_write.string w "Host: localhost:8085\r\n"; - Eio.Buf_write.string w "User-Agent: bench_server\r\n"; - Eio.Buf_write.string w "Connection: keep-alive\r\n"; - Eio.Buf_write.string w (Printf.sprintf "Content-Length: %d\r\n" (String.length msg)); - Eio.Buf_write.string w "\r\n"; - Eio.Buf_write.string w msg; - let status = Eio.Buf_read.line r in - assert (status = "HTTP/1.1 200 OK"); - let len = parse_headers r in - let body = Eio.Buf_read.take len r in - assert (body = msg ^ " / received"); - incr total - done; - !total - -let main net domain_mgr ~n_client_domains ~n_server_domains ~n_connections_per_domain ~n_requests_per_connection = - let total = Atomic.make 0 in - let t0 = Unix.gettimeofday () in - Switch.run ~name:"main" (fun sw -> - let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8085) in - let backlog = n_connections_per_domain * n_client_domains in - let server_socket = Eio.Net.listen ~reuse_addr:true ~backlog ~sw net addr in - Fiber.fork_daemon ~sw (fun () -> - Eio.Net.run_server server_socket handle_connection - ~additional_domains:(domain_mgr, n_server_domains - 1) - ~on_error:raise - ); - for domain = 1 to n_client_domains do - Fiber.fork ~sw (fun () -> - Eio.Domain_manager.run domain_mgr (fun () -> - Switch.run ~name:"client-domain" @@ fun sw -> - for i = 1 to n_connections_per_domain do - Fiber.fork ~sw (fun () -> - let id = Printf.sprintf "domain %d / conn %d" domain i in - let conn = Eio.Net.connect ~sw net addr in - let requests = run_client ~n_requests:n_requests_per_connection id conn in - ignore (Atomic.fetch_and_add total requests : int) - ) - done - ) - ) - done - ); - let t1 = Unix.gettimeofday () in - (* Fmt.pr "clients, servers, requests, requests/s@."; *) - let requests = n_connections_per_domain * n_client_domains * n_requests_per_connection in - assert (requests = Atomic.get total); - let req_per_s = float requests /. (t1 -. t0) in - Metric.create - (Printf.sprintf "requests:%d client-domains:%d server-domains:%d" requests n_client_domains n_server_domains) - (`Float req_per_s) "requests/s" "Request rate of a HTTP client/server system" - -let run env = - let metrics = - main env#net env#domain_mgr - ~n_client_domains:4 - ~n_server_domains:4 - ~n_connections_per_domain:25 - ~n_requests_per_connection:1000 - in - [metrics] +(* A multi-domain server handles HTTP-like requests from many clients running across multiple domains. *) + +open Eio.Std + +(* Note: this is not a real HTTP parser! *) +let key_char = function + | 'A'..'Z' | 'a'..'z' | '-' -> true + | _ -> false + +let parse_headers r = + let len = ref (-1) in + let rec aux () = + let key = Eio.Buf_read.take_while key_char r in + if key = "" then Eio.Buf_read.string "\r\n" r + else ( + Eio.Buf_read.char ':' r; + let value = Eio.Buf_read.line r in + if key = "Content-Length" then len := int_of_string (String.trim value); + aux () + ) + in + aux (); + !len + +let handle_connection conn _addr = + Eio.Buf_write.with_flow conn @@ fun w -> + let rec requests r = + let _req = Eio.Buf_read.line r in + let len = parse_headers r in + let body = Eio.Buf_read.take len r in + let response = body ^ " / received" in + Eio.Buf_write.string w "HTTP/1.1 200 OK\r\n"; + Eio.Buf_write.string w (Printf.sprintf "Content-Length: %d\r\n" (String.length response)); + Eio.Buf_write.string w "\r\n"; + Eio.Buf_write.string w response; + if not (Eio.Buf_read.at_end_of_input r) then requests r + in + Eio.Buf_read.parse_exn requests conn ~max_size:max_int + +let run_client ~n_requests id conn = + let total = ref 0 in + let r = Eio.Buf_read.of_flow conn ~max_size:max_int in + Eio.Buf_write.with_flow conn @@ fun w -> + for i = 1 to n_requests do + let msg = Printf.sprintf "%s / request %d" id i in + Eio.Buf_write.string w "POST / HTTP/1.1\r\n"; + Eio.Buf_write.string w "Host: localhost:8085\r\n"; + Eio.Buf_write.string w "User-Agent: bench_server\r\n"; + Eio.Buf_write.string w "Connection: keep-alive\r\n"; + Eio.Buf_write.string w (Printf.sprintf "Content-Length: %d\r\n" (String.length msg)); + Eio.Buf_write.string w "\r\n"; + Eio.Buf_write.string w msg; + let status = Eio.Buf_read.line r in + assert (status = "HTTP/1.1 200 OK"); + let len = parse_headers r in + let body = Eio.Buf_read.take len r in + assert (body = msg ^ " / received"); + incr total + done; + !total + +let main net domain_mgr ~n_client_domains ~n_server_domains ~n_connections_per_domain ~n_requests_per_connection = + let total = Atomic.make 0 in + let t0 = Unix.gettimeofday () in + Switch.run ~name:"main" (fun sw -> + let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8085) in + let backlog = n_connections_per_domain * n_client_domains in + let server_socket = Eio.Net.listen ~reuse_addr:true ~backlog ~sw net addr in + Fiber.fork_daemon ~sw (fun () -> + Eio.Net.run_server server_socket handle_connection + ~additional_domains:(domain_mgr, n_server_domains - 1) + ~on_error:raise + ); + for domain = 1 to n_client_domains do + Fiber.fork ~sw (fun () -> + Eio.Domain_manager.run domain_mgr (fun () -> + Switch.run ~name:"client-domain" @@ fun sw -> + for i = 1 to n_connections_per_domain do + Fiber.fork ~sw (fun () -> + let id = Printf.sprintf "domain %d / conn %d" domain i in + let conn = Eio.Net.connect ~sw net addr in + let requests = run_client ~n_requests:n_requests_per_connection id conn in + ignore (Atomic.fetch_and_add total requests : int) + ) + done + ) + ) + done + ); + let t1 = Unix.gettimeofday () in + (* Fmt.pr "clients, servers, requests, requests/s@."; *) + let requests = n_connections_per_domain * n_client_domains * n_requests_per_connection in + assert (requests = Atomic.get total); + let req_per_s = float requests /. (t1 -. t0) in + Metric.create + (Printf.sprintf "requests:%d client-domains:%d server-domains:%d" requests n_client_domains n_server_domains) + (`Float req_per_s) "requests/s" "Request rate of a HTTP client/server system" + +let run env = + let metrics = + main env#net env#domain_mgr + ~n_client_domains:4 + ~n_server_domains:4 + ~n_connections_per_domain:25 + ~n_requests_per_connection:1000 + in + [metrics] diff --git a/bench/bench_mutex.ml b/bench/bench_mutex.ml index b3ae81578..2ff225656 100644 --- a/bench/bench_mutex.ml +++ b/bench/bench_mutex.ml @@ -1,54 +1,54 @@ -open Eio.Std - -let v = ref 0 - -let run_worker ~iters_per_thread mutex = - for _ = 1 to iters_per_thread do - Eio.Mutex.lock mutex; - let x = !v in - v := x + 1; - Fiber.yield (); - assert (!v = x + 1); - v := x; - Eio.Mutex.unlock mutex; - done - -let run_bench ~domain_mgr ~clock ~use_domains ~iters_per_thread ~threads = - let mutex = Eio.Mutex.create () in - Gc.full_major (); - let t0 = Eio.Time.now clock in - Switch.run (fun sw -> - for _ = 1 to threads do - Fiber.fork ~sw (fun () -> - if use_domains then ( - Eio.Domain_manager.run domain_mgr @@ fun () -> - run_worker ~iters_per_thread mutex - ) else ( - run_worker ~iters_per_thread mutex - ) - ) - done - ); - assert (!v = 0); - let t1 = Eio.Time.now clock in - let time_total = t1 -. t0 in - let n_iters = iters_per_thread * threads in - let time_per_iter = time_total /. float n_iters in - Metric.create - (Printf.sprintf "iterations=%d threads=%d" n_iters threads) - (`Float (1e9 *. time_per_iter)) "ns" "Time to update a shared counter" - -let main ~domain_mgr ~clock = - [false, 1_000_000, 1; - false, 1_000_000, 2; - false, 100_000, 8; - true, 100_000, 1; - true, 10_000, 2; - true, 10_000, 8] - |> List.map (fun (use_domains, iters_per_thread, threads) -> - run_bench ~domain_mgr ~clock ~use_domains ~iters_per_thread ~threads) - -let run env = - main - ~domain_mgr:(Eio.Stdenv.domain_mgr env) - ~clock:(Eio.Stdenv.clock env) +open Eio.Std + +let v = ref 0 + +let run_worker ~iters_per_thread mutex = + for _ = 1 to iters_per_thread do + Eio.Mutex.lock mutex; + let x = !v in + v := x + 1; + Fiber.yield (); + assert (!v = x + 1); + v := x; + Eio.Mutex.unlock mutex; + done + +let run_bench ~domain_mgr ~clock ~use_domains ~iters_per_thread ~threads = + let mutex = Eio.Mutex.create () in + Gc.full_major (); + let t0 = Eio.Time.now clock in + Switch.run (fun sw -> + for _ = 1 to threads do + Fiber.fork ~sw (fun () -> + if use_domains then ( + Eio.Domain_manager.run domain_mgr @@ fun () -> + run_worker ~iters_per_thread mutex + ) else ( + run_worker ~iters_per_thread mutex + ) + ) + done + ); + assert (!v = 0); + let t1 = Eio.Time.now clock in + let time_total = t1 -. t0 in + let n_iters = iters_per_thread * threads in + let time_per_iter = time_total /. float n_iters in + Metric.create + (Printf.sprintf "iterations=%d threads=%d" n_iters threads) + (`Float (1e9 *. time_per_iter)) "ns" "Time to update a shared counter" + +let main ~domain_mgr ~clock = + [false, 1_000_000, 1; + false, 1_000_000, 2; + false, 100_000, 8; + true, 100_000, 1; + true, 10_000, 2; + true, 10_000, 8] + |> List.map (fun (use_domains, iters_per_thread, threads) -> + run_bench ~domain_mgr ~clock ~use_domains ~iters_per_thread ~threads) + +let run env = + main + ~domain_mgr:(Eio.Stdenv.domain_mgr env) + ~clock:(Eio.Stdenv.clock env) diff --git a/bench/bench_promise.ml b/bench/bench_promise.ml index 43ca9220e..adf351595 100644 --- a/bench/bench_promise.ml +++ b/bench/bench_promise.ml @@ -1,108 +1,108 @@ -open Eio.Std - -type request = { - req_body : int; - response : response option Promise.u; -} -and response = { - resp_body : int; - next_request : request Promise.u; -} - -(* Simulate other work in the domain, and also prevent it from going to sleep. - Otherwise, we're just measuring how long it takes the OS to wake a sleeping thread. *) -let rec spin () = - Fiber.yield (); - spin () - -(* A client and server exchange these payload values. - Each contains the current message and a resolver which the other party can use to reply. *) - -let rec run_server ~n_iters ~i r = - (* Set up reply channel *) - let p2, r2 = Promise.create () in - (* Send i and next_request channel to client *) - Promise.resolve r (Some { resp_body = i; next_request = r2 }); - (* Await client's response, with new send channel *) - let { req_body; response } = Promise.await p2 in - assert (req_body = i); - if i < n_iters then - run_server ~n_iters ~i:(succ i) response - else - Promise.resolve response None - -let rec run_client ~n_iters ~i p = - (* Wait for message and reply channel from server *) - match Promise.await p with - | Some { resp_body; next_request } -> - assert (resp_body = i); - (* Create new channel for next message *) - let p2, r2 = Promise.create () in - (* Send reply message and new channel to the server *) - Promise.resolve next_request { req_body = i; response = r2 }; - run_client ~n_iters ~i:(succ i) p2 - | None -> - assert (i = n_iters + 1) - -let bench_resolved ~clock ~n_iters = - let t0 = Eio.Time.now clock in - let p = Promise.create_resolved 1 in - let t = ref 0 in - for _ = 1 to n_iters do - t := !t + Promise.await p; - done; - let t1 = Eio.Time.now clock in - assert (!t = n_iters); - Metric.create - "read-resolved" - (`Float (1e9 *. (t1 -. t0) /. float n_iters)) "ns" - "Time to read a resolved promise" - -let maybe_spin v fn = - if v then Fiber.first spin fn - else fn () - -let run_bench ~domain_mgr ~spin ~clock ~use_domains ~n_iters = - let init_p, init_r = Promise.create () in - Gc.full_major (); - let t0 = Eio.Time.now clock in - Fiber.both - (fun () -> - if use_domains then ( - Eio.Domain_manager.run domain_mgr @@ fun () -> - maybe_spin spin (fun () -> run_server ~n_iters ~i:0 init_r) - ) else ( - maybe_spin spin (fun () -> run_server ~n_iters ~i:0 init_r) - ) - ) - (fun () -> - maybe_spin spin (fun () -> run_client ~n_iters ~i:0 init_p) - ); - let t1 = Eio.Time.now clock in - let time_total = t1 -. t0 in - let time_per_iter = time_total /. float n_iters in - let domains_label = - if use_domains then - if spin then "with-spin" - else "without-spin" - else "no" - in - Metric.create - (Printf.sprintf "iterations:%d domains:%s" n_iters domains_label) - (`Float (1e9 *. time_per_iter)) "ns" - "Time to round-trip a request/reply" - -let main ~domain_mgr ~clock = - let resolved = bench_resolved ~clock ~n_iters:(10_000_000) in - let metrics = [false, false, 1_000_000; - true, true, 100_000; - true, false, 100_000] - |> List.map (fun (use_domains, spin, n_iters) -> - run_bench ~domain_mgr ~spin ~clock ~use_domains ~n_iters - ) in - resolved :: metrics - -let run env = - main - ~domain_mgr:(Eio.Stdenv.domain_mgr env) - ~clock:(Eio.Stdenv.clock env) +open Eio.Std + +type request = { + req_body : int; + response : response option Promise.u; +} +and response = { + resp_body : int; + next_request : request Promise.u; +} + +(* Simulate other work in the domain, and also prevent it from going to sleep. + Otherwise, we're just measuring how long it takes the OS to wake a sleeping thread. *) +let rec spin () = + Fiber.yield (); + spin () + +(* A client and server exchange these payload values. + Each contains the current message and a resolver which the other party can use to reply. *) + +let rec run_server ~n_iters ~i r = + (* Set up reply channel *) + let p2, r2 = Promise.create () in + (* Send i and next_request channel to client *) + Promise.resolve r (Some { resp_body = i; next_request = r2 }); + (* Await client's response, with new send channel *) + let { req_body; response } = Promise.await p2 in + assert (req_body = i); + if i < n_iters then + run_server ~n_iters ~i:(succ i) response + else + Promise.resolve response None + +let rec run_client ~n_iters ~i p = + (* Wait for message and reply channel from server *) + match Promise.await p with + | Some { resp_body; next_request } -> + assert (resp_body = i); + (* Create new channel for next message *) + let p2, r2 = Promise.create () in + (* Send reply message and new channel to the server *) + Promise.resolve next_request { req_body = i; response = r2 }; + run_client ~n_iters ~i:(succ i) p2 + | None -> + assert (i = n_iters + 1) + +let bench_resolved ~clock ~n_iters = + let t0 = Eio.Time.now clock in + let p = Promise.create_resolved 1 in + let t = ref 0 in + for _ = 1 to n_iters do + t := !t + Promise.await p; + done; + let t1 = Eio.Time.now clock in + assert (!t = n_iters); + Metric.create + "read-resolved" + (`Float (1e9 *. (t1 -. t0) /. float n_iters)) "ns" + "Time to read a resolved promise" + +let maybe_spin v fn = + if v then Fiber.first spin fn + else fn () + +let run_bench ~domain_mgr ~spin ~clock ~use_domains ~n_iters = + let init_p, init_r = Promise.create () in + Gc.full_major (); + let t0 = Eio.Time.now clock in + Fiber.both + (fun () -> + if use_domains then ( + Eio.Domain_manager.run domain_mgr @@ fun () -> + maybe_spin spin (fun () -> run_server ~n_iters ~i:0 init_r) + ) else ( + maybe_spin spin (fun () -> run_server ~n_iters ~i:0 init_r) + ) + ) + (fun () -> + maybe_spin spin (fun () -> run_client ~n_iters ~i:0 init_p) + ); + let t1 = Eio.Time.now clock in + let time_total = t1 -. t0 in + let time_per_iter = time_total /. float n_iters in + let domains_label = + if use_domains then + if spin then "with-spin" + else "without-spin" + else "no" + in + Metric.create + (Printf.sprintf "iterations:%d domains:%s" n_iters domains_label) + (`Float (1e9 *. time_per_iter)) "ns" + "Time to round-trip a request/reply" + +let main ~domain_mgr ~clock = + let resolved = bench_resolved ~clock ~n_iters:(10_000_000) in + let metrics = [false, false, 1_000_000; + true, true, 100_000; + true, false, 100_000] + |> List.map (fun (use_domains, spin, n_iters) -> + run_bench ~domain_mgr ~spin ~clock ~use_domains ~n_iters + ) in + resolved :: metrics + +let run env = + main + ~domain_mgr:(Eio.Stdenv.domain_mgr env) + ~clock:(Eio.Stdenv.clock env) diff --git a/bench/bench_semaphore.ml b/bench/bench_semaphore.ml index 06982b394..d2ca185f0 100644 --- a/bench/bench_semaphore.ml +++ b/bench/bench_semaphore.ml @@ -1,62 +1,62 @@ -open Eio.Std - -(* Simulate other work in the domain, and also prevent it from going to sleep. - Otherwise, we're just measuring how long it takes the OS to wake a sleeping thread. *) -let rec spin () = - Fiber.yield (); - spin () - -let run_bench ~domain_mgr ~clock ~use_domains ~n_iters ~n_resources = - let n_workers = 4 in - let sem = Eio.Semaphore.make n_resources in - let n_pending = Atomic.make n_workers in - let all_started, set_all_started = Promise.create () in - let t0 = ref 0.0 in - let run_worker ~n_iters sem = - Switch.run @@ fun sw -> - Fiber.fork_daemon ~sw spin; - if Atomic.fetch_and_add n_pending (-1) = 1 then ( - Promise.resolve set_all_started (); - t0 := Eio.Time.now clock; - ) else ( - Promise.await all_started - ); - for _ = 1 to n_iters do - Eio.Semaphore.acquire sem; - Fiber.yield (); - Eio.Semaphore.release sem - done - in - let run () = - if use_domains then ( - Eio.Domain_manager.run domain_mgr @@ fun () -> - run_worker ~n_iters sem - ) else ( - run_worker ~n_iters sem - ) - in - Gc.full_major (); - Fiber.all (List.init n_workers (Fun.const run)); - let t1 = Eio.Time.now clock in - let time_total = t1 -. !t0 in - let time_per_iter = time_total /. float n_iters in - Metric.create - (Printf.sprintf "iterations:%d resources:%d" n_iters n_resources) - (`Float (1e9 *. time_per_iter)) "ns" - "Time to acquire a semaphore, yeild, and release it" - -let main ~domain_mgr ~clock = - [false, 100_000, 2; - false, 100_000, 3; - false, 100_000, 4; - true, 10_000, 2; - true, 10_000, 3; - true, 10_000, 4] - |> List.map (fun (use_domains, n_iters, n_resources) -> - run_bench ~domain_mgr ~clock ~use_domains ~n_iters ~n_resources - ) - -let run env = - main - ~domain_mgr:(Eio.Stdenv.domain_mgr env) - ~clock:(Eio.Stdenv.clock env) +open Eio.Std + +(* Simulate other work in the domain, and also prevent it from going to sleep. + Otherwise, we're just measuring how long it takes the OS to wake a sleeping thread. *) +let rec spin () = + Fiber.yield (); + spin () + +let run_bench ~domain_mgr ~clock ~use_domains ~n_iters ~n_resources = + let n_workers = 4 in + let sem = Eio.Semaphore.make n_resources in + let n_pending = Atomic.make n_workers in + let all_started, set_all_started = Promise.create () in + let t0 = ref 0.0 in + let run_worker ~n_iters sem = + Switch.run @@ fun sw -> + Fiber.fork_daemon ~sw spin; + if Atomic.fetch_and_add n_pending (-1) = 1 then ( + Promise.resolve set_all_started (); + t0 := Eio.Time.now clock; + ) else ( + Promise.await all_started + ); + for _ = 1 to n_iters do + Eio.Semaphore.acquire sem; + Fiber.yield (); + Eio.Semaphore.release sem + done + in + let run () = + if use_domains then ( + Eio.Domain_manager.run domain_mgr @@ fun () -> + run_worker ~n_iters sem + ) else ( + run_worker ~n_iters sem + ) + in + Gc.full_major (); + Fiber.all (List.init n_workers (Fun.const run)); + let t1 = Eio.Time.now clock in + let time_total = t1 -. !t0 in + let time_per_iter = time_total /. float n_iters in + Metric.create + (Printf.sprintf "iterations:%d resources:%d" n_iters n_resources) + (`Float (1e9 *. time_per_iter)) "ns" + "Time to acquire a semaphore, yeild, and release it" + +let main ~domain_mgr ~clock = + [false, 100_000, 2; + false, 100_000, 3; + false, 100_000, 4; + true, 10_000, 2; + true, 10_000, 3; + true, 10_000, 4] + |> List.map (fun (use_domains, n_iters, n_resources) -> + run_bench ~domain_mgr ~clock ~use_domains ~n_iters ~n_resources + ) + +let run env = + main + ~domain_mgr:(Eio.Stdenv.domain_mgr env) + ~clock:(Eio.Stdenv.clock env) diff --git a/bench/bench_stat.ml b/bench/bench_stat.ml index 6eab360e6..2320b42c2 100644 --- a/bench/bench_stat.ml +++ b/bench/bench_stat.ml @@ -1,152 +1,152 @@ -open Eio.Std - -module Path = Eio.Path - -let () = Random.init 3 - -let ( / ) = Eio.Path.( / ) - -module Bench_dir = struct - type t = - | Dir of { name : string; perm : int; children : t list } - | File of { name : string; size : int64; perm : int; } - - let get_name = function Dir { name; _ } | File { name; _ } -> name - - let get_children = function - | Dir { children; _ } -> children - | File _ -> invalid_arg "Files don't have children" - - let compare a b = String.compare (get_name a) (get_name b) - - let rec sort = function - | Dir ({ children; _ } as v) -> - let c = List.map sort children in - let c = List.stable_sort compare c in - Dir { v with children = c } - | File _ as f -> f - - let rec size = function - | Dir { children; _ } -> - List.fold_left (fun acc v -> acc + size v) 0 children - | File _ -> 1 - - let rec pp ppf = function - | Dir { name; perm; children } -> - if children = [] then Fmt.pf ppf "dir %s (0o%o)" name perm else - Fmt.pf ppf "@[dir %s (0o%o)@ %a@]" name perm Fmt.(list ~sep:Fmt.cut pp) children - | File { name; size; perm } -> - Fmt.pf ppf "file %s (0o%o) %Lu" name perm size - - let make fs t = - let rec aux iter fs = function - | Dir { name; perm; children } -> - let dir = fs / name in - Path.mkdir ~perm dir; - iter (aux List.iter dir) children - | File { name; size; perm } -> - let buf = Cstruct.create (Int64.to_int size) in - Path.with_open_out ~create:(`If_missing perm) (fs / name) (fun oc -> - Eio.Flow.write oc [ buf ] - ) - in - aux Fiber.List.iter fs t -end - -let with_tmp_dir ~fs prefix suffix fn = - Switch.run @@ fun sw -> - let dir = fs / Filename.temp_dir prefix suffix in - Switch.on_release sw (fun () -> Path.rmtree dir); - fn dir - -let bench_stat root = - let rec aux level dir = - let { Eio.File.Stat.kind; perm; size; _ } = Path.stat ~follow:false dir in - match kind with - | `Directory -> - let items = Path.read_dir dir in - let map = if level > 3 then List.map else Fiber.List.map ?max_fibers:None in - let children = items |> map (fun f -> aux (level + 1) (dir / f)) in - let name = Path.native_exn dir |> Filename.basename in - Bench_dir.Dir { name; perm; children } - | `Regular_file -> - let name = Path.native_exn dir |> Filename.basename in - File { name; perm; size = Optint.Int63.to_int64 size } - | _ -> assert false - in - aux 1 root - -let file name = Bench_dir.File { name; perm = 0o644; size = 128L } -let dir name children = Bench_dir.Dir { name; perm = 0o700; children } - -let random_bench_dir ~n ~levels = - if levels < 1 then invalid_arg "Levels should be >= 1"; - let rec loop root = function - | 1 -> ( - match root with - | Bench_dir.Dir d -> - let leaf_files = List.init n (fun i -> file (Fmt.str "test-file-%i-%i" 1 i)) in - Bench_dir.Dir { d with children = leaf_files } - | _ -> failwith "Root is always expected to be a directory" - ) - | level -> - match root with - | Bench_dir.Dir d -> - let files = List.init n (fun i -> file (Fmt.str "test-file-%i-%i" level i)) in - let dirs = List.init n (fun i -> dir (Fmt.str "test-dir-%i-%i" level i) []) in - let dirs = List.map (fun dir -> loop dir (level - 1)) dirs in - Bench_dir.Dir { d with children = dirs @ files } - | _ -> failwith "Root is always expected to be directory" - in - loop (dir "root" []) levels - -let run_bench ~n ~levels ~root ~clock = - let dir = random_bench_dir ~levels ~n |> Bench_dir.sort in - traceln "Going to create %i files and directories" (Bench_dir.size dir); - let create_time = - let t0 = Eio.Time.now clock in - Bench_dir.make root dir; - let t1 = Eio.Time.now clock in - t1 -. t0 - in - traceln "Created in %.2f s" create_time; - let bench () = - Gc.full_major (); - let stat0 = Gc.stat () in - let t0 = Eio.Time.now clock in - let res = bench_stat root in - let t1 = Eio.Time.now clock in - let stat1 = Gc.stat () in - match Bench_dir.sort res with - | Dir { children = [ dir' ]; _ } -> - assert (dir = dir'); - let time_total = t1 -. t0 in - let minor_total = stat1.minor_words -. stat0.minor_words in - let major_total = stat1.major_words -. stat0.major_words in - time_total, minor_total, major_total - | _ -> failwith "Stat not the same as the spec" - in - let time, minor, major = bench () in - traceln "Statted in %.2f s" time; - let remove_time = - let t0 = Eio.Time.now clock in - let root = root / "root" in - Eio.Path.read_dir root |> Fiber.List.iter (fun item -> Eio.Path.rmtree (root / item)); - Eio.Path.rmdir root; - let t1 = Eio.Time.now clock in - t1 -. t0 - in - traceln "Removed in %.2f s" remove_time; - [ - Metric.create "create-time" (`Float (1e3 *. create_time)) "ms" (Fmt.str "Time to create %i files and directories" (Bench_dir.size dir)); - Metric.create "stat-time" (`Float (1e3 *. time)) "ms" (Fmt.str "Time to stat %i files and directories" (Bench_dir.size dir)); - Metric.create "stat-minor" (`Float (1e-3 *. minor)) "kwords" (Fmt.str "Minor words allocated to stat %i files and directories" (Bench_dir.size dir)); - Metric.create "stat-major" (`Float (1e-3 *. major)) "kwords" (Fmt.str "Major words allocated %i files and directories" (Bench_dir.size dir)); - Metric.create "remove-time" (`Float (1e3 *. remove_time)) "ms" "Time to remove everything"; - ] - -let run env = - let fs = Eio.Stdenv.fs env in - let clock = Eio.Stdenv.clock env in - with_tmp_dir ~fs "eio-bench-" "-stat" @@ fun root -> - run_bench ~n:20 ~levels:4 ~root ~clock +open Eio.Std + +module Path = Eio.Path + +let () = Random.init 3 + +let ( / ) = Eio.Path.( / ) + +module Bench_dir = struct + type t = + | Dir of { name : string; perm : int; children : t list } + | File of { name : string; size : int64; perm : int; } + + let get_name = function Dir { name; _ } | File { name; _ } -> name + + let get_children = function + | Dir { children; _ } -> children + | File _ -> invalid_arg "Files don't have children" + + let compare a b = String.compare (get_name a) (get_name b) + + let rec sort = function + | Dir ({ children; _ } as v) -> + let c = List.map sort children in + let c = List.stable_sort compare c in + Dir { v with children = c } + | File _ as f -> f + + let rec size = function + | Dir { children; _ } -> + List.fold_left (fun acc v -> acc + size v) 0 children + | File _ -> 1 + + let rec pp ppf = function + | Dir { name; perm; children } -> + if children = [] then Fmt.pf ppf "dir %s (0o%o)" name perm else + Fmt.pf ppf "@[dir %s (0o%o)@ %a@]" name perm Fmt.(list ~sep:Fmt.cut pp) children + | File { name; size; perm } -> + Fmt.pf ppf "file %s (0o%o) %Lu" name perm size + + let make fs t = + let rec aux iter fs = function + | Dir { name; perm; children } -> + let dir = fs / name in + Path.mkdir ~perm dir; + iter (aux List.iter dir) children + | File { name; size; perm } -> + let buf = Cstruct.create (Int64.to_int size) in + Path.with_open_out ~create:(`If_missing perm) (fs / name) (fun oc -> + Eio.Flow.write oc [ buf ] + ) + in + aux Fiber.List.iter fs t +end + +let with_tmp_dir ~fs prefix suffix fn = + Switch.run @@ fun sw -> + let dir = fs / Filename.temp_dir prefix suffix in + Switch.on_release sw (fun () -> Path.rmtree dir); + fn dir + +let bench_stat root = + let rec aux level dir = + let { Eio.File.Stat.kind; perm; size; _ } = Path.stat ~follow:false dir in + match kind with + | `Directory -> + let items = Path.read_dir dir in + let map = if level > 3 then List.map else Fiber.List.map ?max_fibers:None in + let children = items |> map (fun f -> aux (level + 1) (dir / f)) in + let name = Path.native_exn dir |> Filename.basename in + Bench_dir.Dir { name; perm; children } + | `Regular_file -> + let name = Path.native_exn dir |> Filename.basename in + File { name; perm; size = Optint.Int63.to_int64 size } + | _ -> assert false + in + aux 1 root + +let file name = Bench_dir.File { name; perm = 0o644; size = 128L } +let dir name children = Bench_dir.Dir { name; perm = 0o700; children } + +let random_bench_dir ~n ~levels = + if levels < 1 then invalid_arg "Levels should be >= 1"; + let rec loop root = function + | 1 -> ( + match root with + | Bench_dir.Dir d -> + let leaf_files = List.init n (fun i -> file (Fmt.str "test-file-%i-%i" 1 i)) in + Bench_dir.Dir { d with children = leaf_files } + | _ -> failwith "Root is always expected to be a directory" + ) + | level -> + match root with + | Bench_dir.Dir d -> + let files = List.init n (fun i -> file (Fmt.str "test-file-%i-%i" level i)) in + let dirs = List.init n (fun i -> dir (Fmt.str "test-dir-%i-%i" level i) []) in + let dirs = List.map (fun dir -> loop dir (level - 1)) dirs in + Bench_dir.Dir { d with children = dirs @ files } + | _ -> failwith "Root is always expected to be directory" + in + loop (dir "root" []) levels + +let run_bench ~n ~levels ~root ~clock = + let dir = random_bench_dir ~levels ~n |> Bench_dir.sort in + traceln "Going to create %i files and directories" (Bench_dir.size dir); + let create_time = + let t0 = Eio.Time.now clock in + Bench_dir.make root dir; + let t1 = Eio.Time.now clock in + t1 -. t0 + in + traceln "Created in %.2f s" create_time; + let bench () = + Gc.full_major (); + let stat0 = Gc.stat () in + let t0 = Eio.Time.now clock in + let res = bench_stat root in + let t1 = Eio.Time.now clock in + let stat1 = Gc.stat () in + match Bench_dir.sort res with + | Dir { children = [ dir' ]; _ } -> + assert (dir = dir'); + let time_total = t1 -. t0 in + let minor_total = stat1.minor_words -. stat0.minor_words in + let major_total = stat1.major_words -. stat0.major_words in + time_total, minor_total, major_total + | _ -> failwith "Stat not the same as the spec" + in + let time, minor, major = bench () in + traceln "Statted in %.2f s" time; + let remove_time = + let t0 = Eio.Time.now clock in + let root = root / "root" in + Eio.Path.read_dir root |> Fiber.List.iter (fun item -> Eio.Path.rmtree (root / item)); + Eio.Path.rmdir root; + let t1 = Eio.Time.now clock in + t1 -. t0 + in + traceln "Removed in %.2f s" remove_time; + [ + Metric.create "create-time" (`Float (1e3 *. create_time)) "ms" (Fmt.str "Time to create %i files and directories" (Bench_dir.size dir)); + Metric.create "stat-time" (`Float (1e3 *. time)) "ms" (Fmt.str "Time to stat %i files and directories" (Bench_dir.size dir)); + Metric.create "stat-minor" (`Float (1e-3 *. minor)) "kwords" (Fmt.str "Minor words allocated to stat %i files and directories" (Bench_dir.size dir)); + Metric.create "stat-major" (`Float (1e-3 *. major)) "kwords" (Fmt.str "Major words allocated %i files and directories" (Bench_dir.size dir)); + Metric.create "remove-time" (`Float (1e3 *. remove_time)) "ms" "Time to remove everything"; + ] + +let run env = + let fs = Eio.Stdenv.fs env in + let clock = Eio.Stdenv.clock env in + with_tmp_dir ~fs "eio-bench-" "-stat" @@ fun root -> + run_bench ~n:20 ~levels:4 ~root ~clock diff --git a/bench/bench_stream.ml b/bench/bench_stream.ml index a9a439e41..499201825 100644 --- a/bench/bench_stream.ml +++ b/bench/bench_stream.ml @@ -1,90 +1,90 @@ -(* Some sender domains each run a bunch of fibers submitting items to a stream. - Some receiver domains each run a single fiber accepting items from the stream. - It also tests the single-domain case. *) - -open Eio.Std - -let n_sender_fibers = 10 (* Concurrent sending fibers per sending domain *) - -(* Simulate other work in the domain, and also prevent it from going to sleep. - Otherwise, we're just measuring how long it takes the OS to wake a sleeping thread. *) -let rec spin () = - Fiber.yield (); - spin () - -(* [n_fibers] fibers each send values [1..n_iters] to [stream]. *) -let run_sender ~n_fibers ~n_iters stream = - Switch.run @@ fun sw -> - Fiber.fork_daemon ~sw spin; - for _ = 1 to n_fibers do - Fiber.fork ~sw (fun () -> - for i = 1 to n_iters do - Eio.Stream.add stream i - done - ) - done - -(* Read [n_iters] values from [stream] and add them to [total] (at the end). *) -let run_recv ~n_iters ~total stream = - Switch.run @@ fun sw -> - Fiber.fork_daemon ~sw spin; - let rec aux acc = function - | 0 -> acc - | i -> aux (acc + Eio.Stream.take stream) (i - 1) in - ignore (Atomic.fetch_and_add total (aux 0 n_iters) : int) - -(* Run the tests using [n_sender_domains] additional domains to send (0 to send - and receive in a single domain). When [n_sender_domains > 0], we also use - that many receiver domains. *) -let run_bench ~domain_mgr ~clock ~n_send_domains ~n_iters ~capacity = - let stream = Eio.Stream.create capacity in - let total = Atomic.make 0 in (* Total received (sanity check at the end) *) - let n_senders = max 1 n_send_domains in - let n_iters_total = (* Total number of items to be sent through [stream] *) - n_iters * n_sender_fibers * n_senders - in - Gc.full_major (); - let t0 = Eio.Time.now clock in - Switch.run (fun sw -> - let run_sender () = run_sender ~n_fibers:n_sender_fibers ~n_iters stream in - if n_send_domains > 0 then ( - for _ = 1 to n_send_domains do - Fiber.fork ~sw (fun () -> Eio.Domain_manager.run domain_mgr run_sender) - done - ) else ( - Fiber.fork ~sw run_sender - ); - let run_recv () = run_recv ~n_iters:(n_iters * n_sender_fibers) ~total stream in - for _ = 1 to n_senders - 1 do - Fiber.fork ~sw @@ fun () -> - Eio.Domain_manager.run domain_mgr run_recv - done; - Fiber.fork ~sw run_recv - ); - let t1 = Eio.Time.now clock in - let total = Atomic.get total in - let expected_total = n_senders * n_sender_fibers * (n_iters * (1 + n_iters) / 2) in - assert (total = expected_total); - let time_total = t1 -. t0 in - let time_per_iter = time_total /. float n_iters_total in - Metric.create - (Printf.sprintf "sender-domains:%d iterations:%d capacity:%d" n_send_domains n_iters capacity) - (`Float (1e9 *. time_per_iter)) "ns" - "Time to transmit one item over the stream" - -let main ~domain_mgr ~clock = - [0, 100_000; - 1, 100_000; - 2, 100_000; - 4, 100_000; - ] - |> List.concat_map (fun (n_send_domains, n_iters) -> - [0; 1; 100] |> List.map (fun capacity -> - run_bench ~domain_mgr ~clock ~n_send_domains ~n_iters ~capacity - ) - ) - -let run env = - main - ~domain_mgr:(Eio.Stdenv.domain_mgr env) - ~clock:(Eio.Stdenv.clock env) +(* Some sender domains each run a bunch of fibers submitting items to a stream. + Some receiver domains each run a single fiber accepting items from the stream. + It also tests the single-domain case. *) + +open Eio.Std + +let n_sender_fibers = 10 (* Concurrent sending fibers per sending domain *) + +(* Simulate other work in the domain, and also prevent it from going to sleep. + Otherwise, we're just measuring how long it takes the OS to wake a sleeping thread. *) +let rec spin () = + Fiber.yield (); + spin () + +(* [n_fibers] fibers each send values [1..n_iters] to [stream]. *) +let run_sender ~n_fibers ~n_iters stream = + Switch.run @@ fun sw -> + Fiber.fork_daemon ~sw spin; + for _ = 1 to n_fibers do + Fiber.fork ~sw (fun () -> + for i = 1 to n_iters do + Eio.Stream.add stream i + done + ) + done + +(* Read [n_iters] values from [stream] and add them to [total] (at the end). *) +let run_recv ~n_iters ~total stream = + Switch.run @@ fun sw -> + Fiber.fork_daemon ~sw spin; + let rec aux acc = function + | 0 -> acc + | i -> aux (acc + Eio.Stream.take stream) (i - 1) in + ignore (Atomic.fetch_and_add total (aux 0 n_iters) : int) + +(* Run the tests using [n_sender_domains] additional domains to send (0 to send + and receive in a single domain). When [n_sender_domains > 0], we also use + that many receiver domains. *) +let run_bench ~domain_mgr ~clock ~n_send_domains ~n_iters ~capacity = + let stream = Eio.Stream.create capacity in + let total = Atomic.make 0 in (* Total received (sanity check at the end) *) + let n_senders = max 1 n_send_domains in + let n_iters_total = (* Total number of items to be sent through [stream] *) + n_iters * n_sender_fibers * n_senders + in + Gc.full_major (); + let t0 = Eio.Time.now clock in + Switch.run (fun sw -> + let run_sender () = run_sender ~n_fibers:n_sender_fibers ~n_iters stream in + if n_send_domains > 0 then ( + for _ = 1 to n_send_domains do + Fiber.fork ~sw (fun () -> Eio.Domain_manager.run domain_mgr run_sender) + done + ) else ( + Fiber.fork ~sw run_sender + ); + let run_recv () = run_recv ~n_iters:(n_iters * n_sender_fibers) ~total stream in + for _ = 1 to n_senders - 1 do + Fiber.fork ~sw @@ fun () -> + Eio.Domain_manager.run domain_mgr run_recv + done; + Fiber.fork ~sw run_recv + ); + let t1 = Eio.Time.now clock in + let total = Atomic.get total in + let expected_total = n_senders * n_sender_fibers * (n_iters * (1 + n_iters) / 2) in + assert (total = expected_total); + let time_total = t1 -. t0 in + let time_per_iter = time_total /. float n_iters_total in + Metric.create + (Printf.sprintf "sender-domains:%d iterations:%d capacity:%d" n_send_domains n_iters capacity) + (`Float (1e9 *. time_per_iter)) "ns" + "Time to transmit one item over the stream" + +let main ~domain_mgr ~clock = + [0, 100_000; + 1, 100_000; + 2, 100_000; + 4, 100_000; + ] + |> List.concat_map (fun (n_send_domains, n_iters) -> + [0; 1; 100] |> List.map (fun capacity -> + run_bench ~domain_mgr ~clock ~n_send_domains ~n_iters ~capacity + ) + ) + +let run env = + main + ~domain_mgr:(Eio.Stdenv.domain_mgr env) + ~clock:(Eio.Stdenv.clock env) diff --git a/bench/bench_systhread.ml b/bench/bench_systhread.ml index 7b5dc2974..ee8a331e7 100644 --- a/bench/bench_systhread.ml +++ b/bench/bench_systhread.ml @@ -1,76 +1,76 @@ -(* Measure the overhead of [Eio_unix.run_in_systhread]. *) - -open Eio.Std - -let n_iters = 1000 - -let do_syscall () = ignore (Unix.getuid () : int) - -let work () = - for _ = 1 to n_iters do - Eio_unix.run_in_systhread do_syscall - done - -(* Return the average time for one call to [getuid]. *) -let run_domain ~fibers = - let t0 = Unix.gettimeofday () in - Switch.run ~name:"run_domain" (fun sw -> - for _ = 1 to fibers do - Fiber.fork ~sw work - done - ); - let t1 = Unix.gettimeofday () in - (t1 -. t0) /. float n_iters - -let time ~domain_mgr ~baseline ~domains ~fibers = - let overhead t = t /. baseline in - let name = Printf.sprintf "domains:%d fibers:%d" domains fibers in - (* Work-around for https://github.com/ocaml/ocaml/issues/12948 *) - let main_done, set_main_done = Promise.create () in - Switch.run ~name @@ fun sw -> - let times = - List.init (domains - 1) (fun _ -> - Fiber.fork_promise ~sw (fun () -> - Eio.Domain_manager.run domain_mgr (fun () -> - let r = run_domain ~fibers in - Promise.await main_done; - r - ) - ) - ) - in - let my_time = run_domain ~fibers in - Promise.resolve set_main_done (); (* Allow Domain.join to be called *) - let times = - my_time :: List.map Promise.await_exn times - |> List.map (fun t -> t *. 1e6) - in - traceln "%s" name; - times |> List.iteri (fun i t -> - traceln "%d: %.2f us (%.1f times slower)" i t (overhead t) - ); - let avg = (List.fold_left (+.) 0. times) /. float domains in - Metric.create name (`Float avg) "us" name - -let run env = - let domain_mgr = env#domain_mgr in - let baseline = - Eio.Private.Trace.with_span "baseline" @@ fun () -> - let t0 = Unix.gettimeofday () in - for _ = 1 to n_iters do - do_syscall () - done; - let t1 = Unix.gettimeofday () in - ((t1 -. t0) /. float n_iters) *. 1e6 - in - traceln "baseline (no systhreads): %.2f us" baseline; - let results = - [ - time ~domains:1 ~fibers:1; - time ~domains:1 ~fibers:2; - time ~domains:1 ~fibers:4; - time ~domains:4 ~fibers:1; - ] - |> List.map (fun f -> f ~domain_mgr ~baseline) - in - Metric.create "blocking" (`Float baseline) "us" "baseline" :: results +(* Measure the overhead of [Eio_unix.run_in_systhread]. *) + +open Eio.Std + +let n_iters = 1000 + +let do_syscall () = ignore (Unix.getuid () : int) + +let work () = + for _ = 1 to n_iters do + Eio_unix.run_in_systhread do_syscall + done + +(* Return the average time for one call to [getuid]. *) +let run_domain ~fibers = + let t0 = Unix.gettimeofday () in + Switch.run ~name:"run_domain" (fun sw -> + for _ = 1 to fibers do + Fiber.fork ~sw work + done + ); + let t1 = Unix.gettimeofday () in + (t1 -. t0) /. float n_iters + +let time ~domain_mgr ~baseline ~domains ~fibers = + let overhead t = t /. baseline in + let name = Printf.sprintf "domains:%d fibers:%d" domains fibers in + (* Work-around for https://github.com/ocaml/ocaml/issues/12948 *) + let main_done, set_main_done = Promise.create () in + Switch.run ~name @@ fun sw -> + let times = + List.init (domains - 1) (fun _ -> + Fiber.fork_promise ~sw (fun () -> + Eio.Domain_manager.run domain_mgr (fun () -> + let r = run_domain ~fibers in + Promise.await main_done; + r + ) + ) + ) + in + let my_time = run_domain ~fibers in + Promise.resolve set_main_done (); (* Allow Domain.join to be called *) + let times = + my_time :: List.map Promise.await_exn times + |> List.map (fun t -> t *. 1e6) + in + traceln "%s" name; + times |> List.iteri (fun i t -> + traceln "%d: %.2f us (%.1f times slower)" i t (overhead t) + ); + let avg = (List.fold_left (+.) 0. times) /. float domains in + Metric.create name (`Float avg) "us" name + +let run env = + let domain_mgr = env#domain_mgr in + let baseline = + Eio.Private.Trace.with_span "baseline" @@ fun () -> + let t0 = Unix.gettimeofday () in + for _ = 1 to n_iters do + do_syscall () + done; + let t1 = Unix.gettimeofday () in + ((t1 -. t0) /. float n_iters) *. 1e6 + in + traceln "baseline (no systhreads): %.2f us" baseline; + let results = + [ + time ~domains:1 ~fibers:1; + time ~domains:1 ~fibers:2; + time ~domains:1 ~fibers:4; + time ~domains:4 ~fibers:1; + ] + |> List.map (fun f -> f ~domain_mgr ~baseline) + in + Metric.create "blocking" (`Float baseline) "us" "baseline" :: results diff --git a/bench/bench_yield.ml b/bench/bench_yield.ml index 41b8513bd..dfeb8bc5c 100644 --- a/bench/bench_yield.ml +++ b/bench/bench_yield.ml @@ -1,29 +1,29 @@ -open Eio.Std - -let n_fibers = [1; 2; (* 3; 4; 5; 10; 20; 30; 40; 50; *) 100; 500; 1000; 10000] - -let main ~clock = - n_fibers |> List.map (fun n_fibers -> - let n_iters = 1000000 / n_fibers in - Gc.full_major (); - let t0 = Eio.Time.now clock in - Switch.run (fun sw -> - for _ = 1 to n_fibers do - Fiber.fork ~sw (fun () -> - for _ = 1 to n_iters do - Fiber.yield () - done - ) - done - ); - let t1 = Eio.Time.now clock in - let time_total = t1 -. t0 in - let n_total = n_fibers * n_iters in - let time_per_iter = time_total /. float n_total in - Metric.create - (Printf.sprintf "fibers:%d" n_fibers) - (`Float (1e9 *. time_per_iter)) "ns" "Time to yield" - ) - -let run env = - main ~clock:(Eio.Stdenv.clock env) +open Eio.Std + +let n_fibers = [1; 2; (* 3; 4; 5; 10; 20; 30; 40; 50; *) 100; 500; 1000; 10000] + +let main ~clock = + n_fibers |> List.map (fun n_fibers -> + let n_iters = 1000000 / n_fibers in + Gc.full_major (); + let t0 = Eio.Time.now clock in + Switch.run (fun sw -> + for _ = 1 to n_fibers do + Fiber.fork ~sw (fun () -> + for _ = 1 to n_iters do + Fiber.yield () + done + ) + done + ); + let t1 = Eio.Time.now clock in + let time_total = t1 -. t0 in + let n_total = n_fibers * n_iters in + let time_per_iter = time_total /. float n_total in + Metric.create + (Printf.sprintf "fibers:%d" n_fibers) + (`Float (1e9 *. time_per_iter)) "ns" "Time to yield" + ) + +let run env = + main ~clock:(Eio.Stdenv.clock env) diff --git a/bench/dune b/bench/dune index 558d2718d..0dd074e67 100644 --- a/bench/dune +++ b/bench/dune @@ -1,8 +1,8 @@ -; This should be an executable, but dune won't let us associate non-installed executables -; to packages, so we use this work-around. -(test - (name main) - (package eio_main) - (deps ./main.exe) - (action (progn)) ; Don't run as a test - (libraries eio_main yojson)) +; This should be an executable, but dune won't let us associate non-installed executables +; to packages, so we use this work-around. +(test + (name main) + (package eio_main) + (deps ./main.exe) + (action (progn)) ; Don't run as a test + (libraries eio_main yojson)) diff --git a/bench/main.ml b/bench/main.ml index e5319e7b2..d7040f7c2 100644 --- a/bench/main.ml +++ b/bench/main.ml @@ -1,63 +1,63 @@ -open Eio.Std - -let benchmarks = [ - "Promise", Bench_promise.run; - "Cancel", Bench_cancel.run; - "Buf_read", Bench_buf_read.run; - "Condition", Bench_condition.run; - "Fiber.yield", Bench_yield.run; - "Mutex", Bench_mutex.run; - "Semaphore", Bench_semaphore.run; - "Stream", Bench_stream.run; - "HTTP", Bench_http.run; - "Eio_unix.Fd", Bench_fd.run; - "File.stat", Bench_fstat.run; - "Path.stat", Bench_stat.run; - "Flow.copy", Bench_copy.run; - "Eio_unix.run_in_systhread", Bench_systhread.run; -] - -let usage_error () = - let names = List.map fst benchmarks in - Fmt.epr "Usage: main.exe [%a]@." Fmt.(list ~sep:(any " | ") string) names; - exit 1 - -let () = - Eio_main.run @@ fun env -> - traceln "Using %s backend" env#backend_id; - let benchmarks = - match Array.to_list Sys.argv with - | [_] -> benchmarks - | [_; name] -> - begin match List.assoc_opt name benchmarks with - | Some run -> [name, run] - | None -> - Fmt.epr "Unknown benchmark %S@." name; - usage_error () - end - | _ -> usage_error () - in - let run (name, fn) = - traceln "Running %s..." name; - let metrics = fn env in - `Assoc [ - "name", `String name; - "metrics", `List metrics; - ] - in - (* The benchmark machine runs an old Docker that blocks pidfd_open *) - (* let uname = Eio.Process.parse_out env#process_mgr Eio.Buf_read.take_all ["uname"; "-a"] in *) - let uname = - let ch = Unix.open_process_in "uname -a" in - let x = input_line ch in - close_in ch; - x - in - Fmt.pr "%a@." (Yojson.Safe.pretty_print ~std:true) @@ `Assoc [ - "config", `Assoc [ - "uname", `String uname; - "backend", `String env#backend_id; - "recommended_domain_count", `Int (Domain.recommended_domain_count ()); - ]; - "results", `List (List.map run benchmarks); - ] +open Eio.Std + +let benchmarks = [ + "Promise", Bench_promise.run; + "Cancel", Bench_cancel.run; + "Buf_read", Bench_buf_read.run; + "Condition", Bench_condition.run; + "Fiber.yield", Bench_yield.run; + "Mutex", Bench_mutex.run; + "Semaphore", Bench_semaphore.run; + "Stream", Bench_stream.run; + "HTTP", Bench_http.run; + "Eio_unix.Fd", Bench_fd.run; + "File.stat", Bench_fstat.run; + "Path.stat", Bench_stat.run; + "Flow.copy", Bench_copy.run; + "Eio_unix.run_in_systhread", Bench_systhread.run; +] + +let usage_error () = + let names = List.map fst benchmarks in + Fmt.epr "Usage: main.exe [%a]@." Fmt.(list ~sep:(any " | ") string) names; + exit 1 + +let () = + Eio_main.run @@ fun env -> + traceln "Using %s backend" env#backend_id; + let benchmarks = + match Array.to_list Sys.argv with + | [_] -> benchmarks + | [_; name] -> + begin match List.assoc_opt name benchmarks with + | Some run -> [name, run] + | None -> + Fmt.epr "Unknown benchmark %S@." name; + usage_error () + end + | _ -> usage_error () + in + let run (name, fn) = + traceln "Running %s..." name; + let metrics = fn env in + `Assoc [ + "name", `String name; + "metrics", `List metrics; + ] + in + (* The benchmark machine runs an old Docker that blocks pidfd_open *) + (* let uname = Eio.Process.parse_out env#process_mgr Eio.Buf_read.take_all ["uname"; "-a"] in *) + let uname = + let ch = Unix.open_process_in "uname -a" in + let x = input_line ch in + close_in ch; + x + in + Fmt.pr "%a@." (Yojson.Safe.pretty_print ~std:true) @@ `Assoc [ + "config", `Assoc [ + "uname", `String uname; + "backend", `String env#backend_id; + "recommended_domain_count", `Int (Domain.recommended_domain_count ()); + ]; + "results", `List (List.map run benchmarks); + ] diff --git a/bench/metric.ml b/bench/metric.ml index 0b3872cfb..ba110e12c 100644 --- a/bench/metric.ml +++ b/bench/metric.ml @@ -1,7 +1,7 @@ -let create name value units description : Yojson.Safe.t = - `Assoc [ - "name", `String name; - "value", (value :> Yojson.Safe.t); - "units", `String units; - "description", `String description; - ] +let create name value units description : Yojson.Safe.t = + `Assoc [ + "name", `String name; + "value", (value :> Yojson.Safe.t); + "units", `String units; + "description", `String description; + ] diff --git a/doc/dune b/doc/dune index 8ea33088a..898924c9e 100644 --- a/doc/dune +++ b/doc/dune @@ -1,5 +1,5 @@ -(mdx - (package eio_main) - (deps (package eio_main) (env_var "EIO_BACKEND")) - (enabled_if (<> %{os_type} "Win32")) - (files multicore.md)) +(mdx + (package eio_main) + (deps (package eio_main) (env_var "EIO_BACKEND")) + (enabled_if (<> %{os_type} "Win32")) + (files multicore.md)) diff --git a/doc/multicore.md b/doc/multicore.md index 2536979e9..56480fe25 100644 --- a/doc/multicore.md +++ b/doc/multicore.md @@ -1,537 +1,537 @@ -# Multicore Guide - - - -* [Introduction](#introduction) -* [Problems with Multicore Programming](#problems-with-multicore-programming) - * [Optimisation 1: Caching](#optimisation-1-caching) - * [Optimisation 2: Out-of-Order Execution](#optimisation-2-out-of-order-execution) - * [Optimisation 3: Compiler Optimisations](#optimisation-3-compiler-optimisations) - * [Optimisation 4: Multiple Cores](#optimisation-4-multiple-cores) -* [The OCaml Memory Model](#the-ocaml-memory-model) - * [Atomic Locations](#atomic-locations) - * [Initialisation](#initialisation) -* [Safety Guidelines](#safety-guidelines) -* [Performance Guidelines](#performance-guidelines) -* [Further Reading](#further-reading) - - - -## Introduction - -OCaml 5.0 adds support for using multiple CPU cores in a single OCaml process. -An OCaml process is made up of one or more *domains*, and -the operating system can run each domain on a different core, so that they run in parallel. -This can make programs run much faster, but also introduces new ways for programs to go wrong. -This guide explains how to write correct multicore programs using Eio. - -Note that using multiple cores is only useful to make your program run faster, when one core isn't enough. -Programs that need to juggle a large number of IO tasks -(such as downloading multiple files in parallel while providing an interactive user interface), -but don't need much CPU time, can just use multiple fibers on a single core instead. -Doing that avoids the problems described in this document. - -Before we start, we'll define a wrapper around `Eio_main.run` for the examples below. -`run fn` runs an Eio event loop, passing `fn` a function for running things in new domains: - -```ocaml -# #require "eio_main";; -# open Eio.Std;; - -# let run fn = - Eio_main.run @@ fun env -> - let domain_mgr = Eio.Stdenv.domain_mgr env in - fn (Eio.Domain_manager.run domain_mgr);; -val run : (((unit -> 'a) -> 'a) -> 'b) -> 'b = -``` - -## Problems with Multicore Programming - -There are two big difficulties with multicore programming. -We'll start with the simpler one. -Consider this program, which runs two fibers on a single domain: - -```ocaml -# Eio_main.run @@ fun _ -> - let x = ref 0 in - Fiber.both - (fun () -> incr x) - (fun () -> incr x); - traceln "x = %d" !x;; -+x = 2 -- : unit = () -``` - -Because we're only using a single domain, only one `incr` call can be running at once. -`x` gets incremented twice, and the final result is always `2`. -`both` runs the first fiber until it finishes or waits for something, and then switches to the next runnable fiber. - -However, trying to do the same thing with two cores adds a new behaviour: - - -```ocaml -# run @@ fun run_in_new_domain -> - let x = ref 0 in - Fiber.both - (fun () -> run_in_new_domain (fun () -> incr x)) - (fun () -> run_in_new_domain (fun () -> incr x)); - traceln "x = %d" !x;; -+x = 1 OR -+x = 2 -- : unit = () -``` - -The output here may be `x = 1` or `x = 2`. -One way to see that this can happen is to realise that `incr x` is really made up of three steps: - -1. Read the current value at location `x`. -2. Add one to it. -3. Store the result back at `x`. - -This wasn't a problem when using fibers because none of these steps performs an effect, -so once `incr` starts it continues until it's finished. -But with domains, both domains may perform step 1 at the same time, reading `0`, and -then both domains will write `1` as the result. - -It is easy to corrupt more complex data structures in this way. -For example, `Queue.add` increments a length counter and then makes the old last node point to the new one. -If two domains both add an item at the same time, it is possible to end up with a queue with its length counter -set to 2, but only containing one of the added items. - -However, this is not the only difficultly with multicore programming. -Consider this program: - -```ocaml -let test run_in_new_domain = - let x = ref 5 in - let ready = ref false in - Fiber.both - (fun () -> run_in_new_domain (fun () -> - x := !x * 2; - ready := true - )) - (fun () -> run_in_new_domain (fun () -> - while not !ready do () done; - traceln "x = %d" !x - )) -``` - -The first domain doubles `x` from `5` to `10` and then sets `ready` to `true`. -The second waits until `ready` is `true` and then prints `x`. -The results can be surprising: - - -```ocaml -# run test;; -+x = 5 OR -+x = 10 OR -(never finishes) -``` - -This cannot be explained simply by both domains running at the same time, -which brings us to the second difficulty. -To understand how the above results can happen we need to look at some optimisations computers use to run programs faster. - -### Optimisation 1: Caching - -A simple model of a computer is a CPU connected to some memory: - -``` -+-----+ +-----+ -| CPU |<------->| RAM | -+-----+ +-----+ -``` - -To perform an operation such as `incr x`, the CPU asks the RAM for the contents of memory address `x`. -It then increments it, and sends the result back to the RAM. - -Accessing RAM is relatively slow. A cache can be added to make things faster: - -``` -+-----+ +-------+ +-----+ -| CPU |<---->| Cache |<---->| RAM | -+-----+ +-------+ +-----+ -``` - -When the CPU requests a memory address, the cache fetches it from RAM and remembers what it was. -Next time the CPU wants the same address, the cache can return the remembered value quickly. -The cache can only store values for a limited number of addresses and will forget old addresses as new ones are loaded. - -Luckily, you usually don't need to think about the computer's caches. -A program that was correct without a cache is still correct with it; it just runs faster. - -### Optimisation 2: Out-of-Order Execution - -Consider the code `incr x; incr y`. -If executed in order, the CPU will: - -1. Request `x` from the memory. -2. Wait for it to arrive. -3. Add one and write it back. -4. Request `y` from the memory. -5. Wait for it to arrive. -6. Add one and write it back. - -This is very slow. When a modern CPU gets to step 2, it will look for other things it could be doing while waiting. -It can't do steps 2 or 3 (they depend on the fetched value), but it can start fetching `y`: - -1. Request `x` from the memory. -2. Request `y` from the memory. -3. Wait for `x` to arrive. -4. Add one and write it back. -5. Wait for `y` to arrive. -6. Add one and write it back. - -This can go much faster. - -Luckily, you usually don't need to think about out-of-order execution. -The CPU will only change the order when it won't make any visible difference, except to make the program run faster. - -### Optimisation 3: Compiler Optimisations - -Consider the code: - -```ocaml -let debug = ref false - -let foo x = - if !debug then print_endline "enter"; - incr x; - if !debug then print_endline "leave" -``` - -It would be wasteful to load `debug` from the memory twice. -Since `foo` doesn't change it after reading, the compiler can just reuse the previous load, -as if we'd written: - -```ocaml -let debug = ref false - -let foo x = - let d = !debug in - if d then print_endline "enter"; - incr x; - if d then print_endline "leave" -``` - -This is even faster than using the cache. -Luckily, you usually don't need to think about compiler optimisations. -The compiler will only optimise code if it doesn't change the program's behaviour, except to make it faster. - -### Optimisation 4: Multiple Cores - -We can make a computer faster by having multiple CPUs (or cores within a CPU): - -``` -+-------+ +-------+ +-----+ -| CPU-A |<---->| Cache |<---->| | -+-------+ +-------+ | | - | RAM | -+-------+ +-------+ | | -| CPU-B |<---->| Cache |<---->| | -+-------+ +-------+ +-----+ -``` - -Unluckily, this makes all of the previous optimisations unsound. - -Recall the test program above: - -```ocaml -let test run_in_new_domain = - let x = ref 5 in - let ready = ref false in - Fiber.both - (fun () -> run_in_new_domain (fun () -> - x := !x * 2; - ready := true - )) - (fun () -> run_in_new_domain (fun () -> - while not !ready do () done; - traceln "x = %d" !x - )) -``` - -If the first branch runs on CPU-A and the second on CPU-B: - -1. The first iteration of the `while` loop will load `ready=false` into CPU-B's cache. - It might then just keep using this cached value forever, even after CPU-A has updated it in the main memory. - -2. While CPU-A is waiting to read the old value of `x`, it might get on with setting `ready := true`. - The while loop might then finish and print `x = 5` before CPU-A has written the new value for `x`. - -3. The compiler might notice that `ready` isn't changed in the `while` loop. - It might optimise it to: `let r = !ready in while r do () done ...` and never finish. - -How can we write a correct program when our caches, CPUs and compiler are changing our program's behaviour? -The solution is to use a *memory model*. - -## The OCaml Memory Model - -The [OCaml Memory Model][] defines an imaginary computer system, and guarantees that a real system will not do anything that one wouldn't. -If your program would run correctly on the imaginary system, it will run correctly on a real one too. -The imaginary system has no caches, no out-of-order execution, and no compiler optimisations. -It does, however, have a slightly odd kind of memory. - -Each memory location has a *timeline* of values, rather than storing a single value like a normal memory location, -and each domain has a position on each timeline. -When our `test` program above has created the two `ref` cells and is about to spawn the domains, the memory looks like this: - -``` -x : [AB]5-----------------> -ready : [AB]false-------------> -``` - -This means that e.g. `ready`'s timeline contains just the initial value `false`, -and both processors are at that point on the timeline. -The set of positions over all timelines is called the CPU's *frontier*. -For example, the column of `A`s above is `A`'s frontier. - -When a processor reads from a memory location, it may get back any value at or after its current position. -At the moment, there is only one value on each timeline, so reads will just return that. - -When a processor writes to a memory location, it adds the new value somewhere to the right of its current position, -and then moves to that position. -So once the first branch has performed the `x := !x * 2` step, we have: - -``` -x : [B]5--------[A]10-----> -ready : [AB]false-------------> -``` - -If `A` reads from `x` at this point it will certainly read back the `10` it just wrote. -But if `B` were to read from `x`, it might see `5` or it might see `10`. -Concretely, this corresponds to possibilities such as `10` being in the computer's main RAM -but `5` being in `B`'s cache. - -The first branch then sets `ready := true`: - -``` -x : [B]5--------[A]10-----> -ready : [B]false---[A]true----> -``` - -I've shown the `true` slightly left of the `10` just to emphasise that the timelines are independent; -a write can go anywhere to the right of the current location. - -If the `while` loop keeps reading `false` (which it can) then the program will not terminate. -If it does read `true`, it will then read and display `x`, which it might see as either `5` or `10`. -This explains the three possible behaviours of the program on a real computer, -without having to think about caches, out-of-order execution, or compiler optimisations. - -### Atomic Locations - -OCaml also provides special "atomic" locations. -An atomic location just stores a single value; it does not have a timeline. -We could fix our program by replacing the `ref` cells with atomics, like this: - -```ocaml -let test run_in_new_domain = - let x = Atomic.make 5 in - let ready = Atomic.make false in - Fiber.both - (fun () -> run_in_new_domain (fun () -> - Atomic.set x (Atomic.get x * 2); - Atomic.set ready true - )) - (fun () -> run_in_new_domain (fun () -> - while not (Atomic.get ready) do () done; - traceln "x = %d" (Atomic.get x) - )) -``` - -This version will always produce the expected result: - -```ocaml -# run test;; -+x = 10 -- : unit = () -``` - -However, using atomics everywhere is slow. -For example, the first `Atomic.get x` might require loading `x` from RAM, even if it was already in the cache. - -We can solve this by relying on a useful feature of atomics: -every atomic also has a frontier of its own (a location on every non-atomic location's timeline). -The union of two frontiers is a frontier where each timeline point is the maximum of the two inputs. -Writing to an atomic sets both the writer's frontier and the atomic's frontier to the union of them both. -Reading from an atomic is similar, but updates only the reader's frontier. - -Here's a new version, mixing atomic and non-atomic locations: - -```ocaml -let test run_in_new_domain = - let x = ref 5 in - let ready = Atomic.make false in - Fiber.both - (fun () -> run_in_new_domain (fun () -> - x := !x * 2; - Atomic.set ready true - )) - (fun () -> run_in_new_domain (fun () -> - while not (Atomic.get ready) do () done; - traceln "x = %d" !x - )) -``` - -Initially (before the `Fiber.both`) the memory looks like this: - -``` -x : [ABR]5-----------------> -ready : false (atomic) -``` - -Notice that `ready` now has a frontier too, marked as `R`. -After writing `x`, we have: - -``` -x : [BR]5--------[A]10-----> -ready : false (atomic) -``` - -When the first branch writes to the atomic location `ready`, `[R]` gets updated too: - -``` -x : [B]5--------[AR]10-----> -ready : true (atomic) -``` - -At this point, if `B` were to read `x` it might see `5` or `10`, but after reading from `ready` it not only learns that its value is now `true`, -but also gets its frontier updated with information from `R`: - -``` -x : 5--------[ABR]10-----> -ready : true (atomic) -``` - -Therefore, this version will always print `10`: - -```ocaml -# run test;; -+x = 10 -- : unit = () -``` - -Of course, atomic locations do not store frontiers in a real computer. -It's just a way of thinking about what values can be read after accessing an atomic location. -For example, a real system must not perform the write to `ready` before issuing the write to `x`. - -### Initialisation - -In the above examples, the locations were set up before spawning the new domains. -What if we create new locations from a domain? For example, what does this do? - -```ocaml -let test run_in_new_domain = - let x = ref [1; 2; 3] in - Fiber.both - (fun () -> run_in_new_domain (fun () -> - x := [4; 5; 6] - )) - (fun () -> run_in_new_domain (fun () -> - traceln "x = %a" Fmt.(Dump.list int) !x - )) -``` - -If the second branch sees the old value of `x` then it will print `[1; 2; 3]`. -But if it sees the new value (a pointer to a newly allocated list), can we be sure those locations are initialised? -The answer is yes: a location's timeline in the OCaml memory model starts when the location is allocated -(it is not a physical memory address which might get reused). -In particular, an immutable value only ever has one item on its timeline, and so you can only ever read that value. -So it will always see a correct list: - - -```ocaml -# run test;; -+x = [1; 2; 3] OR -+x = [4; 5; 6] -- : unit = () -``` - -## Safety Guidelines - -It's important to understand the above to avoid writing incorrect code, -but there are several general principles that avoid most problems: - -- Immutable values can always be shared safely between domains. - -- To transfer mutable data, the sending domain must write to an atomic location after making the changes, - and the receiver must read from the same atomic location before reading the data. - The sender must not mutate the data after sending it. - -- Higher-level thread-safe primitives use atomics internally. - For example, protecting mutable data with a `Mutex` (only accessing the data while holding the mutex) - will ensure that all domains always see the latest writes. - Likewise, resolving an Eio `Promise` or adding data to an Eio `Stream` will write to an atomic location, - and reading the promise or taking the value from the stream will read the atomic, - ensuring that the receiver is up-to-date with the state of the data (assuming it wasn't - modified afterwards). - -- OCaml spent the first 25 years of its existence without multicore support, and so most libraries are not thread-safe. - Even in languages that had parallelism from the beginning, thread safety is a very common cause of bugs. - You should assume that values created by an OCaml library are not multicore safe, unless specified otherwise. - -There are several reasonable ways to share mutable values between domains: - -1. Values specifically designed to be thread-safe (e.g. a `Mutex.t`) can be shared. -2. A non-threadsafe value's owning domain can update it in response to messages from other domains. -3. A non-threadsafe value can be wrapped with a mutex. -4. A non-threadsafe value can passed to another domain if the sending domain will never use it again. - -Note that (2) and (3) are not quite the same. -Consider this code: - -```ocaml -let example q = - assert (Queue.length q = Queue.length q) -``` - -If `q` is only updated by its owning domain (as in 2) then this assertion will always pass. -`Queue.length` will not perform an effect which could switch fibers, so nothing else can update `q`. -If another domain wants to change it, it sends a message to `q`'s domain, which is added to the domain's -run-queue and will take effect later. - -However, if `q` is wrapped by a mutex (as in 3) then the assertion could fail. -The first `Queue.length` will lock and then release the queue, then the second will lock and release it again. -Another domain could change the value between these two calls. - -You can often run most of your program's logic in a single domain, using fibers, -while sending self-contained CPU-intensive jobs to a pool of worker domains. -This gets most of the benefits of using multiple domains while avoiding most of the problems. -See the "Worker Pool" example in the main README for an example. - -Finally, note that OCaml remains type-safe even with multiple domains. -For example, accessing a `Queue` in parallel from multiple domains may result in a corrupted queue, -but it won't cause a segfault. - -## Performance Guidelines - -The following recommendations will help you extract as much performance as possible from your hardware: - -- There's a certain overhead associated with placing execution onto another domain, - but that overhead will be paid off quickly if your job takes at least a few milliseconds to complete. - Jobs that complete under 2-5ms may not be worth running on a separate domain. -- Similarly, jobs that are 100% I/O-bound may not be worth running on a separate domain. - The small initial overhead is simply never recouped. -- If your program never hits 100% CPU usage, it's unlikely that parallelizing it will improve performance. -- Try to avoid reading or writing to memory that's modified by other domains after the start of your job. - Ideally, your jobs shouldn't need to interact with other domains' "working data". - Aim to make your jobs as independent as possible. - If unavoidable, the [Saturn](https://github.com/ocaml-multicore/saturn) library offers a collection of efficient threadsafe data structures. -- It's often easier to design code to be multithreading friendly from the start - (by making longer, independent jobs) than by refactoring existing code. -- There's a cost associated with creating a domain, so try to use the same domains for longer periods of time. - `Eio.Executor_pool` takes care of this automatically. -- Obviously, reuse the same executor pool whenever possible! Don't recreate it over and over. -- Having a large number of domains active at the same time imposes additional overhead on - both the OS scheduler and the OCaml runtime, even if those domains are idle. - -## Further Reading - -- [OCaml Memory Model][] describes the full details of the memory model. -- [Separation Logic Foundations][] introduces Separation Logic, which allows specifying code in a composable way. - It is particularly useful for reasoning about parallel systems. -- [Parallel Programming in Multicore OCaml][] provides help for writing high-performance multicore code in OCaml. - -[OCaml Memory Model]: https://kcsrk.info/papers/pldi18-memory.pdf -[Separation Logic Foundations]: https://softwarefoundations.cis.upenn.edu/slf-current/index.html -[Parallel Programming in Multicore OCaml]: https://github.com/ocaml-multicore/parallel-programming-in-multicore-ocaml +# Multicore Guide + + + +* [Introduction](#introduction) +* [Problems with Multicore Programming](#problems-with-multicore-programming) + * [Optimisation 1: Caching](#optimisation-1-caching) + * [Optimisation 2: Out-of-Order Execution](#optimisation-2-out-of-order-execution) + * [Optimisation 3: Compiler Optimisations](#optimisation-3-compiler-optimisations) + * [Optimisation 4: Multiple Cores](#optimisation-4-multiple-cores) +* [The OCaml Memory Model](#the-ocaml-memory-model) + * [Atomic Locations](#atomic-locations) + * [Initialisation](#initialisation) +* [Safety Guidelines](#safety-guidelines) +* [Performance Guidelines](#performance-guidelines) +* [Further Reading](#further-reading) + + + +## Introduction + +OCaml 5.0 adds support for using multiple CPU cores in a single OCaml process. +An OCaml process is made up of one or more *domains*, and +the operating system can run each domain on a different core, so that they run in parallel. +This can make programs run much faster, but also introduces new ways for programs to go wrong. +This guide explains how to write correct multicore programs using Eio. + +Note that using multiple cores is only useful to make your program run faster, when one core isn't enough. +Programs that need to juggle a large number of IO tasks +(such as downloading multiple files in parallel while providing an interactive user interface), +but don't need much CPU time, can just use multiple fibers on a single core instead. +Doing that avoids the problems described in this document. + +Before we start, we'll define a wrapper around `Eio_main.run` for the examples below. +`run fn` runs an Eio event loop, passing `fn` a function for running things in new domains: + +```ocaml +# #require "eio_main";; +# open Eio.Std;; + +# let run fn = + Eio_main.run @@ fun env -> + let domain_mgr = Eio.Stdenv.domain_mgr env in + fn (Eio.Domain_manager.run domain_mgr);; +val run : (((unit -> 'a) -> 'a) -> 'b) -> 'b = +``` + +## Problems with Multicore Programming + +There are two big difficulties with multicore programming. +We'll start with the simpler one. +Consider this program, which runs two fibers on a single domain: + +```ocaml +# Eio_main.run @@ fun _ -> + let x = ref 0 in + Fiber.both + (fun () -> incr x) + (fun () -> incr x); + traceln "x = %d" !x;; ++x = 2 +- : unit = () +``` + +Because we're only using a single domain, only one `incr` call can be running at once. +`x` gets incremented twice, and the final result is always `2`. +`both` runs the first fiber until it finishes or waits for something, and then switches to the next runnable fiber. + +However, trying to do the same thing with two cores adds a new behaviour: + + +```ocaml +# run @@ fun run_in_new_domain -> + let x = ref 0 in + Fiber.both + (fun () -> run_in_new_domain (fun () -> incr x)) + (fun () -> run_in_new_domain (fun () -> incr x)); + traceln "x = %d" !x;; ++x = 1 OR ++x = 2 +- : unit = () +``` + +The output here may be `x = 1` or `x = 2`. +One way to see that this can happen is to realise that `incr x` is really made up of three steps: + +1. Read the current value at location `x`. +2. Add one to it. +3. Store the result back at `x`. + +This wasn't a problem when using fibers because none of these steps performs an effect, +so once `incr` starts it continues until it's finished. +But with domains, both domains may perform step 1 at the same time, reading `0`, and +then both domains will write `1` as the result. + +It is easy to corrupt more complex data structures in this way. +For example, `Queue.add` increments a length counter and then makes the old last node point to the new one. +If two domains both add an item at the same time, it is possible to end up with a queue with its length counter +set to 2, but only containing one of the added items. + +However, this is not the only difficultly with multicore programming. +Consider this program: + +```ocaml +let test run_in_new_domain = + let x = ref 5 in + let ready = ref false in + Fiber.both + (fun () -> run_in_new_domain (fun () -> + x := !x * 2; + ready := true + )) + (fun () -> run_in_new_domain (fun () -> + while not !ready do () done; + traceln "x = %d" !x + )) +``` + +The first domain doubles `x` from `5` to `10` and then sets `ready` to `true`. +The second waits until `ready` is `true` and then prints `x`. +The results can be surprising: + + +```ocaml +# run test;; ++x = 5 OR ++x = 10 OR +(never finishes) +``` + +This cannot be explained simply by both domains running at the same time, +which brings us to the second difficulty. +To understand how the above results can happen we need to look at some optimisations computers use to run programs faster. + +### Optimisation 1: Caching + +A simple model of a computer is a CPU connected to some memory: + +``` ++-----+ +-----+ +| CPU |<------->| RAM | ++-----+ +-----+ +``` + +To perform an operation such as `incr x`, the CPU asks the RAM for the contents of memory address `x`. +It then increments it, and sends the result back to the RAM. + +Accessing RAM is relatively slow. A cache can be added to make things faster: + +``` ++-----+ +-------+ +-----+ +| CPU |<---->| Cache |<---->| RAM | ++-----+ +-------+ +-----+ +``` + +When the CPU requests a memory address, the cache fetches it from RAM and remembers what it was. +Next time the CPU wants the same address, the cache can return the remembered value quickly. +The cache can only store values for a limited number of addresses and will forget old addresses as new ones are loaded. + +Luckily, you usually don't need to think about the computer's caches. +A program that was correct without a cache is still correct with it; it just runs faster. + +### Optimisation 2: Out-of-Order Execution + +Consider the code `incr x; incr y`. +If executed in order, the CPU will: + +1. Request `x` from the memory. +2. Wait for it to arrive. +3. Add one and write it back. +4. Request `y` from the memory. +5. Wait for it to arrive. +6. Add one and write it back. + +This is very slow. When a modern CPU gets to step 2, it will look for other things it could be doing while waiting. +It can't do steps 2 or 3 (they depend on the fetched value), but it can start fetching `y`: + +1. Request `x` from the memory. +2. Request `y` from the memory. +3. Wait for `x` to arrive. +4. Add one and write it back. +5. Wait for `y` to arrive. +6. Add one and write it back. + +This can go much faster. + +Luckily, you usually don't need to think about out-of-order execution. +The CPU will only change the order when it won't make any visible difference, except to make the program run faster. + +### Optimisation 3: Compiler Optimisations + +Consider the code: + +```ocaml +let debug = ref false + +let foo x = + if !debug then print_endline "enter"; + incr x; + if !debug then print_endline "leave" +``` + +It would be wasteful to load `debug` from the memory twice. +Since `foo` doesn't change it after reading, the compiler can just reuse the previous load, +as if we'd written: + +```ocaml +let debug = ref false + +let foo x = + let d = !debug in + if d then print_endline "enter"; + incr x; + if d then print_endline "leave" +``` + +This is even faster than using the cache. +Luckily, you usually don't need to think about compiler optimisations. +The compiler will only optimise code if it doesn't change the program's behaviour, except to make it faster. + +### Optimisation 4: Multiple Cores + +We can make a computer faster by having multiple CPUs (or cores within a CPU): + +``` ++-------+ +-------+ +-----+ +| CPU-A |<---->| Cache |<---->| | ++-------+ +-------+ | | + | RAM | ++-------+ +-------+ | | +| CPU-B |<---->| Cache |<---->| | ++-------+ +-------+ +-----+ +``` + +Unluckily, this makes all of the previous optimisations unsound. + +Recall the test program above: + +```ocaml +let test run_in_new_domain = + let x = ref 5 in + let ready = ref false in + Fiber.both + (fun () -> run_in_new_domain (fun () -> + x := !x * 2; + ready := true + )) + (fun () -> run_in_new_domain (fun () -> + while not !ready do () done; + traceln "x = %d" !x + )) +``` + +If the first branch runs on CPU-A and the second on CPU-B: + +1. The first iteration of the `while` loop will load `ready=false` into CPU-B's cache. + It might then just keep using this cached value forever, even after CPU-A has updated it in the main memory. + +2. While CPU-A is waiting to read the old value of `x`, it might get on with setting `ready := true`. + The while loop might then finish and print `x = 5` before CPU-A has written the new value for `x`. + +3. The compiler might notice that `ready` isn't changed in the `while` loop. + It might optimise it to: `let r = !ready in while r do () done ...` and never finish. + +How can we write a correct program when our caches, CPUs and compiler are changing our program's behaviour? +The solution is to use a *memory model*. + +## The OCaml Memory Model + +The [OCaml Memory Model][] defines an imaginary computer system, and guarantees that a real system will not do anything that one wouldn't. +If your program would run correctly on the imaginary system, it will run correctly on a real one too. +The imaginary system has no caches, no out-of-order execution, and no compiler optimisations. +It does, however, have a slightly odd kind of memory. + +Each memory location has a *timeline* of values, rather than storing a single value like a normal memory location, +and each domain has a position on each timeline. +When our `test` program above has created the two `ref` cells and is about to spawn the domains, the memory looks like this: + +``` +x : [AB]5-----------------> +ready : [AB]false-------------> +``` + +This means that e.g. `ready`'s timeline contains just the initial value `false`, +and both processors are at that point on the timeline. +The set of positions over all timelines is called the CPU's *frontier*. +For example, the column of `A`s above is `A`'s frontier. + +When a processor reads from a memory location, it may get back any value at or after its current position. +At the moment, there is only one value on each timeline, so reads will just return that. + +When a processor writes to a memory location, it adds the new value somewhere to the right of its current position, +and then moves to that position. +So once the first branch has performed the `x := !x * 2` step, we have: + +``` +x : [B]5--------[A]10-----> +ready : [AB]false-------------> +``` + +If `A` reads from `x` at this point it will certainly read back the `10` it just wrote. +But if `B` were to read from `x`, it might see `5` or it might see `10`. +Concretely, this corresponds to possibilities such as `10` being in the computer's main RAM +but `5` being in `B`'s cache. + +The first branch then sets `ready := true`: + +``` +x : [B]5--------[A]10-----> +ready : [B]false---[A]true----> +``` + +I've shown the `true` slightly left of the `10` just to emphasise that the timelines are independent; +a write can go anywhere to the right of the current location. + +If the `while` loop keeps reading `false` (which it can) then the program will not terminate. +If it does read `true`, it will then read and display `x`, which it might see as either `5` or `10`. +This explains the three possible behaviours of the program on a real computer, +without having to think about caches, out-of-order execution, or compiler optimisations. + +### Atomic Locations + +OCaml also provides special "atomic" locations. +An atomic location just stores a single value; it does not have a timeline. +We could fix our program by replacing the `ref` cells with atomics, like this: + +```ocaml +let test run_in_new_domain = + let x = Atomic.make 5 in + let ready = Atomic.make false in + Fiber.both + (fun () -> run_in_new_domain (fun () -> + Atomic.set x (Atomic.get x * 2); + Atomic.set ready true + )) + (fun () -> run_in_new_domain (fun () -> + while not (Atomic.get ready) do () done; + traceln "x = %d" (Atomic.get x) + )) +``` + +This version will always produce the expected result: + +```ocaml +# run test;; ++x = 10 +- : unit = () +``` + +However, using atomics everywhere is slow. +For example, the first `Atomic.get x` might require loading `x` from RAM, even if it was already in the cache. + +We can solve this by relying on a useful feature of atomics: +every atomic also has a frontier of its own (a location on every non-atomic location's timeline). +The union of two frontiers is a frontier where each timeline point is the maximum of the two inputs. +Writing to an atomic sets both the writer's frontier and the atomic's frontier to the union of them both. +Reading from an atomic is similar, but updates only the reader's frontier. + +Here's a new version, mixing atomic and non-atomic locations: + +```ocaml +let test run_in_new_domain = + let x = ref 5 in + let ready = Atomic.make false in + Fiber.both + (fun () -> run_in_new_domain (fun () -> + x := !x * 2; + Atomic.set ready true + )) + (fun () -> run_in_new_domain (fun () -> + while not (Atomic.get ready) do () done; + traceln "x = %d" !x + )) +``` + +Initially (before the `Fiber.both`) the memory looks like this: + +``` +x : [ABR]5-----------------> +ready : false (atomic) +``` + +Notice that `ready` now has a frontier too, marked as `R`. +After writing `x`, we have: + +``` +x : [BR]5--------[A]10-----> +ready : false (atomic) +``` + +When the first branch writes to the atomic location `ready`, `[R]` gets updated too: + +``` +x : [B]5--------[AR]10-----> +ready : true (atomic) +``` + +At this point, if `B` were to read `x` it might see `5` or `10`, but after reading from `ready` it not only learns that its value is now `true`, +but also gets its frontier updated with information from `R`: + +``` +x : 5--------[ABR]10-----> +ready : true (atomic) +``` + +Therefore, this version will always print `10`: + +```ocaml +# run test;; ++x = 10 +- : unit = () +``` + +Of course, atomic locations do not store frontiers in a real computer. +It's just a way of thinking about what values can be read after accessing an atomic location. +For example, a real system must not perform the write to `ready` before issuing the write to `x`. + +### Initialisation + +In the above examples, the locations were set up before spawning the new domains. +What if we create new locations from a domain? For example, what does this do? + +```ocaml +let test run_in_new_domain = + let x = ref [1; 2; 3] in + Fiber.both + (fun () -> run_in_new_domain (fun () -> + x := [4; 5; 6] + )) + (fun () -> run_in_new_domain (fun () -> + traceln "x = %a" Fmt.(Dump.list int) !x + )) +``` + +If the second branch sees the old value of `x` then it will print `[1; 2; 3]`. +But if it sees the new value (a pointer to a newly allocated list), can we be sure those locations are initialised? +The answer is yes: a location's timeline in the OCaml memory model starts when the location is allocated +(it is not a physical memory address which might get reused). +In particular, an immutable value only ever has one item on its timeline, and so you can only ever read that value. +So it will always see a correct list: + + +```ocaml +# run test;; ++x = [1; 2; 3] OR ++x = [4; 5; 6] +- : unit = () +``` + +## Safety Guidelines + +It's important to understand the above to avoid writing incorrect code, +but there are several general principles that avoid most problems: + +- Immutable values can always be shared safely between domains. + +- To transfer mutable data, the sending domain must write to an atomic location after making the changes, + and the receiver must read from the same atomic location before reading the data. + The sender must not mutate the data after sending it. + +- Higher-level thread-safe primitives use atomics internally. + For example, protecting mutable data with a `Mutex` (only accessing the data while holding the mutex) + will ensure that all domains always see the latest writes. + Likewise, resolving an Eio `Promise` or adding data to an Eio `Stream` will write to an atomic location, + and reading the promise or taking the value from the stream will read the atomic, + ensuring that the receiver is up-to-date with the state of the data (assuming it wasn't + modified afterwards). + +- OCaml spent the first 25 years of its existence without multicore support, and so most libraries are not thread-safe. + Even in languages that had parallelism from the beginning, thread safety is a very common cause of bugs. + You should assume that values created by an OCaml library are not multicore safe, unless specified otherwise. + +There are several reasonable ways to share mutable values between domains: + +1. Values specifically designed to be thread-safe (e.g. a `Mutex.t`) can be shared. +2. A non-threadsafe value's owning domain can update it in response to messages from other domains. +3. A non-threadsafe value can be wrapped with a mutex. +4. A non-threadsafe value can passed to another domain if the sending domain will never use it again. + +Note that (2) and (3) are not quite the same. +Consider this code: + +```ocaml +let example q = + assert (Queue.length q = Queue.length q) +``` + +If `q` is only updated by its owning domain (as in 2) then this assertion will always pass. +`Queue.length` will not perform an effect which could switch fibers, so nothing else can update `q`. +If another domain wants to change it, it sends a message to `q`'s domain, which is added to the domain's +run-queue and will take effect later. + +However, if `q` is wrapped by a mutex (as in 3) then the assertion could fail. +The first `Queue.length` will lock and then release the queue, then the second will lock and release it again. +Another domain could change the value between these two calls. + +You can often run most of your program's logic in a single domain, using fibers, +while sending self-contained CPU-intensive jobs to a pool of worker domains. +This gets most of the benefits of using multiple domains while avoiding most of the problems. +See the "Worker Pool" example in the main README for an example. + +Finally, note that OCaml remains type-safe even with multiple domains. +For example, accessing a `Queue` in parallel from multiple domains may result in a corrupted queue, +but it won't cause a segfault. + +## Performance Guidelines + +The following recommendations will help you extract as much performance as possible from your hardware: + +- There's a certain overhead associated with placing execution onto another domain, + but that overhead will be paid off quickly if your job takes at least a few milliseconds to complete. + Jobs that complete under 2-5ms may not be worth running on a separate domain. +- Similarly, jobs that are 100% I/O-bound may not be worth running on a separate domain. + The small initial overhead is simply never recouped. +- If your program never hits 100% CPU usage, it's unlikely that parallelizing it will improve performance. +- Try to avoid reading or writing to memory that's modified by other domains after the start of your job. + Ideally, your jobs shouldn't need to interact with other domains' "working data". + Aim to make your jobs as independent as possible. + If unavoidable, the [Saturn](https://github.com/ocaml-multicore/saturn) library offers a collection of efficient threadsafe data structures. +- It's often easier to design code to be multithreading friendly from the start + (by making longer, independent jobs) than by refactoring existing code. +- There's a cost associated with creating a domain, so try to use the same domains for longer periods of time. + `Eio.Executor_pool` takes care of this automatically. +- Obviously, reuse the same executor pool whenever possible! Don't recreate it over and over. +- Having a large number of domains active at the same time imposes additional overhead on + both the OS scheduler and the OCaml runtime, even if those domains are idle. + +## Further Reading + +- [OCaml Memory Model][] describes the full details of the memory model. +- [Separation Logic Foundations][] introduces Separation Logic, which allows specifying code in a composable way. + It is particularly useful for reasoning about parallel systems. +- [Parallel Programming in Multicore OCaml][] provides help for writing high-performance multicore code in OCaml. + +[OCaml Memory Model]: https://kcsrk.info/papers/pldi18-memory.pdf +[Separation Logic Foundations]: https://softwarefoundations.cis.upenn.edu/slf-current/index.html +[Parallel Programming in Multicore OCaml]: https://github.com/ocaml-multicore/parallel-programming-in-multicore-ocaml diff --git a/doc/prelude.ml b/doc/prelude.ml index 2f3a7ca79..c2de66243 100644 --- a/doc/prelude.ml +++ b/doc/prelude.ml @@ -1,34 +1,34 @@ -#require "eio_main";; -#require "eio.mock";; - -module Eio_main = struct - open Eio.Std - - module Fake_clock = struct - type time = float - type t = unit - let sleep_until () _time = failwith "No sleeping in tests!" - let now _ = 1623940778.27033591 - end - - let fake_clock = - let handler = Eio.Time.Pi.clock (module Fake_clock) in - Eio.Resource.T ((), handler) - - let run fn = - (* To avoid non-deterministic output, we run the examples a single domain. *) - let fake_domain_mgr = Eio_mock.Domain_manager.create () in - Eio_main.run @@ fun env -> - fn @@ object - method net = env#net - method stdin = env#stdin - method stdout = env#stdout - method stderr = env#stderr - method cwd = env#cwd - method process_mgr = env#process_mgr - method domain_mgr = fake_domain_mgr - method clock = fake_clock - end -end - -let parse_config (flow : _ Eio.Flow.source) = ignore +#require "eio_main";; +#require "eio.mock";; + +module Eio_main = struct + open Eio.Std + + module Fake_clock = struct + type time = float + type t = unit + let sleep_until () _time = failwith "No sleeping in tests!" + let now _ = 1623940778.27033591 + end + + let fake_clock = + let handler = Eio.Time.Pi.clock (module Fake_clock) in + Eio.Resource.T ((), handler) + + let run fn = + (* To avoid non-deterministic output, we run the examples a single domain. *) + let fake_domain_mgr = Eio_mock.Domain_manager.create () in + Eio_main.run @@ fun env -> + fn @@ object + method net = env#net + method stdin = env#stdin + method stdout = env#stdout + method stderr = env#stderr + method cwd = env#cwd + method process_mgr = env#process_mgr + method domain_mgr = fake_domain_mgr + method clock = fake_clock + end +end + +let parse_config (flow : _ Eio.Flow.source) = ignore diff --git a/doc/rationale.md b/doc/rationale.md index b77ad10e5..698988c17 100644 --- a/doc/rationale.md +++ b/doc/rationale.md @@ -1,167 +1,167 @@ -This document collects some of the reasons behind various API choices in Eio. - -## Scheduling Order - -When forking a new fiber, there are several reasonable scheduling behaviours: - -1. Append the new fiber to the run queue and then continue running the parent. -2. Append the parent fiber to the run queue and start the child immediately. -3. Append both old and new fibers to the run-queue (in some order), then schedule the next task at the queue's head. -4. Prepend the old and new fibers to the *head* of the run-queue and resume one of them immediately. - -And several desirable features: - -- Especially for `Fiber.both`, putting both at the start or both at the end of the run-queue seems more consistent - that starting one before everything in the queue and the other after. -- Adding both to the head of the queue is the most flexible, since the other behaviours can then be achieved by yielding. -- Putting both at the head may lead to starvation of other fibers. -- Running the child before the parent allows the child to e.g. create a switch and store it somewhere atomically. -- Scheduling new work to run next can make better use of the cache in some cases (domainslib works this way). - -Therefore, `Fiber.fork f` runs `f` immediately and pushes the calling fiber to the head of the run-queue. -After making this change, the examples in the README seemed a bit more natural too. - -## Indicating End-of-File - -Functions for reading from a byte-stream need a way to indicate that the stream has ended. -There are various common ways to do this: - -- Raise the `End_of_file` exception, as `Stdlib.input_line` does. -- Return `None`, as `Stdlib.In_channel.input_line` does. -- Return that 0 bytes were read, as `Stdlib.input` does. -- Return `Error End_of_file`, or similar. - -Desirable features: - -- A program that forgets to handle end-of-file should not hang. -- The programmer should not forget to handle end-of-file when they need to. -- The programmer should not be forced to handle it when they don't. -- Ideally, reading should not allocate on the heap. -- The meaning of the code should be obvious. - -Returning 0 makes infinite loops easy to write. -For example, a function to parse a number from a stream might keep appending to a buffer until it sees a non-digit byte. -If the file ends in the middle of a number, the parser will hang, while working in other cases. - -Returning a result or option type forces an allocation even for successful reads. -Mirage's `FLOW` type even uses ``Ok `Eof``, requiring a double allocation on every successful read. -However, it is likely that a read will allocate for other reasons (such as allocating a continuation when performing an effect), -so this is not a serious problem (for unbuffered reads at least). - -Returning `None` makes the code unclear - you need to check the documentation to discover whether this applies only to end-of-file or to other kinds of error too, and may encourage programmers to discard error information and return `None` in all cases. - -Raising `End_of_file` or returning 0 allows the programmer to forget to handle the error with no compile-time warning. - -Eio chooses to use `End_of_file`: - -- If you forget to handle it, the cause of the problem is at least obvious (unlike returning 0). -- It makes it easy to handle the error in one place, rather than throughout a parser. - A backtracking parser is likely to be using exceptions for errors anyway. -- With typed effects it will be possible to track the exception in the type system (unlike returning 0). -- For simple code, with a single read in a loop, you will immediately notice if you don't handle end-of-file. -- For complex code, with multiple reads, you will likely use a parser library that hides this anyway. - -## Dynamic Dispatch - -Code is easier to understand when the target of a function call is known statically. -However, this is not always possible. -For example, there are many ways to provide a stream of bytes (from a file, TCP socket, HTTP encoding, TLS encoding, etc). -Often this choice is determined by the user at runtime, for example by providing a URL giving the scheme to use. -We may even need to choose a completely different Eio backend at runtime. -For example `Eio_main.run` will use the io_uring backend if the Linux kernel is new enough, -but fall back to `Eio_posix` if not. -For these reasons, Eio needs to use dynamic dispatch. - -A resource whose implementation isn't known until runtime can be represented in many ways, including: - -- As an object. -- As a record, with one field for each method. -- As a first-class module along with one of its values, packed in a GADT. - -OCaml modules have the nice property that they can be used from fully static to fully dynamic situations: - -- If a library author knows which concrete module they want, - they can just call that module directly. - -- If the library can be used with different modules, - but the application using the library will decide which one at compile time, - the library can use a functor. - -- If the module will only be known at runtime, a first-class module can be passed as an argument. - -For Eio, we also need good support for sub-typing because different platforms provide different features, -and because different operating system resources have overlapping features. -For example: - -- Some flows are read-only, some write-only, and some read-write. -- Most can be closed. -- Some two-way flows support shutting down one side of the connection. -- Some flows are backed by a Unix file descriptor which we may want to extract. - -The OCaml standard library provides separate `close_in` and `close_out` functions, but cannot handle two-way flows. -Eio instead provides a single `Flow.close` that works with all flows that can be closed. - -Users of Eio can choose how specific to make their code. -For example, calling `Eio_main.run` will get you a basic Unix-like environment, -whereas using `Eio_linux.run` provides extra features specific to Linux's io_uring API. -This can then all be tracked in the type system -(dynamic checks are also possible, for more complex code that wants to use specific features only when available). -In contrast, OCaml's `Unix` module provides several functions that simply fail at runtime -on platforms where the function isn't available. - -For dynamic dispatch with subtyping, objects seem to be the best choice: - -- Records and modules require explicit casts when used. - Objects avoid this problem using row-polymorphism. - -- Using records or first-class modules requires frequently allocating. - For example, when you have a `TWO_WAY` module and you want to use it as a `SOURCE`, - OCaml has to make a copy of the module with the fields in the right order. - For records, you have to write the code to do this copying yourself. - Objects don't change their in-memory representation when used at different types. - -- Using records means storing all the methods on every instance, which is wasteful. - Using a GADT adds an extra level of indirection to the value's fields. - An object uses a single block to store the object's fields and a pointer to the shared method table. - -- First-class modules and GADTs are an advanced feature of the language. - The new users we hope to attract to OCaml 5.0 are likely to be familiar with objects already. - -- It is possible to provide base classes with default implementations of some methods. - This can allow adding new operations to the API in future without breaking existing providers. - -In general, simulating objects using other features of the language leads to worse performance -and worse ergonomics than using the language's built-in support. - -However, in order for Eio to be widely accepted in the OCaml community, -we no longer use of objects and instead use a pair of a value and a function for looking up interfaces. -There is a problem here, because each interface has a different type, -so the function's return type depends on its input (the interface ID). -This requires using a GADT. However, GADT's don't support sub-typing. -To get around this, we use an extensible GADT to get the correct typing -(but which will raise an exception if the interface isn't supported), -and then wrap this with a polymorphic variant phantom type to help ensure -it is used correctly. - -This system gives the same performance as using objects and without requiring allocation. -However, care is needed when defining new interfaces, -since the compiler can't check that the resource really implements all the interfaces its phantom type suggests. - -## Results vs Exceptions - -The OCaml standard library uses exceptions to report errors in most cases. -Many libraries instead use the `result` type, which has the advantage of tracking the possible errors in the type system. -However, using `result` is slower, as it requires more allocations, and explicit code to propagate errors. - -As part of the effects work, OCaml is expected to gain a [typed effects][] extension to the type system, -allowing it to track both effects and exceptions statically. -In anticipation of this, the Eio library prefers to use exceptions in most cases, -reserving the use of `result` for cases where the caller is likely to want to handle the problem immediately -rather than propagate it. - -In additional, while result types work well -for functions with a small number of known errors which can be handled at the call-site, -they work poorly for IO errors where there are typically a large and unknown set of possible errors -(depending on the backend). - -[typed effects]: https://www.janestreet.com/tech-talks/effective-programming/ +This document collects some of the reasons behind various API choices in Eio. + +## Scheduling Order + +When forking a new fiber, there are several reasonable scheduling behaviours: + +1. Append the new fiber to the run queue and then continue running the parent. +2. Append the parent fiber to the run queue and start the child immediately. +3. Append both old and new fibers to the run-queue (in some order), then schedule the next task at the queue's head. +4. Prepend the old and new fibers to the *head* of the run-queue and resume one of them immediately. + +And several desirable features: + +- Especially for `Fiber.both`, putting both at the start or both at the end of the run-queue seems more consistent + that starting one before everything in the queue and the other after. +- Adding both to the head of the queue is the most flexible, since the other behaviours can then be achieved by yielding. +- Putting both at the head may lead to starvation of other fibers. +- Running the child before the parent allows the child to e.g. create a switch and store it somewhere atomically. +- Scheduling new work to run next can make better use of the cache in some cases (domainslib works this way). + +Therefore, `Fiber.fork f` runs `f` immediately and pushes the calling fiber to the head of the run-queue. +After making this change, the examples in the README seemed a bit more natural too. + +## Indicating End-of-File + +Functions for reading from a byte-stream need a way to indicate that the stream has ended. +There are various common ways to do this: + +- Raise the `End_of_file` exception, as `Stdlib.input_line` does. +- Return `None`, as `Stdlib.In_channel.input_line` does. +- Return that 0 bytes were read, as `Stdlib.input` does. +- Return `Error End_of_file`, or similar. + +Desirable features: + +- A program that forgets to handle end-of-file should not hang. +- The programmer should not forget to handle end-of-file when they need to. +- The programmer should not be forced to handle it when they don't. +- Ideally, reading should not allocate on the heap. +- The meaning of the code should be obvious. + +Returning 0 makes infinite loops easy to write. +For example, a function to parse a number from a stream might keep appending to a buffer until it sees a non-digit byte. +If the file ends in the middle of a number, the parser will hang, while working in other cases. + +Returning a result or option type forces an allocation even for successful reads. +Mirage's `FLOW` type even uses ``Ok `Eof``, requiring a double allocation on every successful read. +However, it is likely that a read will allocate for other reasons (such as allocating a continuation when performing an effect), +so this is not a serious problem (for unbuffered reads at least). + +Returning `None` makes the code unclear - you need to check the documentation to discover whether this applies only to end-of-file or to other kinds of error too, and may encourage programmers to discard error information and return `None` in all cases. + +Raising `End_of_file` or returning 0 allows the programmer to forget to handle the error with no compile-time warning. + +Eio chooses to use `End_of_file`: + +- If you forget to handle it, the cause of the problem is at least obvious (unlike returning 0). +- It makes it easy to handle the error in one place, rather than throughout a parser. + A backtracking parser is likely to be using exceptions for errors anyway. +- With typed effects it will be possible to track the exception in the type system (unlike returning 0). +- For simple code, with a single read in a loop, you will immediately notice if you don't handle end-of-file. +- For complex code, with multiple reads, you will likely use a parser library that hides this anyway. + +## Dynamic Dispatch + +Code is easier to understand when the target of a function call is known statically. +However, this is not always possible. +For example, there are many ways to provide a stream of bytes (from a file, TCP socket, HTTP encoding, TLS encoding, etc). +Often this choice is determined by the user at runtime, for example by providing a URL giving the scheme to use. +We may even need to choose a completely different Eio backend at runtime. +For example `Eio_main.run` will use the io_uring backend if the Linux kernel is new enough, +but fall back to `Eio_posix` if not. +For these reasons, Eio needs to use dynamic dispatch. + +A resource whose implementation isn't known until runtime can be represented in many ways, including: + +- As an object. +- As a record, with one field for each method. +- As a first-class module along with one of its values, packed in a GADT. + +OCaml modules have the nice property that they can be used from fully static to fully dynamic situations: + +- If a library author knows which concrete module they want, + they can just call that module directly. + +- If the library can be used with different modules, + but the application using the library will decide which one at compile time, + the library can use a functor. + +- If the module will only be known at runtime, a first-class module can be passed as an argument. + +For Eio, we also need good support for sub-typing because different platforms provide different features, +and because different operating system resources have overlapping features. +For example: + +- Some flows are read-only, some write-only, and some read-write. +- Most can be closed. +- Some two-way flows support shutting down one side of the connection. +- Some flows are backed by a Unix file descriptor which we may want to extract. + +The OCaml standard library provides separate `close_in` and `close_out` functions, but cannot handle two-way flows. +Eio instead provides a single `Flow.close` that works with all flows that can be closed. + +Users of Eio can choose how specific to make their code. +For example, calling `Eio_main.run` will get you a basic Unix-like environment, +whereas using `Eio_linux.run` provides extra features specific to Linux's io_uring API. +This can then all be tracked in the type system +(dynamic checks are also possible, for more complex code that wants to use specific features only when available). +In contrast, OCaml's `Unix` module provides several functions that simply fail at runtime +on platforms where the function isn't available. + +For dynamic dispatch with subtyping, objects seem to be the best choice: + +- Records and modules require explicit casts when used. + Objects avoid this problem using row-polymorphism. + +- Using records or first-class modules requires frequently allocating. + For example, when you have a `TWO_WAY` module and you want to use it as a `SOURCE`, + OCaml has to make a copy of the module with the fields in the right order. + For records, you have to write the code to do this copying yourself. + Objects don't change their in-memory representation when used at different types. + +- Using records means storing all the methods on every instance, which is wasteful. + Using a GADT adds an extra level of indirection to the value's fields. + An object uses a single block to store the object's fields and a pointer to the shared method table. + +- First-class modules and GADTs are an advanced feature of the language. + The new users we hope to attract to OCaml 5.0 are likely to be familiar with objects already. + +- It is possible to provide base classes with default implementations of some methods. + This can allow adding new operations to the API in future without breaking existing providers. + +In general, simulating objects using other features of the language leads to worse performance +and worse ergonomics than using the language's built-in support. + +However, in order for Eio to be widely accepted in the OCaml community, +we no longer use of objects and instead use a pair of a value and a function for looking up interfaces. +There is a problem here, because each interface has a different type, +so the function's return type depends on its input (the interface ID). +This requires using a GADT. However, GADT's don't support sub-typing. +To get around this, we use an extensible GADT to get the correct typing +(but which will raise an exception if the interface isn't supported), +and then wrap this with a polymorphic variant phantom type to help ensure +it is used correctly. + +This system gives the same performance as using objects and without requiring allocation. +However, care is needed when defining new interfaces, +since the compiler can't check that the resource really implements all the interfaces its phantom type suggests. + +## Results vs Exceptions + +The OCaml standard library uses exceptions to report errors in most cases. +Many libraries instead use the `result` type, which has the advantage of tracking the possible errors in the type system. +However, using `result` is slower, as it requires more allocations, and explicit code to propagate errors. + +As part of the effects work, OCaml is expected to gain a [typed effects][] extension to the type system, +allowing it to track both effects and exceptions statically. +In anticipation of this, the Eio library prefers to use exceptions in most cases, +reserving the use of `result` for cases where the caller is likely to want to handle the problem immediately +rather than propagate it. + +In additional, while result types work well +for functions with a small number of known errors which can be handled at the call-site, +they work poorly for IO errors where there are typically a large and unknown set of possible errors +(depending on the backend). + +[typed effects]: https://www.janestreet.com/tech-talks/effective-programming/ diff --git a/doc/traces/Makefile b/doc/traces/Makefile index ddc8a175e..af474643d 100644 --- a/doc/traces/Makefile +++ b/doc/traces/Makefile @@ -1,4 +1,4 @@ -all: both-posix.svg cancel-posix.svg switch-mock.svg net-posix.svg multicore-posix.svg - -%.svg: %.fxt - eio-trace render "$<" +all: both-posix.svg cancel-posix.svg switch-mock.svg net-posix.svg multicore-posix.svg + +%.svg: %.fxt + eio-trace render "$<" diff --git a/doc/traces/both-posix.svg b/doc/traces/both-posix.svg index 7c584bba1..0bc54a6a8 100644 --- a/doc/traces/both-posix.svg +++ b/doc/traces/both-posix.svg @@ -1,351 +1,351 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/doc/traces/cancel-posix.svg b/doc/traces/cancel-posix.svg index 9e51f1916..ac76e308f 100644 --- a/doc/traces/cancel-posix.svg +++ b/doc/traces/cancel-posix.svg @@ -1,344 +1,344 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/doc/traces/multicore-posix.svg b/doc/traces/multicore-posix.svg index ec12675ad..8007daed6 100644 --- a/doc/traces/multicore-posix.svg +++ b/doc/traces/multicore-posix.svg @@ -1,1490 +1,1490 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/doc/traces/net-posix.svg b/doc/traces/net-posix.svg index 9c534923b..82c9494c3 100644 --- a/doc/traces/net-posix.svg +++ b/doc/traces/net-posix.svg @@ -1,832 +1,832 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/doc/traces/switch-mock.svg b/doc/traces/switch-mock.svg index f8ec6ffa5..19c23e945 100644 --- a/doc/traces/switch-mock.svg +++ b/doc/traces/switch-mock.svg @@ -1,569 +1,569 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/dune b/dune index 5c5a1c5cf..02b266517 100644 --- a/dune +++ b/dune @@ -1,6 +1,6 @@ -(mdx - (package eio_main) - (deps (package eio_main) (package kcas) (env_var "EIO_BACKEND")) - (preludes doc/prelude.ml) - (enabled_if (<> %{os_type} "Win32")) - (files README.md)) +(mdx + (package eio_main) + (deps (package eio_main) (package kcas) (env_var "EIO_BACKEND")) + (preludes doc/prelude.ml) + (enabled_if (<> %{os_type} "Win32")) + (files README.md)) diff --git a/dune-project b/dune-project index 0a291c02e..60bc1de89 100644 --- a/dune-project +++ b/dune-project @@ -1,76 +1,76 @@ -(lang dune 3.9) -(name eio) -(formatting disabled) -(generate_opam_files true) -(source (github ocaml-multicore/eio)) -(license ISC) -(authors "Anil Madhavapeddy" "Thomas Leonard") -(maintainers "anil@recoil.org") -(documentation "https://ocaml-multicore.github.io/eio/") -(package - (name eio) - (synopsis "Effect-based direct-style IO API for OCaml") - (description "An effect-based IO API for multicore OCaml with fibers.") - (conflicts (seq (< 0.3))) - (depends - (ocaml (>= 5.1.0)) - (bigstringaf (>= 0.9.0)) - (cstruct (>= 6.0.1)) - lwt-dllist - (optint (>= 0.1.0)) - (psq (>= 0.2.0)) - (fmt (>= 0.8.9)) - (hmap (>= 0.8.1)) - (domain-local-await (>= 0.1.0)) - (crowbar (and (>= 0.2) :with-test)) - (mtime (>= 2.0.0)) - (mdx (and (>= 2.4.1) :with-test)) - (dscheck (and (>= 0.1.0) :with-test)))) -(package - (name eio_linux) - (synopsis "Eio implementation for Linux using io-uring") - (description "An Eio implementation for Linux using io-uring.") - (allow_empty) ; Work-around for dune bug #6938 - (depends - (alcotest (and (>= 1.7.0) :with-test)) - (eio (= :version)) - (mdx (and (>= 2.4.1) :with-test)) - (logs (and (>= 0.7.0) :with-test)) - (fmt (>= 0.8.9)) - (cmdliner (and (>= 1.1.0) :with-test)) - (uring (>= 0.9)))) -(package - (name eio_posix) - (allow_empty) ; Work-around for dune bug #6938 - (synopsis "Eio implementation for POSIX systems") - (description "An Eio implementation for most Unix-like platforms") - (depends - (eio (= :version)) - (iomux (>= 0.2)) - (mdx (and (>= 2.4.1) :with-test)) - (fmt (>= 0.8.9)))) -(package - (name eio_windows) - (synopsis "Eio implementation for Windows") - (description "An Eio implementation using OCaml's Unix.select") - (allow_empty) ; Work-around for dune bug #6938 - (depends - (eio (= :version)) - (fmt (>= 0.8.9)) - (kcas (and (>= 0.3.0) :with-test)) - (alcotest (and (>= 1.7.0) :with-test)))) -(package - (name eio_main) - (synopsis "Effect-based direct-style IO mainloop for OCaml") - (description "Selects an appropriate Eio backend for the current platform.") - (depends - (mdx (and (>= 2.4.1) :with-test)) - (kcas (and (>= 0.3.0) :with-test)) - (yojson (and (>= 2.0.2) :with-test)) - (eio_linux (and - (= :version) - (= :os "linux") - (or (<> :os-distribution "centos") (> :os-version 7)))) - (eio_posix (and (= :version) (<> :os "win32"))) - (eio_windows (and (= :version) (= :os "win32"))))) -(using mdx 0.2) +(lang dune 3.9) +(name eio) +(formatting disabled) +(generate_opam_files true) +(source (github ocaml-multicore/eio)) +(license ISC) +(authors "Anil Madhavapeddy" "Thomas Leonard") +(maintainers "anil@recoil.org") +(documentation "https://ocaml-multicore.github.io/eio/") +(package + (name eio) + (synopsis "Effect-based direct-style IO API for OCaml") + (description "An effect-based IO API for multicore OCaml with fibers.") + (conflicts (seq (< 0.3))) + (depends + (ocaml (>= 5.1.0)) + (bigstringaf (>= 0.9.0)) + (cstruct (>= 6.0.1)) + lwt-dllist + (optint (>= 0.1.0)) + (psq (>= 0.2.0)) + (fmt (>= 0.8.9)) + (hmap (>= 0.8.1)) + (domain-local-await (>= 0.1.0)) + (crowbar (and (>= 0.2) :with-test)) + (mtime (>= 2.0.0)) + (mdx (and (>= 2.4.1) :with-test)) + (dscheck (and (>= 0.1.0) :with-test)))) +(package + (name eio_linux) + (synopsis "Eio implementation for Linux using io-uring") + (description "An Eio implementation for Linux using io-uring.") + (allow_empty) ; Work-around for dune bug #6938 + (depends + (alcotest (and (>= 1.7.0) :with-test)) + (eio (= :version)) + (mdx (and (>= 2.4.1) :with-test)) + (logs (and (>= 0.7.0) :with-test)) + (fmt (>= 0.8.9)) + (cmdliner (and (>= 1.1.0) :with-test)) + (uring (>= 0.9)))) +(package + (name eio_posix) + (allow_empty) ; Work-around for dune bug #6938 + (synopsis "Eio implementation for POSIX systems") + (description "An Eio implementation for most Unix-like platforms") + (depends + (eio (= :version)) + (iomux (>= 0.2)) + (mdx (and (>= 2.4.1) :with-test)) + (fmt (>= 0.8.9)))) +(package + (name eio_windows) + (synopsis "Eio implementation for Windows") + (description "An Eio implementation using OCaml's Unix.select") + (allow_empty) ; Work-around for dune bug #6938 + (depends + (eio (= :version)) + (fmt (>= 0.8.9)) + (kcas (and (>= 0.3.0) :with-test)) + (alcotest (and (>= 1.7.0) :with-test)))) +(package + (name eio_main) + (synopsis "Effect-based direct-style IO mainloop for OCaml") + (description "Selects an appropriate Eio backend for the current platform.") + (depends + (mdx (and (>= 2.4.1) :with-test)) + (kcas (and (>= 0.3.0) :with-test)) + (yojson (and (>= 2.0.2) :with-test)) + (eio_linux (and + (= :version) + (= :os "linux") + (or (<> :os-distribution "centos") (> :os-version 7)))) + (eio_posix (and (= :version) (<> :os "win32"))) + (eio_windows (and (= :version) (= :os "win32"))))) +(using mdx 0.2) diff --git a/eio.opam b/eio.opam index 78109b129..16dc2187d 100644 --- a/eio.opam +++ b/eio.opam @@ -1,45 +1,45 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "Effect-based direct-style IO API for OCaml" -description: "An effect-based IO API for multicore OCaml with fibers." -maintainer: ["anil@recoil.org"] -authors: ["Anil Madhavapeddy" "Thomas Leonard"] -license: "ISC" -homepage: "https://github.com/ocaml-multicore/eio" -doc: "https://ocaml-multicore.github.io/eio/" -bug-reports: "https://github.com/ocaml-multicore/eio/issues" -depends: [ - "dune" {>= "3.9"} - "ocaml" {>= "5.1.0"} - "bigstringaf" {>= "0.9.0"} - "cstruct" {>= "6.0.1"} - "lwt-dllist" - "optint" {>= "0.1.0"} - "psq" {>= "0.2.0"} - "fmt" {>= "0.8.9"} - "hmap" {>= "0.8.1"} - "domain-local-await" {>= "0.1.0"} - "crowbar" {>= "0.2" & with-test} - "mtime" {>= "2.0.0"} - "mdx" {>= "2.4.1" & with-test} - "dscheck" {>= "0.1.0" & with-test} - "odoc" {with-doc} -] -conflicts: [ - "seq" {< "0.3"} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/ocaml-multicore/eio.git" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Effect-based direct-style IO API for OCaml" +description: "An effect-based IO API for multicore OCaml with fibers." +maintainer: ["anil@recoil.org"] +authors: ["Anil Madhavapeddy" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/ocaml-multicore/eio" +doc: "https://ocaml-multicore.github.io/eio/" +bug-reports: "https://github.com/ocaml-multicore/eio/issues" +depends: [ + "dune" {>= "3.9"} + "ocaml" {>= "5.1.0"} + "bigstringaf" {>= "0.9.0"} + "cstruct" {>= "6.0.1"} + "lwt-dllist" + "optint" {>= "0.1.0"} + "psq" {>= "0.2.0"} + "fmt" {>= "0.8.9"} + "hmap" {>= "0.8.1"} + "domain-local-await" {>= "0.1.0"} + "crowbar" {>= "0.2" & with-test} + "mtime" {>= "2.0.0"} + "mdx" {>= "2.4.1" & with-test} + "dscheck" {>= "0.1.0" & with-test} + "odoc" {with-doc} +] +conflicts: [ + "seq" {< "0.3"} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-multicore/eio.git" diff --git a/eio_linux.opam b/eio_linux.opam index c4ab67004..f60b69823 100644 --- a/eio_linux.opam +++ b/eio_linux.opam @@ -1,37 +1,37 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "Eio implementation for Linux using io-uring" -description: "An Eio implementation for Linux using io-uring." -maintainer: ["anil@recoil.org"] -authors: ["Anil Madhavapeddy" "Thomas Leonard"] -license: "ISC" -homepage: "https://github.com/ocaml-multicore/eio" -doc: "https://ocaml-multicore.github.io/eio/" -bug-reports: "https://github.com/ocaml-multicore/eio/issues" -depends: [ - "dune" {>= "3.9"} - "alcotest" {>= "1.7.0" & with-test} - "eio" {= version} - "mdx" {>= "2.4.1" & with-test} - "logs" {>= "0.7.0" & with-test} - "fmt" {>= "0.8.9"} - "cmdliner" {>= "1.1.0" & with-test} - "uring" {>= "0.9"} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/ocaml-multicore/eio.git" -available: [os = "linux"] +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Eio implementation for Linux using io-uring" +description: "An Eio implementation for Linux using io-uring." +maintainer: ["anil@recoil.org"] +authors: ["Anil Madhavapeddy" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/ocaml-multicore/eio" +doc: "https://ocaml-multicore.github.io/eio/" +bug-reports: "https://github.com/ocaml-multicore/eio/issues" +depends: [ + "dune" {>= "3.9"} + "alcotest" {>= "1.7.0" & with-test} + "eio" {= version} + "mdx" {>= "2.4.1" & with-test} + "logs" {>= "0.7.0" & with-test} + "fmt" {>= "0.8.9"} + "cmdliner" {>= "1.1.0" & with-test} + "uring" {>= "0.9"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-multicore/eio.git" +available: [os = "linux"] diff --git a/eio_linux.opam.template b/eio_linux.opam.template index e9b1560db..0ed4d6e4b 100644 --- a/eio_linux.opam.template +++ b/eio_linux.opam.template @@ -1 +1 @@ -available: [os = "linux"] +available: [os = "linux"] diff --git a/eio_main.opam b/eio_main.opam index 1d3cad8a4..22a4b0cd6 100644 --- a/eio_main.opam +++ b/eio_main.opam @@ -1,38 +1,38 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "Effect-based direct-style IO mainloop for OCaml" -description: "Selects an appropriate Eio backend for the current platform." -maintainer: ["anil@recoil.org"] -authors: ["Anil Madhavapeddy" "Thomas Leonard"] -license: "ISC" -homepage: "https://github.com/ocaml-multicore/eio" -doc: "https://ocaml-multicore.github.io/eio/" -bug-reports: "https://github.com/ocaml-multicore/eio/issues" -depends: [ - "dune" {>= "3.9"} - "mdx" {>= "2.4.1" & with-test} - "kcas" {>= "0.3.0" & with-test} - "yojson" {>= "2.0.2" & with-test} - "eio_linux" - {= version & os = "linux" & - (os-distribution != "centos" | os-version > "7")} - "eio_posix" {= version & os != "win32"} - "eio_windows" {= version & os = "win32"} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/ocaml-multicore/eio.git" -x-ci-accept-failures: ["macos-homebrew"] +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Effect-based direct-style IO mainloop for OCaml" +description: "Selects an appropriate Eio backend for the current platform." +maintainer: ["anil@recoil.org"] +authors: ["Anil Madhavapeddy" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/ocaml-multicore/eio" +doc: "https://ocaml-multicore.github.io/eio/" +bug-reports: "https://github.com/ocaml-multicore/eio/issues" +depends: [ + "dune" {>= "3.9"} + "mdx" {>= "2.4.1" & with-test} + "kcas" {>= "0.3.0" & with-test} + "yojson" {>= "2.0.2" & with-test} + "eio_linux" + {= version & os = "linux" & + (os-distribution != "centos" | os-version > "7")} + "eio_posix" {= version & os != "win32"} + "eio_windows" {= version & os = "win32"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-multicore/eio.git" +x-ci-accept-failures: ["macos-homebrew"] diff --git a/eio_main.opam.template b/eio_main.opam.template index 74cb2a4df..cce8c4c9b 100644 --- a/eio_main.opam.template +++ b/eio_main.opam.template @@ -1 +1 @@ -x-ci-accept-failures: ["macos-homebrew"] +x-ci-accept-failures: ["macos-homebrew"] diff --git a/eio_posix.opam b/eio_posix.opam index aeae42e0f..27925c690 100644 --- a/eio_posix.opam +++ b/eio_posix.opam @@ -1,33 +1,33 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "Eio implementation for POSIX systems" -description: "An Eio implementation for most Unix-like platforms" -maintainer: ["anil@recoil.org"] -authors: ["Anil Madhavapeddy" "Thomas Leonard"] -license: "ISC" -homepage: "https://github.com/ocaml-multicore/eio" -doc: "https://ocaml-multicore.github.io/eio/" -bug-reports: "https://github.com/ocaml-multicore/eio/issues" -depends: [ - "dune" {>= "3.9"} - "eio" {= version} - "iomux" {>= "0.2"} - "mdx" {>= "2.4.1" & with-test} - "fmt" {>= "0.8.9"} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/ocaml-multicore/eio.git" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Eio implementation for POSIX systems" +description: "An Eio implementation for most Unix-like platforms" +maintainer: ["anil@recoil.org"] +authors: ["Anil Madhavapeddy" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/ocaml-multicore/eio" +doc: "https://ocaml-multicore.github.io/eio/" +bug-reports: "https://github.com/ocaml-multicore/eio/issues" +depends: [ + "dune" {>= "3.9"} + "eio" {= version} + "iomux" {>= "0.2"} + "mdx" {>= "2.4.1" & with-test} + "fmt" {>= "0.8.9"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-multicore/eio.git" diff --git a/eio_windows.opam b/eio_windows.opam index b24efa546..5598c616d 100644 --- a/eio_windows.opam +++ b/eio_windows.opam @@ -1,34 +1,34 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "Eio implementation for Windows" -description: "An Eio implementation using OCaml's Unix.select" -maintainer: ["anil@recoil.org"] -authors: ["Anil Madhavapeddy" "Thomas Leonard"] -license: "ISC" -homepage: "https://github.com/ocaml-multicore/eio" -doc: "https://ocaml-multicore.github.io/eio/" -bug-reports: "https://github.com/ocaml-multicore/eio/issues" -depends: [ - "dune" {>= "3.9"} - "eio" {= version} - "fmt" {>= "0.8.9"} - "kcas" {>= "0.3.0" & with-test} - "alcotest" {>= "1.7.0" & with-test} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/ocaml-multicore/eio.git" -#available: [os = "win32"] +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Eio implementation for Windows" +description: "An Eio implementation using OCaml's Unix.select" +maintainer: ["anil@recoil.org"] +authors: ["Anil Madhavapeddy" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/ocaml-multicore/eio" +doc: "https://ocaml-multicore.github.io/eio/" +bug-reports: "https://github.com/ocaml-multicore/eio/issues" +depends: [ + "dune" {>= "3.9"} + "eio" {= version} + "fmt" {>= "0.8.9"} + "kcas" {>= "0.3.0" & with-test} + "alcotest" {>= "1.7.0" & with-test} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-multicore/eio.git" +#available: [os = "win32"] diff --git a/eio_windows.opam.template b/eio_windows.opam.template index 8fe8e3252..85b7aaa2e 100644 --- a/eio_windows.opam.template +++ b/eio_windows.opam.template @@ -1 +1 @@ -#available: [os = "win32"] +#available: [os = "win32"] diff --git a/examples/both/dune b/examples/both/dune index fb95515c7..6dfa1cd94 100644 --- a/examples/both/dune +++ b/examples/both/dune @@ -1,3 +1,3 @@ -(executable - (name main) - (libraries eio_main)) +(executable + (name main) + (libraries eio_main)) diff --git a/examples/both/main.ml b/examples/both/main.ml index c8bebc978..bacb7660e 100644 --- a/examples/both/main.ml +++ b/examples/both/main.ml @@ -1,7 +1,7 @@ -open Eio.Std - -let () = - Eio_main.run @@ fun _env -> - Fiber.both - (fun () -> for x = 1 to 3 do traceln "x = %d" x; Fiber.yield () done) - (fun () -> for y = 1 to 3 do traceln "y = %d" y; Fiber.yield () done) +open Eio.Std + +let () = + Eio_main.run @@ fun _env -> + Fiber.both + (fun () -> for x = 1 to 3 do traceln "x = %d" x; Fiber.yield () done) + (fun () -> for y = 1 to 3 do traceln "y = %d" y; Fiber.yield () done) diff --git a/examples/capsicum/dune b/examples/capsicum/dune index fb95515c7..6dfa1cd94 100644 --- a/examples/capsicum/dune +++ b/examples/capsicum/dune @@ -1,3 +1,3 @@ -(executable - (name main) - (libraries eio_main)) +(executable + (name main) + (libraries eio_main)) diff --git a/examples/capsicum/main.ml b/examples/capsicum/main.ml index f6fe71f1f..bb0964553 100644 --- a/examples/capsicum/main.ml +++ b/examples/capsicum/main.ml @@ -1,40 +1,40 @@ -open Eio.Std - -let ( / ) = Eio.Path.( / ) - -let test_eio dir = - traceln "Using the file-system via the directory resource works:"; - let test_file = dir / "capsicum-test.txt" in - traceln "Writing %a..." Eio.Path.pp test_file; - Eio.Path.save test_file "A test file" ~create:(`Exclusive 0o644); - traceln "Read: %S" (Eio.Path.load test_file); - Eio.Path.unlink test_file - -let test_legacy () = - traceln "Bypassing Eio and accessing other resources should fail in Capsicum mode:"; - let ch = open_in "/etc/passwd" in - let len = in_channel_length ch in - let data = really_input_string ch len in - close_in ch; - traceln "Was able to read /etc/passwd:@.%s" (String.trim data) - -let () = - Eio_main.run @@ fun env -> - (* Parse command-line arguments *) - let path = - match Sys.argv with - | [| _; dir |] -> Eio.Stdenv.fs env / dir - | _ -> failwith "Usage: main.exe DIR" - in - if not (Eio.Path.is_directory path) then Fmt.failwith "%a is not a directory" Eio.Path.pp path; - (* Get access to resources before calling cap_enter: *) - Eio.Path.with_open_dir path @@ fun dir -> - traceln "Opened directory %a" Eio.Path.pp path; - (* Switch to capability mode, if possible: *) - begin match Eio_unix.Cap.enter () with - | Ok () -> traceln "Capsicum mode enabled" - | Error `Not_supported -> traceln "!! CAPSICUM PROTECTION NOT AVAILABLE !!" - end; - (* Run tests: *) - test_eio dir; - test_legacy () +open Eio.Std + +let ( / ) = Eio.Path.( / ) + +let test_eio dir = + traceln "Using the file-system via the directory resource works:"; + let test_file = dir / "capsicum-test.txt" in + traceln "Writing %a..." Eio.Path.pp test_file; + Eio.Path.save test_file "A test file" ~create:(`Exclusive 0o644); + traceln "Read: %S" (Eio.Path.load test_file); + Eio.Path.unlink test_file + +let test_legacy () = + traceln "Bypassing Eio and accessing other resources should fail in Capsicum mode:"; + let ch = open_in "/etc/passwd" in + let len = in_channel_length ch in + let data = really_input_string ch len in + close_in ch; + traceln "Was able to read /etc/passwd:@.%s" (String.trim data) + +let () = + Eio_main.run @@ fun env -> + (* Parse command-line arguments *) + let path = + match Sys.argv with + | [| _; dir |] -> Eio.Stdenv.fs env / dir + | _ -> failwith "Usage: main.exe DIR" + in + if not (Eio.Path.is_directory path) then Fmt.failwith "%a is not a directory" Eio.Path.pp path; + (* Get access to resources before calling cap_enter: *) + Eio.Path.with_open_dir path @@ fun dir -> + traceln "Opened directory %a" Eio.Path.pp path; + (* Switch to capability mode, if possible: *) + begin match Eio_unix.Cap.enter () with + | Ok () -> traceln "Capsicum mode enabled" + | Error `Not_supported -> traceln "!! CAPSICUM PROTECTION NOT AVAILABLE !!" + end; + (* Run tests: *) + test_eio dir; + test_legacy () diff --git a/examples/fs/dune b/examples/fs/dune index fb95515c7..6dfa1cd94 100644 --- a/examples/fs/dune +++ b/examples/fs/dune @@ -1,3 +1,3 @@ -(executable - (name main) - (libraries eio_main)) +(executable + (name main) + (libraries eio_main)) diff --git a/examples/fs/main.ml b/examples/fs/main.ml index ef5b4ab0a..253529bff 100644 --- a/examples/fs/main.ml +++ b/examples/fs/main.ml @@ -1,32 +1,32 @@ -(* Walk the directory tree rooted at the current directory, - showing a summary for any .mli files. *) - -let ( / ) = Eio.Path.( / ) - -let is_doc_comment = String.starts_with ~prefix:"(** " - -(* Print the first line of [t]'s doc-comment, if any *) -let scan_mli t f = - Eio.Path.with_lines t (fun lines -> - Seq.find is_doc_comment lines - |> Option.iter (fun line -> - let stop = String.index_from_opt line 4 '*' |> Option.value ~default:(String.length line) in - Format.fprintf f "%a: %s@." Eio.Path.pp t (String.sub line 4 (stop - 4)) - ) - ) - -(* Walk the tree rooted at [t] and scan any .mli files found. *) -let rec scan t f = - match Eio.Path.kind ~follow:false t with - | `Directory -> - Eio.Path.read_dir t |> List.iter (function - | "_build" | "_opam" -> () (* Don't examine these directories *) - | item when String.starts_with ~prefix:"." item -> () (* Skip hidden items *) - | item -> scan (t / item) f - ) - | `Regular_file when Filename.check_suffix (snd t) ".mli" -> scan_mli t f - | _ -> () - -let () = - Eio_main.run @@ fun env -> - scan (Eio.Stdenv.cwd env) Format.std_formatter +(* Walk the directory tree rooted at the current directory, + showing a summary for any .mli files. *) + +let ( / ) = Eio.Path.( / ) + +let is_doc_comment = String.starts_with ~prefix:"(** " + +(* Print the first line of [t]'s doc-comment, if any *) +let scan_mli t f = + Eio.Path.with_lines t (fun lines -> + Seq.find is_doc_comment lines + |> Option.iter (fun line -> + let stop = String.index_from_opt line 4 '*' |> Option.value ~default:(String.length line) in + Format.fprintf f "%a: %s@." Eio.Path.pp t (String.sub line 4 (stop - 4)) + ) + ) + +(* Walk the tree rooted at [t] and scan any .mli files found. *) +let rec scan t f = + match Eio.Path.kind ~follow:false t with + | `Directory -> + Eio.Path.read_dir t |> List.iter (function + | "_build" | "_opam" -> () (* Don't examine these directories *) + | item when String.starts_with ~prefix:"." item -> () (* Skip hidden items *) + | item -> scan (t / item) f + ) + | `Regular_file when Filename.check_suffix (snd t) ".mli" -> scan_mli t f + | _ -> () + +let () = + Eio_main.run @@ fun env -> + scan (Eio.Stdenv.cwd env) Format.std_formatter diff --git a/examples/hello/dune b/examples/hello/dune index fb95515c7..6dfa1cd94 100644 --- a/examples/hello/dune +++ b/examples/hello/dune @@ -1,3 +1,3 @@ -(executable - (name main) - (libraries eio_main)) +(executable + (name main) + (libraries eio_main)) diff --git a/examples/hello/main.ml b/examples/hello/main.ml index 3603f2118..ec23dfebc 100644 --- a/examples/hello/main.ml +++ b/examples/hello/main.ml @@ -1,6 +1,6 @@ -let main ~stdout = - Eio.Flow.copy_string "Hello, world!\n" stdout - -let () = - Eio_main.run @@ fun env -> - main ~stdout:(Eio.Stdenv.stdout env) +let main ~stdout = + Eio.Flow.copy_string "Hello, world!\n" stdout + +let () = + Eio_main.run @@ fun env -> + main ~stdout:(Eio.Stdenv.stdout env) diff --git a/examples/net/client.ml b/examples/net/client.ml index e042e8500..deb0fd49c 100644 --- a/examples/net/client.ml +++ b/examples/net/client.ml @@ -1,21 +1,21 @@ -open Eio.Std - -(* Prefix all trace output with "client: " *) -let traceln fmt = traceln ("client: " ^^ fmt) - -module Read = Eio.Buf_read -module Write = Eio.Buf_write - -(* Connect to [addr] on [net], send a message and then read the reply. *) -let run ~net ~addr = - Switch.run ~name:"client" @@ fun sw -> - traceln "Connecting to server at %a..." Eio.Net.Sockaddr.pp addr; - let flow = Eio.Net.connect ~sw net addr in - (* We use a buffered writer here so we can create the message in multiple - steps but still send it efficiently as a single packet: *) - Write.with_flow flow @@ fun to_server -> - Write.string to_server "Hello"; - Write.char to_server ' '; - Write.string to_server "from client\n"; - let reply = Read.(parse_exn take_all) flow ~max_size:100 in - traceln "Got reply %S" reply +open Eio.Std + +(* Prefix all trace output with "client: " *) +let traceln fmt = traceln ("client: " ^^ fmt) + +module Read = Eio.Buf_read +module Write = Eio.Buf_write + +(* Connect to [addr] on [net], send a message and then read the reply. *) +let run ~net ~addr = + Switch.run ~name:"client" @@ fun sw -> + traceln "Connecting to server at %a..." Eio.Net.Sockaddr.pp addr; + let flow = Eio.Net.connect ~sw net addr in + (* We use a buffered writer here so we can create the message in multiple + steps but still send it efficiently as a single packet: *) + Write.with_flow flow @@ fun to_server -> + Write.string to_server "Hello"; + Write.char to_server ' '; + Write.string to_server "from client\n"; + let reply = Read.(parse_exn take_all) flow ~max_size:100 in + traceln "Got reply %S" reply diff --git a/examples/net/dune b/examples/net/dune index fb95515c7..6dfa1cd94 100644 --- a/examples/net/dune +++ b/examples/net/dune @@ -1,3 +1,3 @@ -(executable - (name main) - (libraries eio_main)) +(executable + (name main) + (libraries eio_main)) diff --git a/examples/net/main.ml b/examples/net/main.ml index 78715aa9d..649c42852 100644 --- a/examples/net/main.ml +++ b/examples/net/main.ml @@ -1,20 +1,20 @@ -open Eio.Std - -let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8080) - -(* Run a server and a test client, communicating using [net]. *) -let main ~net = - Switch.run ~name:"main" @@ fun sw -> - (* We create the listening socket first so that we can be sure it is ready - as soon as the client wants to use it. *) - let listening_socket = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in - (* Start the server running in a new fiber. - Using [fork_daemon] here means that it will be stopped once the client is done - (we don't wait for it to finish because it will keep accepting new connections forever). *) - Fiber.fork_daemon ~sw (fun () -> Server.run listening_socket); - (* Test the server: *) - Client.run ~net ~addr - -let () = - Eio_main.run @@ fun env -> - main ~net:(Eio.Stdenv.net env) +open Eio.Std + +let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8080) + +(* Run a server and a test client, communicating using [net]. *) +let main ~net = + Switch.run ~name:"main" @@ fun sw -> + (* We create the listening socket first so that we can be sure it is ready + as soon as the client wants to use it. *) + let listening_socket = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in + (* Start the server running in a new fiber. + Using [fork_daemon] here means that it will be stopped once the client is done + (we don't wait for it to finish because it will keep accepting new connections forever). *) + Fiber.fork_daemon ~sw (fun () -> Server.run listening_socket); + (* Test the server: *) + Client.run ~net ~addr + +let () = + Eio_main.run @@ fun env -> + main ~net:(Eio.Stdenv.net env) diff --git a/examples/net/server.ml b/examples/net/server.ml index 814224315..43d504ad6 100644 --- a/examples/net/server.ml +++ b/examples/net/server.ml @@ -1,24 +1,24 @@ -open Eio.Std - -(* Prefix all trace output with "server: " *) -let traceln fmt = traceln ("server: " ^^ fmt) - -module Read = Eio.Buf_read - -(* Read one line from [client] and respond with "OK". *) -let handle_client flow addr = - traceln "Accepted connection from %a" Eio.Net.Sockaddr.pp addr; - (* We use a buffered reader because we may need to combine multiple reads - to get a single line (or we may get multiple lines in a single read, - although here we only use the first one). *) - let from_client = Read.of_flow flow ~max_size:100 in - traceln "Received: %S" (Read.line from_client); - Eio.Flow.copy_string "OK" flow - -(* Accept incoming client connections on [socket]. - We can handle multiple clients at the same time. - Never returns (but can be cancelled). *) -let run socket = - Eio.Net.run_server socket handle_client - ~on_error:(traceln "Error handling connection: %a" Fmt.exn) - ~max_connections:1000 +open Eio.Std + +(* Prefix all trace output with "server: " *) +let traceln fmt = traceln ("server: " ^^ fmt) + +module Read = Eio.Buf_read + +(* Read one line from [client] and respond with "OK". *) +let handle_client flow addr = + traceln "Accepted connection from %a" Eio.Net.Sockaddr.pp addr; + (* We use a buffered reader because we may need to combine multiple reads + to get a single line (or we may get multiple lines in a single read, + although here we only use the first one). *) + let from_client = Read.of_flow flow ~max_size:100 in + traceln "Received: %S" (Read.line from_client); + Eio.Flow.copy_string "OK" flow + +(* Accept incoming client connections on [socket]. + We can handle multiple clients at the same time. + Never returns (but can be cancelled). *) +let run socket = + Eio.Net.run_server socket handle_client + ~on_error:(traceln "Error handling connection: %a" Fmt.exn) + ~max_connections:1000 diff --git a/examples/signals/dune b/examples/signals/dune index fb95515c7..6dfa1cd94 100644 --- a/examples/signals/dune +++ b/examples/signals/dune @@ -1,3 +1,3 @@ -(executable - (name main) - (libraries eio_main)) +(executable + (name main) + (libraries eio_main)) diff --git a/examples/signals/main.ml b/examples/signals/main.ml index e0f626411..83092dadb 100644 --- a/examples/signals/main.ml +++ b/examples/signals/main.ml @@ -1,28 +1,28 @@ -open Eio.Std - -let load_config () = - (* A real system would load the file and then pass it to the running service - somehow, but we're just demonstrating signal handling so just sleep to - simulate some time taken to load the new configuration. *) - Eio_unix.sleep 2.0 - -(* $MDX part-begin=main *) -let main ~config_changed = - Eio.Condition.loop_no_mutex config_changed (fun () -> - traceln "Reading configuration ('kill -SIGHUP %d' to reload)..." (Unix.getpid ()); - load_config (); - traceln "Finished reading configuration"; - None (* Keep waiting for futher changes *) - ) -(* $MDX part-end *) - -let () = - Eio_main.run @@ fun _env -> - let config_changed = Eio.Condition.create () in - let handle_signal (_signum : int) = - (* Warning: we're in a signal handler now. - Most operations are unsafe here, except for Eio.Condition.broadcast! *) - Eio.Condition.broadcast config_changed - in - Sys.set_signal Sys.sighup (Signal_handle handle_signal); - main ~config_changed +open Eio.Std + +let load_config () = + (* A real system would load the file and then pass it to the running service + somehow, but we're just demonstrating signal handling so just sleep to + simulate some time taken to load the new configuration. *) + Eio_unix.sleep 2.0 + +(* $MDX part-begin=main *) +let main ~config_changed = + Eio.Condition.loop_no_mutex config_changed (fun () -> + traceln "Reading configuration ('kill -SIGHUP %d' to reload)..." (Unix.getpid ()); + load_config (); + traceln "Finished reading configuration"; + None (* Keep waiting for futher changes *) + ) +(* $MDX part-end *) + +let () = + Eio_main.run @@ fun _env -> + let config_changed = Eio.Condition.create () in + let handle_signal (_signum : int) = + (* Warning: we're in a signal handler now. + Most operations are unsafe here, except for Eio.Condition.broadcast! *) + Eio.Condition.broadcast config_changed + in + Sys.set_signal Sys.sighup (Signal_handle handle_signal); + main ~config_changed diff --git a/examples/trace/dune b/examples/trace/dune index da5d8293d..ef8e9ddeb 100644 --- a/examples/trace/dune +++ b/examples/trace/dune @@ -1,3 +1,3 @@ -(executable - (name main) - (libraries eio.runtime_events eio_main)) +(executable + (name main) + (libraries eio.runtime_events eio_main)) diff --git a/examples/trace/main.ml b/examples/trace/main.ml index 658526345..8dc5d3f58 100644 --- a/examples/trace/main.ml +++ b/examples/trace/main.ml @@ -1,69 +1,69 @@ -(* This example shows how to trace an Eio program. - - The [main] function creates a listening socket and has a client connect and send a message, - which is handled by a server fiber. - - At the same time, another fiber is displaying trace events. - For simplicity, this example runs the tracer in the same process as the program being traced, - but typically they would be separate processes. *) - -open Eio.Std - -let callbacks = - Runtime_events.Callbacks.create () - (* Uncomment to trace GC events too: *) -(* - ~runtime_begin:(handle (fun f phase -> Fmt.pf f "begin %s" (Runtime_events.runtime_phase_name phase))) - ~runtime_end:(handle (fun f phase -> Fmt.pf f "end %s" (Runtime_events.runtime_phase_name phase))) -*) - ~lost_events:(fun ring n -> traceln "ring %d lost %d events" ring n) - |> Eio_runtime_events.add_callbacks - (fun ring ts e -> - (* Note: don't use traceln here, as it will just generate more log events! *) - Fmt.epr "%9Ld:ring %d: %a@." (Runtime_events.Timestamp.to_int64 ts) ring Eio_runtime_events.pp_event e - ) - (* (see lib_eio/runtime_events/eio_runtime_events.mli for more event types) *) - -(* Read and display trace events from [cursor] until [finished]. *) -let trace ~finished (clock, delay) cursor = - traceln "tracer: starting"; - let rec aux () = - let _ : int = Runtime_events.read_poll cursor callbacks None in - if !finished then ( - traceln "tracer: stopping" - ) else ( - Eio.Time.Mono.sleep clock delay; - aux () - ) - in - aux () - -(* The program to be traced. *) -let main net = - Switch.run ~name:"main" @@ fun sw -> - let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8123) in - let s = Eio.Net.listen ~sw ~backlog:1 ~reuse_addr:true net addr in - Fiber.both - (fun () -> - traceln "server: starting"; - let c, _addr = Eio.Net.accept ~sw s in - traceln "server: got connection from client"; - let msg = Eio.Flow.read_all c in - traceln "server: read %S from socket" msg - ) - (fun () -> - traceln "client: connecting socket..."; - let c = Eio.Net.connect ~sw net addr in - Eio.Flow.copy_string "Hello" c; - Eio.Flow.close c - ) - -(* Enable tracing then run the [main] and [trace] fibers. *) -let () = - Runtime_events.start (); - let cursor = Runtime_events.create_cursor None in (* Create a in-process cursor *) - Eio_main.run @@ fun env -> - let finished = ref false in - Fiber.both - (fun () -> trace ~finished (env#mono_clock, 0.01) cursor) - (fun () -> main env#net; finished := true) +(* This example shows how to trace an Eio program. + + The [main] function creates a listening socket and has a client connect and send a message, + which is handled by a server fiber. + + At the same time, another fiber is displaying trace events. + For simplicity, this example runs the tracer in the same process as the program being traced, + but typically they would be separate processes. *) + +open Eio.Std + +let callbacks = + Runtime_events.Callbacks.create () + (* Uncomment to trace GC events too: *) +(* + ~runtime_begin:(handle (fun f phase -> Fmt.pf f "begin %s" (Runtime_events.runtime_phase_name phase))) + ~runtime_end:(handle (fun f phase -> Fmt.pf f "end %s" (Runtime_events.runtime_phase_name phase))) +*) + ~lost_events:(fun ring n -> traceln "ring %d lost %d events" ring n) + |> Eio_runtime_events.add_callbacks + (fun ring ts e -> + (* Note: don't use traceln here, as it will just generate more log events! *) + Fmt.epr "%9Ld:ring %d: %a@." (Runtime_events.Timestamp.to_int64 ts) ring Eio_runtime_events.pp_event e + ) + (* (see lib_eio/runtime_events/eio_runtime_events.mli for more event types) *) + +(* Read and display trace events from [cursor] until [finished]. *) +let trace ~finished (clock, delay) cursor = + traceln "tracer: starting"; + let rec aux () = + let _ : int = Runtime_events.read_poll cursor callbacks None in + if !finished then ( + traceln "tracer: stopping" + ) else ( + Eio.Time.Mono.sleep clock delay; + aux () + ) + in + aux () + +(* The program to be traced. *) +let main net = + Switch.run ~name:"main" @@ fun sw -> + let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8123) in + let s = Eio.Net.listen ~sw ~backlog:1 ~reuse_addr:true net addr in + Fiber.both + (fun () -> + traceln "server: starting"; + let c, _addr = Eio.Net.accept ~sw s in + traceln "server: got connection from client"; + let msg = Eio.Flow.read_all c in + traceln "server: read %S from socket" msg + ) + (fun () -> + traceln "client: connecting socket..."; + let c = Eio.Net.connect ~sw net addr in + Eio.Flow.copy_string "Hello" c; + Eio.Flow.close c + ) + +(* Enable tracing then run the [main] and [trace] fibers. *) +let () = + Runtime_events.start (); + let cursor = Runtime_events.create_cursor None in (* Create a in-process cursor *) + Eio_main.run @@ fun env -> + let finished = ref false in + Fiber.both + (fun () -> trace ~finished (env#mono_clock, 0.01) cursor) + (fun () -> main env#net; finished := true) diff --git a/fuzz/dune b/fuzz/dune index 9462c1399..ada1c0996 100644 --- a/fuzz/dune +++ b/fuzz/dune @@ -1,4 +1,4 @@ -(tests - (package eio) - (libraries cstruct crowbar fmt eio eio.mock eio.unix) - (names fuzz_buf_read fuzz_buf_write fuzz_inherit_fds)) +(tests + (package eio) + (libraries cstruct crowbar fmt eio eio.mock eio.unix) + (names fuzz_buf_read fuzz_buf_write fuzz_inherit_fds)) diff --git a/fuzz/fuzz_buf_read.ml b/fuzz/fuzz_buf_read.ml index 2dec1a914..27d00c84c 100644 --- a/fuzz/fuzz_buf_read.ml +++ b/fuzz/fuzz_buf_read.ml @@ -1,268 +1,268 @@ -(* This file contains a simple model of `Buf_read`, using a single string. - It runs random operations on both the model and the real buffer and - checks they always give the same result. *) - -module String = struct - include String - - let rec find ?(start=0) p t = - if start = String.length t then None - else if p t.[start] then Some start - else find ~start:(succ start) p t - - let drop t n = String.sub t n (String.length t - n) - - let cut ~sep t = - match String.index_opt t sep with - | None -> None - | Some i -> Some (String.sub t 0 i, drop t (i + 1)) -end - -let debug = false - -module Buf_read = Eio.Buf_read -exception Buffer_limit_exceeded = Buf_read.Buffer_limit_exceeded - -let initial_size = 10 -let max_size = 100 - -module Mock_flow = struct - type t = string list ref - - let rec single_read t buf = - match !t with - | [] -> - raise End_of_file - | "" :: xs -> - t := xs; - single_read t buf - | x :: xs -> - let len = min (Cstruct.length buf) (String.length x) in - Cstruct.blit_from_string x 0 buf 0 len; - let x' = String.drop x len in - t := (if x' = "" then xs else x' :: xs); - len - - let read_methods = [] -end - -let mock_flow = - let ops = Eio.Flow.Pi.source (module Mock_flow) in - fun chunks -> Eio.Resource.T (ref chunks, ops) - -module Model = struct - type t = string ref - - let of_chunks chunks = ref (String.concat "" chunks) - - let take_all t = - let old = !t in - if String.length old >= max_size then raise Buffer_limit_exceeded; - t := ""; - old - - let line t = - match String.cut ~sep:'\n' !t with - | Some (line, rest) -> - if String.length line >= max_size then raise Buffer_limit_exceeded; - t := rest; - if String.ends_with ~suffix:"\r" line then String.sub line 0 (String.length line - 1) - else line - | None when !t = "" -> raise End_of_file - | None when String.length !t >= max_size -> raise Buffer_limit_exceeded - | None -> take_all t - - let any_char t = - match !t with - | "" -> raise End_of_file - | s -> - t := String.drop s 1; - s.[0] - - let peek_char t = - match !t with - | "" -> None - | s -> Some (s.[0]) - - let consume t n = - t := String.drop !t n - - let char c t = - match peek_char t with - | Some c2 when c = c2 -> consume t 1 - | Some _ -> failwith "char" - | None -> raise End_of_file - - let string s t = - if debug then Fmt.pr "string %S@." s; - let len_t = String.length !t in - let prefix = String.sub s 0 (min len_t (String.length s)) in - if not (String.starts_with ~prefix !t) then failwith "string"; - if String.length s > max_size then raise Buffer_limit_exceeded; - if String.starts_with ~prefix:s !t then consume t (String.length s) - else raise End_of_file - - let take n t = - if n < 0 then invalid_arg "neg"; - if n > max_size then raise Buffer_limit_exceeded - else if String.length !t >= n then ( - let data = String.sub !t 0 n in - t := String.drop !t n; - data - ) else raise End_of_file - - let take_while p t = - match String.find (Fun.negate p) !t with - | Some i when i >= max_size -> raise Buffer_limit_exceeded - | Some i -> - let data = String.sub !t 0 i in - consume t i; - data - | None -> take_all t - - let skip_while p t = - match String.find (Fun.negate p) !t with - | Some i -> consume t i - | None -> t := "" - - let skip n t = - if n < 0 then invalid_arg "skip"; - if n > String.length !t then ( - t := ""; - raise End_of_file; - ); - consume t n - - let end_of_input t = - if !t <> "" then failwith "not eof" - - let rec lines t = - match line t with - | line -> line :: lines t - | exception End_of_file -> [] - - module BE = struct - let uint16 t = String.get_uint16_be (take 2 t) 0 - - let uint32 t = String.get_int32_be (take 4 t) 0 - - let uint48 t = - let s = take 6 t in - let upper_16 = String.get_uint16_be s 0 |> Int64.of_int in - let middle_16 = String.get_uint16_be s 2 |> Int64.of_int in - let lower_16 = String.get_uint16_be s 4 |> Int64.of_int in - Int64.( - add - (shift_left upper_16 32) - (add - (shift_left middle_16 16) - (lower_16)) - ) - - let uint64 t = String.get_int64_be (take 8 t) 0 - - let float t = - Int32.float_of_bits ( - String.get_int32_be (take 4 t) 0) - - let double t = - Int64.float_of_bits ( - String.get_int64_be (take 8 t) 0) - end - - module LE = struct - let uint16 t = String.get_uint16_le (take 2 t) 0 - - let uint32 t = String.get_int32_le (take 4 t) 0 - - let uint48 t = - let s = take 6 t in - let lower_16 = String.get_uint16_le s 0 |> Int64.of_int in - let middle_16 = String.get_uint16_le s 2 |> Int64.of_int in - let upper_16 = String.get_uint16_le s 4 |> Int64.of_int in - Int64.( - add - (shift_left upper_16 32) - (add - (shift_left middle_16 16) - (lower_16)) - ) - - let uint64 t = String.get_int64_le (take 8 t) 0 - - let float t = - Int32.float_of_bits ( - String.get_int32_le (take 4 t) 0) - - let double t = - Int64.float_of_bits ( - String.get_int64_le (take 8 t) 0) - end -end - -type op = Op : 'a Crowbar.printer * 'a Buf_read.parser * (Model.t -> 'a) -> op - -let unit = Fmt.(const string) "()" -let dump_char f c = Fmt.pf f "%C" c - -let digit = function - | '0'..'9' -> true - | _ -> false - -let op = - let label (name, gen) = Crowbar.with_printer Fmt.(const string name) gen in - Crowbar.choose @@ List.map label [ - "line", Crowbar.const @@ Op (Fmt.Dump.string, Buf_read.line, Model.line); - "char 'x'", Crowbar.const @@ Op (unit, Buf_read.char 'x', Model.char 'x'); - "any_char", Crowbar.const @@ Op (dump_char, Buf_read.any_char, Model.any_char); - "peek_char", Crowbar.const @@ Op (Fmt.Dump.option dump_char, Buf_read.peek_char, Model.peek_char); - "string", Crowbar.(map [bytes]) (fun s -> Op (unit, Buf_read.string s, Model.string s)); - "take", Crowbar.(map [int]) (fun n -> Op (Fmt.Dump.string, Buf_read.take n, Model.take n)); - "take_all", Crowbar.const @@ Op (Fmt.Dump.string, Buf_read.take_all, Model.take_all); - "take_while digit", Crowbar.const @@ Op (Fmt.Dump.string, Buf_read.take_while digit, Model.take_while digit); - "skip_while digit", Crowbar.const @@ Op (unit, Buf_read.skip_while digit, Model.skip_while digit); - "skip", Crowbar.(map [int]) (fun n -> Op (unit, Buf_read.skip n, Model.skip n)); - "end_of_input", Crowbar.const @@ Op (unit, Buf_read.end_of_input, Model.end_of_input); - "lines", Crowbar.const @@ Op (Fmt.Dump.(list string), (Buf_read.(map List.of_seq lines)), Model.lines); - "be_uint16", Crowbar.const @@ Op (Fmt.int, (Buf_read.BE.uint16), Model.BE.uint16); - "be_uint32", Crowbar.const @@ Op (Fmt.int32, (Buf_read.BE.uint32), Model.BE.uint32); - "be_uint48", Crowbar.const @@ Op (Fmt.int64, (Buf_read.BE.uint48), Model.BE.uint48); - "be_uint64", Crowbar.const @@ Op (Fmt.int64, (Buf_read.BE.uint64), Model.BE.uint64); - "be_float", Crowbar.const @@ Op (Fmt.float, (Buf_read.BE.float), Model.BE.float); - "be_double", Crowbar.const @@ Op (Fmt.float, (Buf_read.BE.double), Model.BE.double); - "le_uint16", Crowbar.const @@ Op (Fmt.int, (Buf_read.LE.uint16), Model.LE.uint16); - "le_uint32", Crowbar.const @@ Op (Fmt.int32, (Buf_read.LE.uint32), Model.LE.uint32); - "le_uint48", Crowbar.const @@ Op (Fmt.int64, (Buf_read.LE.uint48), Model.LE.uint48); - "le_uint64", Crowbar.const @@ Op (Fmt.int64, (Buf_read.LE.uint64), Model.LE.uint64); - "le_float", Crowbar.const @@ Op (Fmt.float, (Buf_read.LE.float), Model.LE.float); - "le_double", Crowbar.const @@ Op (Fmt.float, (Buf_read.LE.double), Model.LE.double); - ] - -let catch f x = - match f x with - | y -> Ok y - | exception End_of_file -> Error "EOF" - | exception Invalid_argument _ -> Error "Invalid" - | exception Failure _ -> Error "Failure" - | exception Buffer_limit_exceeded -> Error "TooBig" - -let random chunks ops = - let model = Model.of_chunks chunks in - let chunks_len = String.length !model in - let r = Buf_read.of_flow (mock_flow chunks) ~initial_size ~max_size in - if debug then print_endline "*** start ***"; - let check_eq (Op (pp, a, b)) = - if debug then ( - Fmt.pr "---@."; - Fmt.pr "real :%S@." (Cstruct.to_string (Buf_read.peek r)); - Fmt.pr "model:%S@." !model; - ); - let x = catch a r in - let y = catch b model in - Crowbar.check_eq ~pp:Fmt.(result ~ok:pp ~error:string) x y - in - List.iter check_eq ops; - Crowbar.check_eq ~pp:Fmt.int (Buf_read.consumed_bytes r) (chunks_len - String.length !model) - -let () = - Crowbar.(add_test ~name:"random ops" [list bytes; list op] random) +(* This file contains a simple model of `Buf_read`, using a single string. + It runs random operations on both the model and the real buffer and + checks they always give the same result. *) + +module String = struct + include String + + let rec find ?(start=0) p t = + if start = String.length t then None + else if p t.[start] then Some start + else find ~start:(succ start) p t + + let drop t n = String.sub t n (String.length t - n) + + let cut ~sep t = + match String.index_opt t sep with + | None -> None + | Some i -> Some (String.sub t 0 i, drop t (i + 1)) +end + +let debug = false + +module Buf_read = Eio.Buf_read +exception Buffer_limit_exceeded = Buf_read.Buffer_limit_exceeded + +let initial_size = 10 +let max_size = 100 + +module Mock_flow = struct + type t = string list ref + + let rec single_read t buf = + match !t with + | [] -> + raise End_of_file + | "" :: xs -> + t := xs; + single_read t buf + | x :: xs -> + let len = min (Cstruct.length buf) (String.length x) in + Cstruct.blit_from_string x 0 buf 0 len; + let x' = String.drop x len in + t := (if x' = "" then xs else x' :: xs); + len + + let read_methods = [] +end + +let mock_flow = + let ops = Eio.Flow.Pi.source (module Mock_flow) in + fun chunks -> Eio.Resource.T (ref chunks, ops) + +module Model = struct + type t = string ref + + let of_chunks chunks = ref (String.concat "" chunks) + + let take_all t = + let old = !t in + if String.length old >= max_size then raise Buffer_limit_exceeded; + t := ""; + old + + let line t = + match String.cut ~sep:'\n' !t with + | Some (line, rest) -> + if String.length line >= max_size then raise Buffer_limit_exceeded; + t := rest; + if String.ends_with ~suffix:"\r" line then String.sub line 0 (String.length line - 1) + else line + | None when !t = "" -> raise End_of_file + | None when String.length !t >= max_size -> raise Buffer_limit_exceeded + | None -> take_all t + + let any_char t = + match !t with + | "" -> raise End_of_file + | s -> + t := String.drop s 1; + s.[0] + + let peek_char t = + match !t with + | "" -> None + | s -> Some (s.[0]) + + let consume t n = + t := String.drop !t n + + let char c t = + match peek_char t with + | Some c2 when c = c2 -> consume t 1 + | Some _ -> failwith "char" + | None -> raise End_of_file + + let string s t = + if debug then Fmt.pr "string %S@." s; + let len_t = String.length !t in + let prefix = String.sub s 0 (min len_t (String.length s)) in + if not (String.starts_with ~prefix !t) then failwith "string"; + if String.length s > max_size then raise Buffer_limit_exceeded; + if String.starts_with ~prefix:s !t then consume t (String.length s) + else raise End_of_file + + let take n t = + if n < 0 then invalid_arg "neg"; + if n > max_size then raise Buffer_limit_exceeded + else if String.length !t >= n then ( + let data = String.sub !t 0 n in + t := String.drop !t n; + data + ) else raise End_of_file + + let take_while p t = + match String.find (Fun.negate p) !t with + | Some i when i >= max_size -> raise Buffer_limit_exceeded + | Some i -> + let data = String.sub !t 0 i in + consume t i; + data + | None -> take_all t + + let skip_while p t = + match String.find (Fun.negate p) !t with + | Some i -> consume t i + | None -> t := "" + + let skip n t = + if n < 0 then invalid_arg "skip"; + if n > String.length !t then ( + t := ""; + raise End_of_file; + ); + consume t n + + let end_of_input t = + if !t <> "" then failwith "not eof" + + let rec lines t = + match line t with + | line -> line :: lines t + | exception End_of_file -> [] + + module BE = struct + let uint16 t = String.get_uint16_be (take 2 t) 0 + + let uint32 t = String.get_int32_be (take 4 t) 0 + + let uint48 t = + let s = take 6 t in + let upper_16 = String.get_uint16_be s 0 |> Int64.of_int in + let middle_16 = String.get_uint16_be s 2 |> Int64.of_int in + let lower_16 = String.get_uint16_be s 4 |> Int64.of_int in + Int64.( + add + (shift_left upper_16 32) + (add + (shift_left middle_16 16) + (lower_16)) + ) + + let uint64 t = String.get_int64_be (take 8 t) 0 + + let float t = + Int32.float_of_bits ( + String.get_int32_be (take 4 t) 0) + + let double t = + Int64.float_of_bits ( + String.get_int64_be (take 8 t) 0) + end + + module LE = struct + let uint16 t = String.get_uint16_le (take 2 t) 0 + + let uint32 t = String.get_int32_le (take 4 t) 0 + + let uint48 t = + let s = take 6 t in + let lower_16 = String.get_uint16_le s 0 |> Int64.of_int in + let middle_16 = String.get_uint16_le s 2 |> Int64.of_int in + let upper_16 = String.get_uint16_le s 4 |> Int64.of_int in + Int64.( + add + (shift_left upper_16 32) + (add + (shift_left middle_16 16) + (lower_16)) + ) + + let uint64 t = String.get_int64_le (take 8 t) 0 + + let float t = + Int32.float_of_bits ( + String.get_int32_le (take 4 t) 0) + + let double t = + Int64.float_of_bits ( + String.get_int64_le (take 8 t) 0) + end +end + +type op = Op : 'a Crowbar.printer * 'a Buf_read.parser * (Model.t -> 'a) -> op + +let unit = Fmt.(const string) "()" +let dump_char f c = Fmt.pf f "%C" c + +let digit = function + | '0'..'9' -> true + | _ -> false + +let op = + let label (name, gen) = Crowbar.with_printer Fmt.(const string name) gen in + Crowbar.choose @@ List.map label [ + "line", Crowbar.const @@ Op (Fmt.Dump.string, Buf_read.line, Model.line); + "char 'x'", Crowbar.const @@ Op (unit, Buf_read.char 'x', Model.char 'x'); + "any_char", Crowbar.const @@ Op (dump_char, Buf_read.any_char, Model.any_char); + "peek_char", Crowbar.const @@ Op (Fmt.Dump.option dump_char, Buf_read.peek_char, Model.peek_char); + "string", Crowbar.(map [bytes]) (fun s -> Op (unit, Buf_read.string s, Model.string s)); + "take", Crowbar.(map [int]) (fun n -> Op (Fmt.Dump.string, Buf_read.take n, Model.take n)); + "take_all", Crowbar.const @@ Op (Fmt.Dump.string, Buf_read.take_all, Model.take_all); + "take_while digit", Crowbar.const @@ Op (Fmt.Dump.string, Buf_read.take_while digit, Model.take_while digit); + "skip_while digit", Crowbar.const @@ Op (unit, Buf_read.skip_while digit, Model.skip_while digit); + "skip", Crowbar.(map [int]) (fun n -> Op (unit, Buf_read.skip n, Model.skip n)); + "end_of_input", Crowbar.const @@ Op (unit, Buf_read.end_of_input, Model.end_of_input); + "lines", Crowbar.const @@ Op (Fmt.Dump.(list string), (Buf_read.(map List.of_seq lines)), Model.lines); + "be_uint16", Crowbar.const @@ Op (Fmt.int, (Buf_read.BE.uint16), Model.BE.uint16); + "be_uint32", Crowbar.const @@ Op (Fmt.int32, (Buf_read.BE.uint32), Model.BE.uint32); + "be_uint48", Crowbar.const @@ Op (Fmt.int64, (Buf_read.BE.uint48), Model.BE.uint48); + "be_uint64", Crowbar.const @@ Op (Fmt.int64, (Buf_read.BE.uint64), Model.BE.uint64); + "be_float", Crowbar.const @@ Op (Fmt.float, (Buf_read.BE.float), Model.BE.float); + "be_double", Crowbar.const @@ Op (Fmt.float, (Buf_read.BE.double), Model.BE.double); + "le_uint16", Crowbar.const @@ Op (Fmt.int, (Buf_read.LE.uint16), Model.LE.uint16); + "le_uint32", Crowbar.const @@ Op (Fmt.int32, (Buf_read.LE.uint32), Model.LE.uint32); + "le_uint48", Crowbar.const @@ Op (Fmt.int64, (Buf_read.LE.uint48), Model.LE.uint48); + "le_uint64", Crowbar.const @@ Op (Fmt.int64, (Buf_read.LE.uint64), Model.LE.uint64); + "le_float", Crowbar.const @@ Op (Fmt.float, (Buf_read.LE.float), Model.LE.float); + "le_double", Crowbar.const @@ Op (Fmt.float, (Buf_read.LE.double), Model.LE.double); + ] + +let catch f x = + match f x with + | y -> Ok y + | exception End_of_file -> Error "EOF" + | exception Invalid_argument _ -> Error "Invalid" + | exception Failure _ -> Error "Failure" + | exception Buffer_limit_exceeded -> Error "TooBig" + +let random chunks ops = + let model = Model.of_chunks chunks in + let chunks_len = String.length !model in + let r = Buf_read.of_flow (mock_flow chunks) ~initial_size ~max_size in + if debug then print_endline "*** start ***"; + let check_eq (Op (pp, a, b)) = + if debug then ( + Fmt.pr "---@."; + Fmt.pr "real :%S@." (Cstruct.to_string (Buf_read.peek r)); + Fmt.pr "model:%S@." !model; + ); + let x = catch a r in + let y = catch b model in + Crowbar.check_eq ~pp:Fmt.(result ~ok:pp ~error:string) x y + in + List.iter check_eq ops; + Crowbar.check_eq ~pp:Fmt.int (Buf_read.consumed_bytes r) (chunks_len - String.length !model) + +let () = + Crowbar.(add_test ~name:"random ops" [list bytes; list op] random) diff --git a/fuzz/fuzz_buf_write.ml b/fuzz/fuzz_buf_write.ml index 7a713a114..2bd8129a9 100644 --- a/fuzz/fuzz_buf_write.ml +++ b/fuzz/fuzz_buf_write.ml @@ -1,49 +1,49 @@ -(* Run a random sequence of write operations on an [Eio.Buf_write]. - Check that the expected data gets written to the flow. *) - -module W = Eio.Buf_write - -let initial_size = 10 - -type op = Op : string * (W.t -> unit) -> op (* Expected string, writer *) - -let cstruct = - Crowbar.(map [bytes; int; int]) (fun s off len -> - if String.length s = 0 then Cstruct.empty - else ( - let off = min (abs off) (String.length s) in - let len = min (abs len) (String.length s - off) in - Cstruct.of_string s ~off ~len - ) - ) - -let op = - let label (name, gen) = Crowbar.with_printer (fun f (Op (s, _)) -> Fmt.pf f "%s:%S" name s) gen in - Crowbar.choose @@ List.map label [ - "string", Crowbar.(map [bytes]) (fun s -> Op (s, (fun t -> W.string t s))); - "cstruct", Crowbar.(map [cstruct]) (fun cs -> Op (Cstruct.to_string cs, (fun t -> W.cstruct t cs))); - "schedule_cstruct", Crowbar.(map [cstruct]) (fun cs -> Op (Cstruct.to_string cs, (fun t -> W.schedule_cstruct t cs))); - "yield", Crowbar.const @@ Op ("", (fun _ -> Eio.Fiber.yield ())); - "flush", Crowbar.const @@ Op ("", W.flush); - "pause", Crowbar.const @@ Op ("", W.pause); - "unpause", Crowbar.const @@ Op ("", W.unpause); - ] - -let random ops close = - Eio_mock.Backend.run @@ fun _ -> - let b = Buffer.create 100 in - let flow = Eio.Flow.buffer_sink b in - let expected = ref [] in - W.with_flow flow ~initial_size (fun t -> - let perform (Op (s, write)) = - expected := s :: !expected; - write t - in - List.iter perform ops; - if close then W.close t - ); - let expected = String.concat "" (List.rev !expected) in - Crowbar.check_eq ~pp:Fmt.Dump.string (Buffer.contents b) expected - -let () = - Crowbar.(add_test ~name:"random ops" [list op; bool] random) +(* Run a random sequence of write operations on an [Eio.Buf_write]. + Check that the expected data gets written to the flow. *) + +module W = Eio.Buf_write + +let initial_size = 10 + +type op = Op : string * (W.t -> unit) -> op (* Expected string, writer *) + +let cstruct = + Crowbar.(map [bytes; int; int]) (fun s off len -> + if String.length s = 0 then Cstruct.empty + else ( + let off = min (abs off) (String.length s) in + let len = min (abs len) (String.length s - off) in + Cstruct.of_string s ~off ~len + ) + ) + +let op = + let label (name, gen) = Crowbar.with_printer (fun f (Op (s, _)) -> Fmt.pf f "%s:%S" name s) gen in + Crowbar.choose @@ List.map label [ + "string", Crowbar.(map [bytes]) (fun s -> Op (s, (fun t -> W.string t s))); + "cstruct", Crowbar.(map [cstruct]) (fun cs -> Op (Cstruct.to_string cs, (fun t -> W.cstruct t cs))); + "schedule_cstruct", Crowbar.(map [cstruct]) (fun cs -> Op (Cstruct.to_string cs, (fun t -> W.schedule_cstruct t cs))); + "yield", Crowbar.const @@ Op ("", (fun _ -> Eio.Fiber.yield ())); + "flush", Crowbar.const @@ Op ("", W.flush); + "pause", Crowbar.const @@ Op ("", W.pause); + "unpause", Crowbar.const @@ Op ("", W.unpause); + ] + +let random ops close = + Eio_mock.Backend.run @@ fun _ -> + let b = Buffer.create 100 in + let flow = Eio.Flow.buffer_sink b in + let expected = ref [] in + W.with_flow flow ~initial_size (fun t -> + let perform (Op (s, write)) = + expected := s :: !expected; + write t + in + List.iter perform ops; + if close then W.close t + ); + let expected = String.concat "" (List.rev !expected) in + Crowbar.check_eq ~pp:Fmt.Dump.string (Buffer.contents b) expected + +let () = + Crowbar.(add_test ~name:"random ops" [list op; bool] random) diff --git a/fuzz/fuzz_inherit_fds.ml b/fuzz/fuzz_inherit_fds.ml index c55925d2a..f7ffe5699 100644 --- a/fuzz/fuzz_inherit_fds.ml +++ b/fuzz/fuzz_inherit_fds.ml @@ -1,46 +1,46 @@ -module I = Eio_unix__Inherit_fds - -module S = Set.Make(Int) - -let pp f = function - | `Cloexec x -> Fmt.pf f "close %d" x - | `Keep x -> Fmt.pf f "keep %d" x - -let rec has_duplicates ~seen = function - | [] -> false - | (dst, _) :: _ when S.mem dst seen -> true - | (dst, _) :: xs -> has_duplicates xs ~seen:(S.add dst seen) - -let inherit_fds mapping = - let has_duplicates = has_duplicates ~seen:S.empty mapping in - let fds = Hashtbl.create 10 in - mapping |> List.iter (fun (_dst, src) -> - Hashtbl.add fds src (`Cloexec src); - ); - match I.plan mapping with - | exception (Invalid_argument _) -> assert has_duplicates - | plan -> - assert (not has_duplicates); - plan |> List.iter (fun {I.src; dst} -> - (* Fmt.pr "%d -> %d@." src dst; *) - let v = - match Hashtbl.find fds src with - | `Cloexec x | `Keep x -> - if dst = -1 then `Cloexec x else `Keep x - in - Hashtbl.add fds dst v - ); - mapping |> List.iter (fun (dst, src) -> - let v = Hashtbl.find fds dst in - Crowbar.check_eq ~pp v (`Keep src); - Hashtbl.remove fds dst; - ); - fds |> Hashtbl.iter (fun x -> function - | `Cloexec _ -> () - | `Keep _ -> Fmt.failwith "%d should be close-on-exec!" x - ) - -let fd = Crowbar.range 10 (* Restrict range to make cycles more likely *) - -let () = - Crowbar.(add_test ~name:"inherit_fds" [list (pair fd fd)] inherit_fds) +module I = Eio_unix__Inherit_fds + +module S = Set.Make(Int) + +let pp f = function + | `Cloexec x -> Fmt.pf f "close %d" x + | `Keep x -> Fmt.pf f "keep %d" x + +let rec has_duplicates ~seen = function + | [] -> false + | (dst, _) :: _ when S.mem dst seen -> true + | (dst, _) :: xs -> has_duplicates xs ~seen:(S.add dst seen) + +let inherit_fds mapping = + let has_duplicates = has_duplicates ~seen:S.empty mapping in + let fds = Hashtbl.create 10 in + mapping |> List.iter (fun (_dst, src) -> + Hashtbl.add fds src (`Cloexec src); + ); + match I.plan mapping with + | exception (Invalid_argument _) -> assert has_duplicates + | plan -> + assert (not has_duplicates); + plan |> List.iter (fun {I.src; dst} -> + (* Fmt.pr "%d -> %d@." src dst; *) + let v = + match Hashtbl.find fds src with + | `Cloexec x | `Keep x -> + if dst = -1 then `Cloexec x else `Keep x + in + Hashtbl.add fds dst v + ); + mapping |> List.iter (fun (dst, src) -> + let v = Hashtbl.find fds dst in + Crowbar.check_eq ~pp v (`Keep src); + Hashtbl.remove fds dst; + ); + fds |> Hashtbl.iter (fun x -> function + | `Cloexec _ -> () + | `Keep _ -> Fmt.failwith "%d should be close-on-exec!" x + ) + +let fd = Crowbar.range 10 (* Restrict range to make cycles more likely *) + +let () = + Crowbar.(add_test ~name:"inherit_fds" [list (pair fd fd)] inherit_fds) diff --git a/lib_eio/buf_read.ml b/lib_eio/buf_read.ml index 51e2213b7..3795e3a60 100644 --- a/lib_eio/buf_read.ml +++ b/lib_eio/buf_read.ml @@ -1,442 +1,442 @@ -exception Buffer_limit_exceeded - -open Std - -type t = { - mutable buf : Cstruct.buffer; - mutable pos : int; - mutable len : int; - mutable flow : Flow.source_ty r option; (* None if we've seen eof *) - mutable consumed : int; (* Total bytes consumed so far *) - max_size : int; -} - -type 'a parser = t -> 'a - -let return = Fun.const - -let map f x r = f (x r) - -let pair x y r = - let a = x r in - let b = y r in - a, b - -let bind x f r = f (x r) r - -module Syntax = struct - let ( let+ ) x f r = f (x r) - let ( let* ) = bind - let ( and* ) = pair - let ( and+ ) = pair - - let ( <*> ) = pair - - let ( <* ) a b t = - let x = a t in - ignore (b t); - x - - let ( *> ) a b t = - ignore (a t); - b t -end - -open Syntax - -let capacity t = Bigarray.Array1.dim t.buf - -let of_flow ?initial_size ~max_size flow = - let flow = (flow :> Flow.source_ty r) in - if max_size <= 0 then Fmt.invalid_arg "Max size %d should be positive!" max_size; - let initial_size = Option.value initial_size ~default:(min 4096 max_size) in - let buf = Bigarray.(Array1.create char c_layout initial_size) in - { buf; pos = 0; len = 0; flow = Some flow; max_size; consumed = 0 } - -let of_buffer buf = - let len = Bigarray.Array1.dim buf in - { buf; pos = 0; len; flow = None; max_size = max_int; consumed = 0 } - -let of_string s = - let len = String.length s in - let buf = Bigarray.(Array1.create char c_layout) len in - Cstruct.blit_from_string s 0 (Cstruct.of_bigarray buf) 0 len; - of_buffer buf - -let peek t = - Cstruct.of_bigarray ~off:t.pos ~len:t.len t.buf - -let consume_err t n = - Fmt.invalid_arg "Can't consume %d bytes of a %d byte buffer!" n t.len - -let [@inline] consume t n = - if n < 0 || n > t.len then consume_err t n; - t.pos <- t.pos + n; - t.len <- t.len - n; - t.consumed <- t.consumed + n - -let consume_all t = - t.consumed <- t.consumed + t.len; - t.len <- 0 - -let buffered_bytes t = t.len - -let consumed_bytes t = t.consumed - -let eof_seen t = t.flow = None - -let ensure_slow_path t n = - assert (n >= 0); - if n > t.max_size then raise Buffer_limit_exceeded; - (* We don't have enough data yet, so we'll need to do a read. *) - match t.flow with - | None -> raise End_of_file - | Some flow -> - (* If the buffer is empty, we might as well use all of it: *) - if t.len = 0 then t.pos <- 0; - let () = - let cap = capacity t in - if n > cap then ( - (* [n] bytes won't fit. We need to resize the buffer. *) - let new_size = max n (min t.max_size (cap * 2)) in - let new_buf = Bigarray.(Array1.create char c_layout new_size) in - Cstruct.blit - (peek t) 0 - (Cstruct.of_bigarray new_buf) 0 - t.len; - t.pos <- 0; - t.buf <- new_buf - ) else if t.pos + n > cap then ( - (* [n] bytes will fit in the existing buffer, but we need to compact it first. *) - Cstruct.blit - (peek t) 0 - (Cstruct.of_bigarray t.buf) 0 - t.len; - t.pos <- 0 - ) - in - try - while t.len < n do - let free_space = Cstruct.of_bigarray t.buf ~off:(t.pos + t.len) in - assert (t.len + Cstruct.length free_space >= n); - let got = Flow.single_read flow free_space in - t.len <- t.len + got - done; - assert (buffered_bytes t >= n) - with End_of_file -> - t.flow <- None; - raise End_of_file - -let ensure t n = - if t.len < n then ensure_slow_path t n - -module F = struct - type nonrec t = t - - let single_read t dst = - ensure t 1; - let len = min (buffered_bytes t) (Cstruct.length dst) in - Cstruct.blit (peek t) 0 dst 0 len; - consume t len; - len - - let rsb t fn = - ensure t 1; - let data = peek t in - let sent = fn [data] in - consume t sent - - let read_methods = [Flow.Read_source_buffer rsb] -end - -let as_flow = - let ops = Flow.Pi.source (module F) in - fun t -> Resource.T (t, ops) - -let get t i = - Bigarray.Array1.get t.buf (t.pos + i) - -module BE = struct - let uint16 t = - ensure t 2; - let data = Bigstringaf.get_int16_be t.buf t.pos in - consume t 2; - data - - let uint32 t = - ensure t 4; - let data = Bigstringaf.get_int32_be t.buf t.pos in - consume t 4; - data - - let uint48 t = - ensure t 6; - let upper_32 = Bigstringaf.get_int32_be t.buf t.pos |> Int64.of_int32 |> Int64.logand 0xffffffffL in - let lower_16 = Bigstringaf.get_int16_be t.buf (t.pos + 4) |> Int64.of_int in - consume t 6; - Int64.( - logor - (lower_16) - (shift_left upper_32 16) - ) - - let uint64 t = - ensure t 8; - let data = Bigstringaf.get_int64_be t.buf t.pos in - consume t 8; - data - - let float t = - ensure t 4; - let data = Bigstringaf.unsafe_get_int32_be t.buf t.pos in - consume t 4; - Int32.float_of_bits data - - let double t = - ensure t 8; - let data = Bigstringaf.unsafe_get_int64_be t.buf t.pos in - consume t 8; - Int64.float_of_bits data -end - -module LE = struct - let uint16 t = - ensure t 2; - let data = Bigstringaf.get_int16_le t.buf t.pos in - consume t 2; - data - - let uint32 t = - ensure t 4; - let data = Bigstringaf.get_int32_le t.buf t.pos in - consume t 4; - data - - let uint48 t = - ensure t 6; - let lower_32 = Bigstringaf.get_int32_le t.buf t.pos |> Int64.of_int32 |> Int64.logand 0xffffffffL in - let upper_16 = Bigstringaf.get_int16_le t.buf (t.pos + 4) |> Int64.of_int in - consume t 6; - Int64.( - logor - (shift_left upper_16 32) - lower_32 - ) - - let uint64 t = - ensure t 8; - let data = Bigstringaf.get_int64_le t.buf t.pos in - consume t 8; - data - - let float t = - ensure t 4; - let data = Bigstringaf.unsafe_get_int32_le t.buf t.pos in - consume t 4; - Int32.float_of_bits data - - let double t = - ensure t 8; - let data = Bigstringaf.unsafe_get_int64_le t.buf t.pos in - consume t 8; - Int64.float_of_bits data -end - -let char c t = - ensure t 1; - let c2 = get t 0 in - if c <> c2 then Fmt.failwith "Expected %C but got %C" c c2; - consume t 1 - -let any_char t = - ensure t 1; - let c = get t 0 in - consume t 1; - c - -let uint8 t = Char.code (any_char t) - -let peek_char t = - match ensure t 1 with - | () -> Some (get t 0) - | exception End_of_file -> None - -let take len t = - if len < 0 then Fmt.invalid_arg "take: %d is negative!" len; - ensure t len; - let data = Cstruct.to_string (Cstruct.of_bigarray t.buf ~off:t.pos ~len) in - consume t len; - data - -let string s t = - let rec aux i = - if i = String.length s then ( - consume t i - ) else if i < t.len then ( - if get t i = s.[i] then aux (i + 1) - else ( - let buf = peek t in - let len = min (String.length s) (Cstruct.length buf) in - Fmt.failwith "Expected %S but got %S" - s - (Cstruct.to_string buf ~off:0 ~len) - ) - ) else ( - ensure t (t.len + 1); - aux i - ) - in - aux 0 - -let take_all t = - try - while true do ensure t (t.len + 1) done; - assert false - with End_of_file -> - let data = Cstruct.to_string (peek t) in - consume t t.len; - data - -let count_while p t = - let rec aux i = - if i < t.len then ( - if p (get t i) then aux (i + 1) - else i - ) else ( - ensure t (t.len + 1); - aux i - ) - in - try aux 0 - with End_of_file -> t.len - -let take_while p t = - let len = count_while p t in - let data = Cstruct.to_string (Cstruct.of_bigarray t.buf ~off:t.pos ~len) in - consume t len; - data - -let take_while1 p t = - let len = count_while p t in - if len < 1 then Fmt.failwith "take_while1" - else - let data = Cstruct.to_string (Cstruct.of_bigarray t.buf ~off:t.pos ~len) in - consume t len; - data - -let skip_while p t = - let rec aux i = - if i < t.len then ( - if p (get t i) then aux (i + 1) - else consume t i - ) else ( - consume t t.len; - ensure t 1; - aux 0 - ) - in - try aux 0 - with End_of_file -> () - -let skip_while1 p t = - let len = count_while p t in - if len < 1 then Fmt.failwith "skip_while1" - else consume t len - -let rec skip n t = - if n <= t.len then ( - consume t n - ) else ( - let n = n - t.len in - consume_all t; - ensure t (min n (capacity t)); - skip n t - ) - -let skip n t = - if n < 0 then Fmt.invalid_arg "skip: %d is negative!" n; - try skip n t - with End_of_file -> - (* Skip isn't atomic, so discard everything in this case for consistency. *) - consume t t.len; - raise End_of_file - -let line t = - (* Return the index of the first '\n', reading more data as needed. *) - let rec aux i = - if i = t.len then ( - ensure t (t.len + 1); - aux i - ) else if get t i = '\n' then ( - i - ) else ( - aux (i + 1) - ) - in - match aux 0 with - | exception End_of_file when t.len > 0 -> take_all t - | nl -> - let len = - if nl > 0 && get t (nl - 1) = '\r' then nl - 1 - else nl - in - let line = Cstruct.to_string (Cstruct.of_bigarray t.buf ~off:t.pos ~len) in - consume t (nl + 1); - line - -let at_end_of_input t = - if t.len = 0 && eof_seen t then true - else ( - match ensure t 1 with - | () -> false - | exception End_of_file -> true - ) - -let end_of_input t = - if not (at_end_of_input t) then - failwith "Unexpected data after parsing" - -let pp_pos f t = - Fmt.pf f "at offset %d" (consumed_bytes t) - -let format_errors p t = - match p t with - | v -> Ok v - | exception Failure msg -> Fmt.error_msg "%s (%a)" msg pp_pos t - | exception End_of_file -> Fmt.error_msg "Unexpected end-of-file at offset %d" (t.consumed + t.len) - | exception Buffer_limit_exceeded -> Fmt.error_msg "Buffer size limit exceeded when reading %a" pp_pos t - -let parse ?initial_size ~max_size p flow = - let buf = of_flow flow ?initial_size ~max_size in - format_errors (p <* end_of_input) buf - -let parse_exn ?initial_size ~max_size p flow = - match parse ?initial_size ~max_size p flow with - | Ok x -> x - | Error (`Msg m) -> failwith m - -let parse_string p s = - format_errors (p <* end_of_input) (of_string s) - -let parse_string_exn p s = - match parse_string p s with - | Ok x -> x - | Error (`Msg m) -> failwith m - -[@@inline never] -let bad_offset ~expected actual = - Fmt.invalid_arg "Sequence is stale (expected to be used at offset %d, but stream is now at %d)" - expected actual - -let seq ?(stop=at_end_of_input) p t = - let rec aux offset () = - if offset <> t.consumed then bad_offset ~expected:offset t.consumed; - if stop t then Seq.Nil - else ( - let item = p t in - Seq.Cons (item, aux t.consumed) - ) - in - aux t.consumed - -let lines t = seq line t +exception Buffer_limit_exceeded + +open Std + +type t = { + mutable buf : Cstruct.buffer; + mutable pos : int; + mutable len : int; + mutable flow : Flow.source_ty r option; (* None if we've seen eof *) + mutable consumed : int; (* Total bytes consumed so far *) + max_size : int; +} + +type 'a parser = t -> 'a + +let return = Fun.const + +let map f x r = f (x r) + +let pair x y r = + let a = x r in + let b = y r in + a, b + +let bind x f r = f (x r) r + +module Syntax = struct + let ( let+ ) x f r = f (x r) + let ( let* ) = bind + let ( and* ) = pair + let ( and+ ) = pair + + let ( <*> ) = pair + + let ( <* ) a b t = + let x = a t in + ignore (b t); + x + + let ( *> ) a b t = + ignore (a t); + b t +end + +open Syntax + +let capacity t = Bigarray.Array1.dim t.buf + +let of_flow ?initial_size ~max_size flow = + let flow = (flow :> Flow.source_ty r) in + if max_size <= 0 then Fmt.invalid_arg "Max size %d should be positive!" max_size; + let initial_size = Option.value initial_size ~default:(min 4096 max_size) in + let buf = Bigarray.(Array1.create char c_layout initial_size) in + { buf; pos = 0; len = 0; flow = Some flow; max_size; consumed = 0 } + +let of_buffer buf = + let len = Bigarray.Array1.dim buf in + { buf; pos = 0; len; flow = None; max_size = max_int; consumed = 0 } + +let of_string s = + let len = String.length s in + let buf = Bigarray.(Array1.create char c_layout) len in + Cstruct.blit_from_string s 0 (Cstruct.of_bigarray buf) 0 len; + of_buffer buf + +let peek t = + Cstruct.of_bigarray ~off:t.pos ~len:t.len t.buf + +let consume_err t n = + Fmt.invalid_arg "Can't consume %d bytes of a %d byte buffer!" n t.len + +let [@inline] consume t n = + if n < 0 || n > t.len then consume_err t n; + t.pos <- t.pos + n; + t.len <- t.len - n; + t.consumed <- t.consumed + n + +let consume_all t = + t.consumed <- t.consumed + t.len; + t.len <- 0 + +let buffered_bytes t = t.len + +let consumed_bytes t = t.consumed + +let eof_seen t = t.flow = None + +let ensure_slow_path t n = + assert (n >= 0); + if n > t.max_size then raise Buffer_limit_exceeded; + (* We don't have enough data yet, so we'll need to do a read. *) + match t.flow with + | None -> raise End_of_file + | Some flow -> + (* If the buffer is empty, we might as well use all of it: *) + if t.len = 0 then t.pos <- 0; + let () = + let cap = capacity t in + if n > cap then ( + (* [n] bytes won't fit. We need to resize the buffer. *) + let new_size = max n (min t.max_size (cap * 2)) in + let new_buf = Bigarray.(Array1.create char c_layout new_size) in + Cstruct.blit + (peek t) 0 + (Cstruct.of_bigarray new_buf) 0 + t.len; + t.pos <- 0; + t.buf <- new_buf + ) else if t.pos + n > cap then ( + (* [n] bytes will fit in the existing buffer, but we need to compact it first. *) + Cstruct.blit + (peek t) 0 + (Cstruct.of_bigarray t.buf) 0 + t.len; + t.pos <- 0 + ) + in + try + while t.len < n do + let free_space = Cstruct.of_bigarray t.buf ~off:(t.pos + t.len) in + assert (t.len + Cstruct.length free_space >= n); + let got = Flow.single_read flow free_space in + t.len <- t.len + got + done; + assert (buffered_bytes t >= n) + with End_of_file -> + t.flow <- None; + raise End_of_file + +let ensure t n = + if t.len < n then ensure_slow_path t n + +module F = struct + type nonrec t = t + + let single_read t dst = + ensure t 1; + let len = min (buffered_bytes t) (Cstruct.length dst) in + Cstruct.blit (peek t) 0 dst 0 len; + consume t len; + len + + let rsb t fn = + ensure t 1; + let data = peek t in + let sent = fn [data] in + consume t sent + + let read_methods = [Flow.Read_source_buffer rsb] +end + +let as_flow = + let ops = Flow.Pi.source (module F) in + fun t -> Resource.T (t, ops) + +let get t i = + Bigarray.Array1.get t.buf (t.pos + i) + +module BE = struct + let uint16 t = + ensure t 2; + let data = Bigstringaf.get_int16_be t.buf t.pos in + consume t 2; + data + + let uint32 t = + ensure t 4; + let data = Bigstringaf.get_int32_be t.buf t.pos in + consume t 4; + data + + let uint48 t = + ensure t 6; + let upper_32 = Bigstringaf.get_int32_be t.buf t.pos |> Int64.of_int32 |> Int64.logand 0xffffffffL in + let lower_16 = Bigstringaf.get_int16_be t.buf (t.pos + 4) |> Int64.of_int in + consume t 6; + Int64.( + logor + (lower_16) + (shift_left upper_32 16) + ) + + let uint64 t = + ensure t 8; + let data = Bigstringaf.get_int64_be t.buf t.pos in + consume t 8; + data + + let float t = + ensure t 4; + let data = Bigstringaf.unsafe_get_int32_be t.buf t.pos in + consume t 4; + Int32.float_of_bits data + + let double t = + ensure t 8; + let data = Bigstringaf.unsafe_get_int64_be t.buf t.pos in + consume t 8; + Int64.float_of_bits data +end + +module LE = struct + let uint16 t = + ensure t 2; + let data = Bigstringaf.get_int16_le t.buf t.pos in + consume t 2; + data + + let uint32 t = + ensure t 4; + let data = Bigstringaf.get_int32_le t.buf t.pos in + consume t 4; + data + + let uint48 t = + ensure t 6; + let lower_32 = Bigstringaf.get_int32_le t.buf t.pos |> Int64.of_int32 |> Int64.logand 0xffffffffL in + let upper_16 = Bigstringaf.get_int16_le t.buf (t.pos + 4) |> Int64.of_int in + consume t 6; + Int64.( + logor + (shift_left upper_16 32) + lower_32 + ) + + let uint64 t = + ensure t 8; + let data = Bigstringaf.get_int64_le t.buf t.pos in + consume t 8; + data + + let float t = + ensure t 4; + let data = Bigstringaf.unsafe_get_int32_le t.buf t.pos in + consume t 4; + Int32.float_of_bits data + + let double t = + ensure t 8; + let data = Bigstringaf.unsafe_get_int64_le t.buf t.pos in + consume t 8; + Int64.float_of_bits data +end + +let char c t = + ensure t 1; + let c2 = get t 0 in + if c <> c2 then Fmt.failwith "Expected %C but got %C" c c2; + consume t 1 + +let any_char t = + ensure t 1; + let c = get t 0 in + consume t 1; + c + +let uint8 t = Char.code (any_char t) + +let peek_char t = + match ensure t 1 with + | () -> Some (get t 0) + | exception End_of_file -> None + +let take len t = + if len < 0 then Fmt.invalid_arg "take: %d is negative!" len; + ensure t len; + let data = Cstruct.to_string (Cstruct.of_bigarray t.buf ~off:t.pos ~len) in + consume t len; + data + +let string s t = + let rec aux i = + if i = String.length s then ( + consume t i + ) else if i < t.len then ( + if get t i = s.[i] then aux (i + 1) + else ( + let buf = peek t in + let len = min (String.length s) (Cstruct.length buf) in + Fmt.failwith "Expected %S but got %S" + s + (Cstruct.to_string buf ~off:0 ~len) + ) + ) else ( + ensure t (t.len + 1); + aux i + ) + in + aux 0 + +let take_all t = + try + while true do ensure t (t.len + 1) done; + assert false + with End_of_file -> + let data = Cstruct.to_string (peek t) in + consume t t.len; + data + +let count_while p t = + let rec aux i = + if i < t.len then ( + if p (get t i) then aux (i + 1) + else i + ) else ( + ensure t (t.len + 1); + aux i + ) + in + try aux 0 + with End_of_file -> t.len + +let take_while p t = + let len = count_while p t in + let data = Cstruct.to_string (Cstruct.of_bigarray t.buf ~off:t.pos ~len) in + consume t len; + data + +let take_while1 p t = + let len = count_while p t in + if len < 1 then Fmt.failwith "take_while1" + else + let data = Cstruct.to_string (Cstruct.of_bigarray t.buf ~off:t.pos ~len) in + consume t len; + data + +let skip_while p t = + let rec aux i = + if i < t.len then ( + if p (get t i) then aux (i + 1) + else consume t i + ) else ( + consume t t.len; + ensure t 1; + aux 0 + ) + in + try aux 0 + with End_of_file -> () + +let skip_while1 p t = + let len = count_while p t in + if len < 1 then Fmt.failwith "skip_while1" + else consume t len + +let rec skip n t = + if n <= t.len then ( + consume t n + ) else ( + let n = n - t.len in + consume_all t; + ensure t (min n (capacity t)); + skip n t + ) + +let skip n t = + if n < 0 then Fmt.invalid_arg "skip: %d is negative!" n; + try skip n t + with End_of_file -> + (* Skip isn't atomic, so discard everything in this case for consistency. *) + consume t t.len; + raise End_of_file + +let line t = + (* Return the index of the first '\n', reading more data as needed. *) + let rec aux i = + if i = t.len then ( + ensure t (t.len + 1); + aux i + ) else if get t i = '\n' then ( + i + ) else ( + aux (i + 1) + ) + in + match aux 0 with + | exception End_of_file when t.len > 0 -> take_all t + | nl -> + let len = + if nl > 0 && get t (nl - 1) = '\r' then nl - 1 + else nl + in + let line = Cstruct.to_string (Cstruct.of_bigarray t.buf ~off:t.pos ~len) in + consume t (nl + 1); + line + +let at_end_of_input t = + if t.len = 0 && eof_seen t then true + else ( + match ensure t 1 with + | () -> false + | exception End_of_file -> true + ) + +let end_of_input t = + if not (at_end_of_input t) then + failwith "Unexpected data after parsing" + +let pp_pos f t = + Fmt.pf f "at offset %d" (consumed_bytes t) + +let format_errors p t = + match p t with + | v -> Ok v + | exception Failure msg -> Fmt.error_msg "%s (%a)" msg pp_pos t + | exception End_of_file -> Fmt.error_msg "Unexpected end-of-file at offset %d" (t.consumed + t.len) + | exception Buffer_limit_exceeded -> Fmt.error_msg "Buffer size limit exceeded when reading %a" pp_pos t + +let parse ?initial_size ~max_size p flow = + let buf = of_flow flow ?initial_size ~max_size in + format_errors (p <* end_of_input) buf + +let parse_exn ?initial_size ~max_size p flow = + match parse ?initial_size ~max_size p flow with + | Ok x -> x + | Error (`Msg m) -> failwith m + +let parse_string p s = + format_errors (p <* end_of_input) (of_string s) + +let parse_string_exn p s = + match parse_string p s with + | Ok x -> x + | Error (`Msg m) -> failwith m + +[@@inline never] +let bad_offset ~expected actual = + Fmt.invalid_arg "Sequence is stale (expected to be used at offset %d, but stream is now at %d)" + expected actual + +let seq ?(stop=at_end_of_input) p t = + let rec aux offset () = + if offset <> t.consumed then bad_offset ~expected:offset t.consumed; + if stop t then Seq.Nil + else ( + let item = p t in + Seq.Cons (item, aux t.consumed) + ) + in + aux t.consumed + +let lines t = seq line t diff --git a/lib_eio/buf_read.mli b/lib_eio/buf_read.mli index 4ed9ac271..15c5fca5d 100644 --- a/lib_eio/buf_read.mli +++ b/lib_eio/buf_read.mli @@ -1,325 +1,325 @@ -(** This module provides fairly efficient non-backtracking parsers. - It is modelled on Angstrom's API, and you should use that if - backtracking is needed. - - Example: - {[ - let r = Buf_read.of_flow flow ~max_size:1_000_000 in - Buf_read.line r - ]} -*) - -open Std - -type t -(** An input buffer. *) - -exception Buffer_limit_exceeded -(** Raised if parsing an item would require enlarging the buffer beyond its configured limit. *) - -type 'a parser = t -> 'a -(** An ['a parser] is a function that consumes and returns a value of type ['a]. - @raise Failure The flow can't be parsed as a value of type ['a]. - @raise End_of_file The flow ended without enough data to parse an ['a]. - @raise Buffer_limit_exceeded Parsing the value would exceed the configured size limit. *) - -val parse : ?initial_size:int -> max_size:int -> 'a parser -> _ Flow.source -> ('a, [> `Msg of string]) result -(** [parse p flow ~max_size] uses [p] to parse everything in [flow]. - - It is a convenience function that does - {[ - let buf = of_flow flow ~max_size in - format_errors (p <* end_of_input) buf - ]} - - @param initial_size see {!of_flow}. *) - -val parse_exn : ?initial_size:int -> max_size:int -> 'a parser -> _ Flow.source -> 'a -(** [parse_exn] wraps {!parse}, but raises [Failure msg] if that returns [Error (`Msg msg)]. - - Catching exceptions with [parse] and then raising them might seem pointless, - but this has the effect of turning e.g. an [End_of_file] exception into a [Failure] - with a more user-friendly message. *) - -val parse_string : 'a parser -> string -> ('a, [> `Msg of string]) result -(** [parse_string p s] uses [p] to parse everything in [s]. - It is defined as [format_errors (p <* end_of_input) (of_string s)] *) - -val parse_string_exn : 'a parser -> string -> 'a -(** [parse_string_exn] is like {!parse_string}, but handles errors like {!parse_exn}. *) - -val of_flow : ?initial_size:int -> max_size:int -> _ Flow.source -> t -(** [of_flow ~max_size flow] is a buffered reader backed by [flow]. - - @param initial_size The initial amount of memory to allocate for the buffer. - @param max_size The maximum size to which the buffer may grow. - This must be large enough to hold the largest single item - you want to parse (e.g. the longest line, if using - {!line}), plus any terminator needed to know the value is - complete (e.g. the newline character(s)). This is just to - prevent a run-away input from consuming all memory, and - you can usually just set it much larger than you expect - to need. *) - -val of_buffer : Cstruct.buffer -> t -(** [of_buffer buf] is a reader that reads from [buf]. - [buf] is used directly, without being copied. - [eof_seen (of_buffer buf) = true]. - This module will not modify [buf] itself, but it will expose it via {!peek}. *) - -val of_string : string -> t -(** [of_string s] is a reader that reads from [s]. *) - -val as_flow : t -> Flow.source_ty r -(** [as_flow t] is a buffered flow. - - Reading from it will return data from the buffer, - only reading the underlying flow if the buffer is empty. *) - -(** {2 Reading data} *) - -val line : string parser -(** [line] parses one line. - - Lines can be terminated by either LF or CRLF. - The returned string does not include the terminator. - - If [End_of_file] is reached after seeing some data but before seeing a line - terminator, the data seen is returned as the last line. *) - -val lines : string Seq.t parser -(** [lines] returns a sequence that lazily reads the next line until the end of the input is reached. - - [lines = seq line ~stop:at_end_of_input] *) - -val char : char -> unit parser -(** [char c] checks that the next byte is [c] and consumes it. - @raise Failure if the next byte is not [c] *) - -val any_char : char parser -(** [any_char] parses one character. *) - -val peek_char : char option parser -(** [peek_char] returns [Some c] where [c] is the next character, but does not consume it. - - Returns [None] at the end of the input stream rather than raising [End_of_file]. *) - -val string : string -> unit parser -(** [string s] checks that [s] is the next string in the stream and consumes it. - - @raise Failure if [s] is not a prefix of the stream. *) - -val uint8 : int parser -(** [uint8] parses the next byte as an unsigned 8-bit integer. *) - -(** Big endian parsers *) -module BE : sig - val uint16 : int parser - (** [uint16] parses the next 2 bytes as the lower 16 bits of an [int] in big-endian byte order *) - - val uint32 : int32 parser - (** [uint32] parses the next 4 bytes as an [int32] in big-endian byte order *) - - val uint48 : int64 parser - (** [uint48] parses the next 6 bytes as a 48-bit unsigned big-endian integer *) - - val uint64 : int64 parser - (** [uint64] parses the next 8 bytes as an [int64] in big-endian byte order *) - - val float : float parser - (** [float] parses the next 4 bytes as a [float] in big-endian byte order *) - - val double : float parser - (** [double] parses the next 8 bytes as a [float] in big-endian byte order *) -end - -(** Little endian parsers *) -module LE : sig - val uint16 : int parser - (** [uint16] parses the next 2 bytes as the lower 16 bits of an [int] in little-endian byte order *) - - val uint32 : int32 parser - (** [uint32] parses the next 4 bytes as an [int32] in little-endian byte order *) - - val uint48 : int64 parser - (** [uint48] parses the next 6 bytes as a 48-bit unsigned big-endian integer *) - - val uint64 : int64 parser - (** [uint64] parses the next 8 bytes as an [int64] in little-endian byte order *) - - val float : float parser - (** [float] parses the next 4 bytes as a [float] in little-endian byte order *) - - val double : float parser - (** [double] parses the next 8 bytes as a [float] in little-endian byte order *) -end - -val take : int -> string parser -(** [take n] takes exactly [n] bytes from the input. *) - -val take_all : string parser -(** [take_all] takes all remaining data until end-of-file. - - Returns [""] if already at end-of-file. - - @raise Buffer_limit_exceeded if the remaining data exceeds or equals the buffer limit - (it needs one extra byte to confirm it has reached end-of-file). *) - -val take_while : (char -> bool) -> string parser -(** [take_while p] finds the first byte for which [p] is false - and consumes and returns all bytes before that. - - If [p] is true for all remaining bytes, it returns everything until end-of-file. - - It will return the empty string if there are no matching characters - (and therefore never raises [End_of_file]). *) - -val take_while1 : (char -> bool) -> string parser -(** [take_while1 p] is like [take_while]. However, the parser fails with "take_while1" - if at least one character of input hasn't been consumed by the parser. *) - -val skip_while : (char -> bool) -> unit parser -(** [skip_while p] skips zero or more bytes for which [p] is [true]. - - [skip_while p t] does the same thing as [ignore (take_while p t)], - except that it is not limited by the buffer size. *) - -val skip_while1 : (char -> bool) -> unit parser -(** [skip_while1 p] is like [skip_while]. However, the parser fails with "skip_while1" if - at least one character of input hasn't been skipped. *) - -val skip : int -> unit parser -(** [skip n] discards the next [n] bytes. - - [skip n] = [map ignore (take n)], - except that the number of skipped bytes may be larger than the buffer (it will not grow). - - Note: if [End_of_file] is raised, all bytes in the stream will have been consumed. *) - -val at_end_of_input : bool parser -(** [at_end_of_input] returns [true] when at the end of the stream, or - [false] if there is at least one more byte to be read. *) - -val end_of_input : unit parser -(** [end_of_input] checks that there are no further bytes in the stream. - @raise Failure if there are further bytes *) - -(** {2 Combinators} *) - -val seq : ?stop:bool parser -> 'a parser -> 'a Seq.t parser -(** [seq p] is a sequence that uses [p] to get the next item. - - A sequence node can only be used while the stream is at - the expected position, and will raise [Invalid_argument] - if any bytes have been consumed in the meantime. This - also means that each node can only be used once; use - {!Seq.memoize} to make the sequence persistent. - - It is not necessary to consume all the elements of the - sequence. - - Example ([head 4] is a parser that takes 4 lines): - - {[ - let head n r = - r |> Buf_read.(seq line) |> Seq.take n |> List.of_seq - ]} - - @param stop This is used before parsing each item. - The sequence ends if this returns [true]. - The default is {!at_end_of_input}. *) - -val pair : 'a parser -> 'b parser -> ('a * 'b) parser -(** [pair a b] is a parser that first uses [a] to parse a value [x], - then uses [b] to parse a value [y], then returns [(x, y)]. - - Note that this module does not support backtracking, so if [b] fails - then the bytes consumed by [a] are lost. *) - -val return : 'a -> 'a parser -(** [return x] is a parser that consumes nothing and always returns [x]. - [return] is just [Fun.const]. *) - -val map : ('a -> 'b) -> ('a parser -> 'b parser) -(** [map f a] is a parser that parses the stream with [a] to get [v], - and then returns [f v]. *) - -val bind : 'a parser -> ('a -> 'b parser) -> 'b parser -(** [bind a f] is a parser that first uses [a] to parse a value [v], - then uses [f v] to select the next parser, and then uses that. *) - -val format_errors : 'a parser -> ('a, [> `Msg of string]) result parser -(** [format_errors p] catches [Failure], [End_of_file] and - [Buffer_limit_exceeded] exceptions and returns them as a formatted error message. *) - -(** Convenient syntax for some of the combinators. *) -module Syntax : sig - val ( let+ ) : 'a parser -> ('a -> 'b) -> 'b parser - (** Syntax for {!map}. *) - - val ( let* ) : 'a parser -> ('a -> 'b parser) -> 'b parser - (** Syntax for {!bind} *) - - val ( and+ ) : 'a parser -> 'b parser -> ('a * 'b) parser - (** Syntax for {!pair} *) - - val ( and* ) : 'a parser -> 'b parser -> ('a * 'b) parser - (** Syntax for {!pair} (same as [and+]). *) - - val ( <*> ) : 'a parser -> 'b parser -> ('a * 'b) parser - (** [a <*> b] is [pair a b]. *) - - val ( <* ) : 'a parser -> 'b parser -> 'a parser - (** [a <* b] is [map fst (pair a b)]. - It parses two things and keeps only the first. *) - - val ( *> ) : 'a parser -> 'b parser -> 'b parser - (** [a *> b] is [map snd (pair a b)]. - It parses two things and keeps only the second. *) -end - -(** {2 Low-level API} *) - -val buffered_bytes : t -> int -(** [buffered_bytes t] is the number of bytes that can be read without - reading from the underlying flow. *) - -val peek : t -> Cstruct.t -(** [peek t] returns a view onto the active part of [t]'s internal buffer. - - Performing any operation that might add to the buffer may invalidate this, - so it should be used immediately and then forgotten. - - [Cstruct.length (peek t) = buffered_bytes t]. *) - -val ensure : t -> int -> unit -(** [ensure t n] ensures that the buffer contains at least [n] bytes of data. - - If not, it reads from the flow until there is. - - [buffered_bytes (ensure t n) >= n]. - - @raise End_of_file if the flow ended before [n] bytes were available - @raise Buffer_limit_exceeded if [n] exceeds the buffer's maximum size *) - -val consume : t -> int -> unit -(** [consume t n] discards the first [n] bytes from [t]'s buffer. - - Use this after {!peek} to mark some bytes as consumed. - - [buffered_bytes t' = buffered_bytes t - n] - - Note: unlike {!skip}, this will not read data from the underlying flow. *) - -val consumed_bytes : t -> int -(** [consumed_bytes t] is the total number of bytes consumed. - - i.e. it is the offset into the stream of the next byte to be parsed. *) - -val eof_seen : t -> bool -(** [eof_seen t] indicates whether we've received [End_of_file] from the underlying flow. - - If so, there will never be any further data beyond what [peek] already returns. - - Note that this returns [false] if we're at the end of the stream but don't know it yet. - Use {!at_end_of_input} to be sure. *) +(** This module provides fairly efficient non-backtracking parsers. + It is modelled on Angstrom's API, and you should use that if + backtracking is needed. + + Example: + {[ + let r = Buf_read.of_flow flow ~max_size:1_000_000 in + Buf_read.line r + ]} +*) + +open Std + +type t +(** An input buffer. *) + +exception Buffer_limit_exceeded +(** Raised if parsing an item would require enlarging the buffer beyond its configured limit. *) + +type 'a parser = t -> 'a +(** An ['a parser] is a function that consumes and returns a value of type ['a]. + @raise Failure The flow can't be parsed as a value of type ['a]. + @raise End_of_file The flow ended without enough data to parse an ['a]. + @raise Buffer_limit_exceeded Parsing the value would exceed the configured size limit. *) + +val parse : ?initial_size:int -> max_size:int -> 'a parser -> _ Flow.source -> ('a, [> `Msg of string]) result +(** [parse p flow ~max_size] uses [p] to parse everything in [flow]. + + It is a convenience function that does + {[ + let buf = of_flow flow ~max_size in + format_errors (p <* end_of_input) buf + ]} + + @param initial_size see {!of_flow}. *) + +val parse_exn : ?initial_size:int -> max_size:int -> 'a parser -> _ Flow.source -> 'a +(** [parse_exn] wraps {!parse}, but raises [Failure msg] if that returns [Error (`Msg msg)]. + + Catching exceptions with [parse] and then raising them might seem pointless, + but this has the effect of turning e.g. an [End_of_file] exception into a [Failure] + with a more user-friendly message. *) + +val parse_string : 'a parser -> string -> ('a, [> `Msg of string]) result +(** [parse_string p s] uses [p] to parse everything in [s]. + It is defined as [format_errors (p <* end_of_input) (of_string s)] *) + +val parse_string_exn : 'a parser -> string -> 'a +(** [parse_string_exn] is like {!parse_string}, but handles errors like {!parse_exn}. *) + +val of_flow : ?initial_size:int -> max_size:int -> _ Flow.source -> t +(** [of_flow ~max_size flow] is a buffered reader backed by [flow]. + + @param initial_size The initial amount of memory to allocate for the buffer. + @param max_size The maximum size to which the buffer may grow. + This must be large enough to hold the largest single item + you want to parse (e.g. the longest line, if using + {!line}), plus any terminator needed to know the value is + complete (e.g. the newline character(s)). This is just to + prevent a run-away input from consuming all memory, and + you can usually just set it much larger than you expect + to need. *) + +val of_buffer : Cstruct.buffer -> t +(** [of_buffer buf] is a reader that reads from [buf]. + [buf] is used directly, without being copied. + [eof_seen (of_buffer buf) = true]. + This module will not modify [buf] itself, but it will expose it via {!peek}. *) + +val of_string : string -> t +(** [of_string s] is a reader that reads from [s]. *) + +val as_flow : t -> Flow.source_ty r +(** [as_flow t] is a buffered flow. + + Reading from it will return data from the buffer, + only reading the underlying flow if the buffer is empty. *) + +(** {2 Reading data} *) + +val line : string parser +(** [line] parses one line. + + Lines can be terminated by either LF or CRLF. + The returned string does not include the terminator. + + If [End_of_file] is reached after seeing some data but before seeing a line + terminator, the data seen is returned as the last line. *) + +val lines : string Seq.t parser +(** [lines] returns a sequence that lazily reads the next line until the end of the input is reached. + + [lines = seq line ~stop:at_end_of_input] *) + +val char : char -> unit parser +(** [char c] checks that the next byte is [c] and consumes it. + @raise Failure if the next byte is not [c] *) + +val any_char : char parser +(** [any_char] parses one character. *) + +val peek_char : char option parser +(** [peek_char] returns [Some c] where [c] is the next character, but does not consume it. + + Returns [None] at the end of the input stream rather than raising [End_of_file]. *) + +val string : string -> unit parser +(** [string s] checks that [s] is the next string in the stream and consumes it. + + @raise Failure if [s] is not a prefix of the stream. *) + +val uint8 : int parser +(** [uint8] parses the next byte as an unsigned 8-bit integer. *) + +(** Big endian parsers *) +module BE : sig + val uint16 : int parser + (** [uint16] parses the next 2 bytes as the lower 16 bits of an [int] in big-endian byte order *) + + val uint32 : int32 parser + (** [uint32] parses the next 4 bytes as an [int32] in big-endian byte order *) + + val uint48 : int64 parser + (** [uint48] parses the next 6 bytes as a 48-bit unsigned big-endian integer *) + + val uint64 : int64 parser + (** [uint64] parses the next 8 bytes as an [int64] in big-endian byte order *) + + val float : float parser + (** [float] parses the next 4 bytes as a [float] in big-endian byte order *) + + val double : float parser + (** [double] parses the next 8 bytes as a [float] in big-endian byte order *) +end + +(** Little endian parsers *) +module LE : sig + val uint16 : int parser + (** [uint16] parses the next 2 bytes as the lower 16 bits of an [int] in little-endian byte order *) + + val uint32 : int32 parser + (** [uint32] parses the next 4 bytes as an [int32] in little-endian byte order *) + + val uint48 : int64 parser + (** [uint48] parses the next 6 bytes as a 48-bit unsigned big-endian integer *) + + val uint64 : int64 parser + (** [uint64] parses the next 8 bytes as an [int64] in little-endian byte order *) + + val float : float parser + (** [float] parses the next 4 bytes as a [float] in little-endian byte order *) + + val double : float parser + (** [double] parses the next 8 bytes as a [float] in little-endian byte order *) +end + +val take : int -> string parser +(** [take n] takes exactly [n] bytes from the input. *) + +val take_all : string parser +(** [take_all] takes all remaining data until end-of-file. + + Returns [""] if already at end-of-file. + + @raise Buffer_limit_exceeded if the remaining data exceeds or equals the buffer limit + (it needs one extra byte to confirm it has reached end-of-file). *) + +val take_while : (char -> bool) -> string parser +(** [take_while p] finds the first byte for which [p] is false + and consumes and returns all bytes before that. + + If [p] is true for all remaining bytes, it returns everything until end-of-file. + + It will return the empty string if there are no matching characters + (and therefore never raises [End_of_file]). *) + +val take_while1 : (char -> bool) -> string parser +(** [take_while1 p] is like [take_while]. However, the parser fails with "take_while1" + if at least one character of input hasn't been consumed by the parser. *) + +val skip_while : (char -> bool) -> unit parser +(** [skip_while p] skips zero or more bytes for which [p] is [true]. + + [skip_while p t] does the same thing as [ignore (take_while p t)], + except that it is not limited by the buffer size. *) + +val skip_while1 : (char -> bool) -> unit parser +(** [skip_while1 p] is like [skip_while]. However, the parser fails with "skip_while1" if + at least one character of input hasn't been skipped. *) + +val skip : int -> unit parser +(** [skip n] discards the next [n] bytes. + + [skip n] = [map ignore (take n)], + except that the number of skipped bytes may be larger than the buffer (it will not grow). + + Note: if [End_of_file] is raised, all bytes in the stream will have been consumed. *) + +val at_end_of_input : bool parser +(** [at_end_of_input] returns [true] when at the end of the stream, or + [false] if there is at least one more byte to be read. *) + +val end_of_input : unit parser +(** [end_of_input] checks that there are no further bytes in the stream. + @raise Failure if there are further bytes *) + +(** {2 Combinators} *) + +val seq : ?stop:bool parser -> 'a parser -> 'a Seq.t parser +(** [seq p] is a sequence that uses [p] to get the next item. + + A sequence node can only be used while the stream is at + the expected position, and will raise [Invalid_argument] + if any bytes have been consumed in the meantime. This + also means that each node can only be used once; use + {!Seq.memoize} to make the sequence persistent. + + It is not necessary to consume all the elements of the + sequence. + + Example ([head 4] is a parser that takes 4 lines): + + {[ + let head n r = + r |> Buf_read.(seq line) |> Seq.take n |> List.of_seq + ]} + + @param stop This is used before parsing each item. + The sequence ends if this returns [true]. + The default is {!at_end_of_input}. *) + +val pair : 'a parser -> 'b parser -> ('a * 'b) parser +(** [pair a b] is a parser that first uses [a] to parse a value [x], + then uses [b] to parse a value [y], then returns [(x, y)]. + + Note that this module does not support backtracking, so if [b] fails + then the bytes consumed by [a] are lost. *) + +val return : 'a -> 'a parser +(** [return x] is a parser that consumes nothing and always returns [x]. + [return] is just [Fun.const]. *) + +val map : ('a -> 'b) -> ('a parser -> 'b parser) +(** [map f a] is a parser that parses the stream with [a] to get [v], + and then returns [f v]. *) + +val bind : 'a parser -> ('a -> 'b parser) -> 'b parser +(** [bind a f] is a parser that first uses [a] to parse a value [v], + then uses [f v] to select the next parser, and then uses that. *) + +val format_errors : 'a parser -> ('a, [> `Msg of string]) result parser +(** [format_errors p] catches [Failure], [End_of_file] and + [Buffer_limit_exceeded] exceptions and returns them as a formatted error message. *) + +(** Convenient syntax for some of the combinators. *) +module Syntax : sig + val ( let+ ) : 'a parser -> ('a -> 'b) -> 'b parser + (** Syntax for {!map}. *) + + val ( let* ) : 'a parser -> ('a -> 'b parser) -> 'b parser + (** Syntax for {!bind} *) + + val ( and+ ) : 'a parser -> 'b parser -> ('a * 'b) parser + (** Syntax for {!pair} *) + + val ( and* ) : 'a parser -> 'b parser -> ('a * 'b) parser + (** Syntax for {!pair} (same as [and+]). *) + + val ( <*> ) : 'a parser -> 'b parser -> ('a * 'b) parser + (** [a <*> b] is [pair a b]. *) + + val ( <* ) : 'a parser -> 'b parser -> 'a parser + (** [a <* b] is [map fst (pair a b)]. + It parses two things and keeps only the first. *) + + val ( *> ) : 'a parser -> 'b parser -> 'b parser + (** [a *> b] is [map snd (pair a b)]. + It parses two things and keeps only the second. *) +end + +(** {2 Low-level API} *) + +val buffered_bytes : t -> int +(** [buffered_bytes t] is the number of bytes that can be read without + reading from the underlying flow. *) + +val peek : t -> Cstruct.t +(** [peek t] returns a view onto the active part of [t]'s internal buffer. + + Performing any operation that might add to the buffer may invalidate this, + so it should be used immediately and then forgotten. + + [Cstruct.length (peek t) = buffered_bytes t]. *) + +val ensure : t -> int -> unit +(** [ensure t n] ensures that the buffer contains at least [n] bytes of data. + + If not, it reads from the flow until there is. + + [buffered_bytes (ensure t n) >= n]. + + @raise End_of_file if the flow ended before [n] bytes were available + @raise Buffer_limit_exceeded if [n] exceeds the buffer's maximum size *) + +val consume : t -> int -> unit +(** [consume t n] discards the first [n] bytes from [t]'s buffer. + + Use this after {!peek} to mark some bytes as consumed. + + [buffered_bytes t' = buffered_bytes t - n] + + Note: unlike {!skip}, this will not read data from the underlying flow. *) + +val consumed_bytes : t -> int +(** [consumed_bytes t] is the total number of bytes consumed. + + i.e. it is the offset into the stream of the next byte to be parsed. *) + +val eof_seen : t -> bool +(** [eof_seen t] indicates whether we've received [End_of_file] from the underlying flow. + + If so, there will never be any further data beyond what [peek] already returns. + + Note that this returns [false] if we're at the end of the stream but don't know it yet. + Use {!at_end_of_input} to be sure. *) diff --git a/lib_eio/buf_write.ml b/lib_eio/buf_write.ml index cf5e290e4..8434a9e6e 100644 --- a/lib_eio/buf_write.ml +++ b/lib_eio/buf_write.ml @@ -1,581 +1,581 @@ -(* This module is based on code from Faraday (0.7.2), which had the following - license: - - ---------------------------------------------------------------------------- - Copyright (c) 2016 Inhabited Type LLC. - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - ----------------------------------------------------------------------------*) - - -type bigstring = Bigstringaf.t - -exception Dequeue_empty - -module Deque(T:sig type t val sentinel : t end) : sig - type elem = T.t - - type t - - val create : int -> t - (* [t = create n] creates a new deque with initial capacity [n]. - - [to_list t = []] *) - - val is_empty : t -> bool - (* [is_empty t = (to_list t = []) *) - - val enqueue : elem -> t -> unit - (* [enqueue elem t] - - [to_list t'] = to_list t @ [elem] *) - - val dequeue_exn : t -> elem - (* [dequeue_exn t = List.hd (to_list t)] - - [to_list t' = List.tl (to_list t)] *) - - val enqueue_front : elem -> t -> unit - (* [enqueue_front elem t] - - to_list t' = elem :: to_list t *) - - val to_list : t -> elem list -end = struct - type elem = T.t - - type t = - { mutable elements : elem array - ; mutable front : int - ; mutable back : int } - - let sentinel = T.sentinel - - let create size = - { elements = Array.make size sentinel; front = 0; back = 0 } - - let is_empty t = - t.front = t.back - - let ensure_space t = - if t.back = Array.length t.elements - 1 then begin - let len = t.back - t.front in - if t.front > 0 then begin - (* Shift everything to the front of the array and then clear out - * dangling pointers to elements from their previous locations. *) - Array.blit t.elements t.front t.elements 0 len; - Array.fill t.elements len t.front sentinel - end else begin - let old = t.elements in - let new_ = Array.(make (2 * length old) sentinel) in - Array.blit old t.front new_ 0 len; - t.elements <- new_ - end; - t.front <- 0; - t.back <- len - end - - let enqueue e t = - ensure_space t; - t.elements.(t.back) <- e; - t.back <- t.back + 1 - - let dequeue_exn t = - if is_empty t then - raise Dequeue_empty - else - let result = Array.unsafe_get t.elements t.front in - Array.unsafe_set t.elements t.front sentinel; - t.front <- t.front + 1; - result - - let enqueue_front e t = - (* This is in general not true for Deque data structures, but the usage - * below ensures that there is always space to push an element back on the - * front. An [enqueue_front] is always preceded by a [dequeue], with no - * intervening operations. *) - assert (t.front > 0); - t.front <- t.front - 1; - t.elements.(t.front) <- e - - let to_list t = - let result = ref [] in - for i = t.back - 1 downto t.front do - result := t.elements.(i) :: !result - done; - !result -end - -module Buffers = Deque(struct - type t = Cstruct.t - let sentinel = - let deadbeef = "\222\173\190\239" in - Cstruct.of_string deadbeef -end) - -module Flushes = Deque(struct - type t = int * ((unit, exn) result Promise.u) - let sentinel = - let _, r = Promise.create () in - Promise.resolve_ok r (); - 0, r - end) - -type state = - | Active - | Paused - | Closed - -type t = - { mutable buffer : bigstring - ; mutable scheduled_pos : int (* How much of [buffer] is in [scheduled] *) - ; mutable write_pos : int (* How much of [buffer] has been written to *) - ; scheduled : Buffers.t - ; flushed : Flushes.t - ; mutable bytes_received : int (* Total scheduled bytes. Wraps. *) - ; mutable bytes_written : int (* Total written bytes. Wraps. *) - ; mutable state : state - ; mutable wake_writer : unit -> unit - ; mutable printf : (Format.formatter * bool ref) option - } -(* Invariant: [write_pos >= scheduled_pos] *) - -exception Flush_aborted - -let writable_exn t = - match t.state with - | Active | Paused -> () - | Closed -> - failwith "cannot write to closed writer" - -let wake_writer t = - match t.state with - | Paused -> () - | Active | Closed -> - let wake = t.wake_writer in - if wake != ignore then ( - t.wake_writer <- ignore; - wake () - ) - -(* Schedule [cs] now, without any checks. Users use {!schedule_cstruct} instead. *) -let schedule_iovec t cs = - t.bytes_received <- t.bytes_received + Cstruct.length cs; - Buffers.enqueue cs t.scheduled - -(* Schedule all pending data in [buffer]. *) -let flush_buffer t = - let len = t.write_pos - t.scheduled_pos in - if len > 0 then begin - let off = t.scheduled_pos in - schedule_iovec t (Cstruct.of_bigarray ~off ~len t.buffer); - t.scheduled_pos <- t.write_pos - end - -let free_bytes_in_buffer t = - let buf_len = Bigstringaf.length t.buffer in - buf_len - t.write_pos - -let schedule_cstruct t cs = - writable_exn t; - flush_buffer t; - if Cstruct.length cs > 0 then ( - schedule_iovec t cs; - wake_writer t; - ) - -let ensure_space t len = - if free_bytes_in_buffer t < len then begin - flush_buffer t; - t.buffer <- Bigstringaf.create (max (Bigstringaf.length t.buffer) len); - t.write_pos <- 0; - t.scheduled_pos <- 0 - end - -let advance_pos t n = - t.write_pos <- t.write_pos + n; - wake_writer t - -let write_gen t ~blit ~off ~len a = - writable_exn t; - ensure_space t len; - blit a ~src_off:off t.buffer ~dst_off:t.write_pos ~len; - advance_pos t len - -let string = - let blit = Bigstringaf.blit_from_string in - fun t ?(off=0) ?len a -> - let len = - match len with - | None -> String.length a - off - | Some len -> len - in - write_gen t ~blit ~off ~len a - -let bytes = - let blit = Bigstringaf.blit_from_bytes in - fun t ?(off=0) ?len a -> - let len = - match len with - | None -> Bytes.length a - off - | Some len -> len - in - write_gen t ~blit ~off ~len a - -let cstruct t { Cstruct.buffer; off; len } = - write_gen t ~off ~len buffer - ~blit:Bigstringaf.unsafe_blit - -let char t c = - writable_exn t; - ensure_space t 1; - Bigstringaf.unsafe_set t.buffer t.write_pos c; - advance_pos t 1 - -let uint8 t b = - writable_exn t; - ensure_space t 1; - Bigstringaf.unsafe_set t.buffer t.write_pos (Char.unsafe_chr b); - advance_pos t 1 - -module BE = struct - let uint16 t i = - writable_exn t; - ensure_space t 2; - Bigstringaf.unsafe_set_int16_be t.buffer t.write_pos i; - advance_pos t 2 - - let uint32 t i = - writable_exn t; - ensure_space t 4; - Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos i; - advance_pos t 4 - - let uint48 t i = - writable_exn t; - ensure_space t 6; - Bigstringaf.unsafe_set_int16_be t.buffer t.write_pos - Int64.(to_int (shift_right_logical i 32)); - Bigstringaf.unsafe_set_int32_be t.buffer (t.write_pos + 2) - Int64.(to_int32 i); - advance_pos t 6 - - let uint64 t i = - writable_exn t; - ensure_space t 8; - Bigstringaf.unsafe_set_int64_be t.buffer t.write_pos i; - advance_pos t 8 - - let float t f = - writable_exn t; - ensure_space t 4; - Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos (Int32.bits_of_float f); - advance_pos t 4 - - let double t d = - writable_exn t; - ensure_space t 8; - Bigstringaf.unsafe_set_int64_be t.buffer t.write_pos (Int64.bits_of_float d); - advance_pos t 8 -end - -module LE = struct - let uint16 t i = - writable_exn t; - ensure_space t 2; - Bigstringaf.unsafe_set_int16_le t.buffer t.write_pos i; - advance_pos t 2 - - let uint32 t i = - writable_exn t; - ensure_space t 4; - Bigstringaf.unsafe_set_int32_le t.buffer t.write_pos i; - advance_pos t 4 - - let uint48 t i = - writable_exn t; - ensure_space t 6; - Bigstringaf.unsafe_set_int16_le t.buffer t.write_pos - Int64.(to_int i); - Bigstringaf.unsafe_set_int32_le t.buffer (t.write_pos + 2) - Int64.(to_int32 (shift_right_logical i 16)); - advance_pos t 6 - - let uint64 t i = - writable_exn t; - ensure_space t 8; - Bigstringaf.unsafe_set_int64_le t.buffer t.write_pos i; - advance_pos t 8 - - let float t f = - writable_exn t; - ensure_space t 4; - Bigstringaf.unsafe_set_int32_le t.buffer t.write_pos (Int32.bits_of_float f); - advance_pos t 4 - - let double t d = - writable_exn t; - ensure_space t 8; - Bigstringaf.unsafe_set_int64_le t.buffer t.write_pos (Int64.bits_of_float d); - advance_pos t 8 -end - -let close t = - t.state <- Closed; - flush_buffer t; - wake_writer t - -let is_closed t = - match t.state with - | Closed -> true - | Active | Paused -> false - -let abort t = - close t; - let rec aux () = - match Flushes.dequeue_exn t.flushed with - | exception Dequeue_empty -> () - | (_threshold, r) -> - Promise.resolve_error r Flush_aborted; - aux () - in - aux () - -let of_buffer ?sw buffer = - let t = { buffer - ; write_pos = 0 - ; scheduled_pos = 0 - ; scheduled = Buffers.create 4 - ; flushed = Flushes.create 1 - ; bytes_received = 0 - ; bytes_written = 0 - ; state = Active - ; wake_writer = ignore - ; printf = None - } - in - begin match sw with - | Some sw -> Switch.on_release sw (fun () -> abort t) - | None -> () - end; - t - -let create ?sw size = - of_buffer ?sw (Bigstringaf.create size) - -let pending_bytes t = - (t.write_pos - t.scheduled_pos) + (t.bytes_received - t.bytes_written) - -let has_pending_output t = - pending_bytes t <> 0 - -let pause t = - match t.state with - | Active -> t.state <- Paused - | Paused | Closed -> () - -let unpause t = - match t.state with - | Active | Closed -> () - | Paused -> - t.state <- Active; - if has_pending_output t then - wake_writer t - -let flush t = - flush_buffer t; - unpause t; - if not (Buffers.is_empty t.scheduled) then ( - let p, r = Promise.create () in - Flushes.enqueue (t.bytes_received, r) t.flushed; - Promise.await_exn p - ) - -let make_formatter t = - Format.make_formatter - (fun buf off len -> write_gen t buf ~off ~len ~blit:Bigstringaf.blit_from_string) - (fun () -> flush t) - -let printf t = - let ppf, is_formatting = - match t.printf with - | Some (_, is_formatting as x) -> - is_formatting := true; - x - | None -> - let is_formatting = ref true in - let ppf = - Format.make_formatter - (fun buf off len -> write_gen t buf ~off ~len ~blit:Bigstringaf.blit_from_string) - (fun () -> - (* As per the Format module manual, an explicit flush writes to the - output channel and ensures that "all pending text is displayed" - and "these explicit flush calls [...] could dramatically impact efficiency". - Therefore it is clear that we need to call `flush t` instead of `flush_buffer t`. *) - if !is_formatting then flush t) - in - t.printf <- Some (ppf, is_formatting); - ppf, is_formatting - in - Format.kfprintf (fun ppf -> - if not !is_formatting then raise (Sys_error "Buf_write.printf: invalid concurrent access"); - (* Ensure that [ppf]'s internal buffer is flushed to [t], but without flushing [t] itself: *) - is_formatting := false; - Format.pp_print_flush ppf () - ) ppf - -let rec shift_buffers t written = - match Buffers.dequeue_exn t.scheduled with - | { Cstruct.len; _ } as iovec -> - if len <= written then - shift_buffers t (written - len) - else - Buffers.enqueue_front (Cstruct.shift iovec written) t.scheduled - | exception Dequeue_empty -> - assert (written = 0); - if t.scheduled_pos = t.write_pos then begin - t.scheduled_pos <- 0; - t.write_pos <- 0 - end - -(* Resolve any flushes that are now due. *) -let rec shift_flushes t = - match Flushes.dequeue_exn t.flushed with - | exception Dequeue_empty -> () - | (threshold, r) as flush -> - (* Be careful: [bytes_written] and [threshold] both wrap, so subtract first. *) - if t.bytes_written - threshold >= 0 then ( - (* We have written at least up to [threshold] - (or we're more than [max_int] behind, which we assume won't happen). *) - Promise.resolve_ok r (); - shift_flushes t - ) else ( - Flushes.enqueue_front flush t.flushed - ) - -let shift t written = - shift_buffers t written; - t.bytes_written <- t.bytes_written + written; - shift_flushes t - -let rec await_batch t = - flush_buffer t; - match t.state, has_pending_output t with - | Closed, false -> raise End_of_file - | (Active | Closed), true -> Buffers.to_list t.scheduled - | Paused, _ | Active, false -> - Suspend.enter "Buf_write.await_batch" (fun ctx enqueue -> - Fiber_context.set_cancel_fn ctx (fun ex -> - t.wake_writer <- ignore; - enqueue (Error ex) - ); - t.wake_writer <- (fun () -> - (* Our caller has already set [wake_writer <- ignore]. *) - Fiber_context.clear_cancel_fn ctx; - enqueue (Ok ()) - ); - ); - await_batch t - -(* We have to do our own copy, because we can't [shift] until the write is complete. *) -let copy t flow = - let rec aux () = - let iovecs = await_batch t in - let wrote = Flow.single_write flow iovecs in - shift t wrote; - aux () - in - try aux () - with End_of_file -> () - -let with_flow ?(initial_size=0x1000) flow fn = - Switch.run ~name:"Buf_write.with_flow" @@ fun sw -> - let t = create ~sw initial_size in - Fiber.fork ~sw (fun () -> copy t flow); - match fn t with - | x -> - close t; - x - | exception ex -> - close t; - (* Raising the exception will cancel the writer thread, so do a flush first. - We don't want to flush if cancelled, but in that case the switch will - end the writer thread itself (and [flush] will raise). *) - flush t; - raise ex - -let rec serialize t writev = - match await_batch t with - | exception End_of_file -> Ok () - | iovecs -> - match writev iovecs with - | Error `Closed as e -> close t; e - | Ok n -> - shift t n; - if not (Buffers.is_empty t.scheduled) then Fiber.yield (); - serialize t writev - -let serialize_to_string t = - close t; - match await_batch t with - | exception End_of_file -> "" - | iovecs -> - let len = Cstruct.lenv iovecs in - let bytes = Bytes.create len in - let pos = ref 0 in - List.iter (function - | { Cstruct.buffer; off; len } -> - Bigstringaf.unsafe_blit_to_bytes buffer ~src_off:off bytes ~dst_off:!pos ~len; - pos := !pos + len) - iovecs; - shift t len; - assert (not (has_pending_output t)); - Bytes.unsafe_to_string bytes - -let serialize_to_cstruct t = - close t; - match await_batch t with - | exception End_of_file -> Cstruct.empty - | iovecs -> - let data = Cstruct.concat iovecs in - shift t (Cstruct.length data); - assert (not (has_pending_output t)); - data - -let drain = - let rec loop t acc = - match await_batch t with - | exception End_of_file -> acc - | iovecs -> - let len = Cstruct.lenv iovecs in - shift t len; - loop t (len + acc) - in - fun t -> loop t 0 +(* This module is based on code from Faraday (0.7.2), which had the following + license: + + ---------------------------------------------------------------------------- + Copyright (c) 2016 Inhabited Type LLC. + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + ----------------------------------------------------------------------------*) + + +type bigstring = Bigstringaf.t + +exception Dequeue_empty + +module Deque(T:sig type t val sentinel : t end) : sig + type elem = T.t + + type t + + val create : int -> t + (* [t = create n] creates a new deque with initial capacity [n]. + + [to_list t = []] *) + + val is_empty : t -> bool + (* [is_empty t = (to_list t = []) *) + + val enqueue : elem -> t -> unit + (* [enqueue elem t] + + [to_list t'] = to_list t @ [elem] *) + + val dequeue_exn : t -> elem + (* [dequeue_exn t = List.hd (to_list t)] + + [to_list t' = List.tl (to_list t)] *) + + val enqueue_front : elem -> t -> unit + (* [enqueue_front elem t] + + to_list t' = elem :: to_list t *) + + val to_list : t -> elem list +end = struct + type elem = T.t + + type t = + { mutable elements : elem array + ; mutable front : int + ; mutable back : int } + + let sentinel = T.sentinel + + let create size = + { elements = Array.make size sentinel; front = 0; back = 0 } + + let is_empty t = + t.front = t.back + + let ensure_space t = + if t.back = Array.length t.elements - 1 then begin + let len = t.back - t.front in + if t.front > 0 then begin + (* Shift everything to the front of the array and then clear out + * dangling pointers to elements from their previous locations. *) + Array.blit t.elements t.front t.elements 0 len; + Array.fill t.elements len t.front sentinel + end else begin + let old = t.elements in + let new_ = Array.(make (2 * length old) sentinel) in + Array.blit old t.front new_ 0 len; + t.elements <- new_ + end; + t.front <- 0; + t.back <- len + end + + let enqueue e t = + ensure_space t; + t.elements.(t.back) <- e; + t.back <- t.back + 1 + + let dequeue_exn t = + if is_empty t then + raise Dequeue_empty + else + let result = Array.unsafe_get t.elements t.front in + Array.unsafe_set t.elements t.front sentinel; + t.front <- t.front + 1; + result + + let enqueue_front e t = + (* This is in general not true for Deque data structures, but the usage + * below ensures that there is always space to push an element back on the + * front. An [enqueue_front] is always preceded by a [dequeue], with no + * intervening operations. *) + assert (t.front > 0); + t.front <- t.front - 1; + t.elements.(t.front) <- e + + let to_list t = + let result = ref [] in + for i = t.back - 1 downto t.front do + result := t.elements.(i) :: !result + done; + !result +end + +module Buffers = Deque(struct + type t = Cstruct.t + let sentinel = + let deadbeef = "\222\173\190\239" in + Cstruct.of_string deadbeef +end) + +module Flushes = Deque(struct + type t = int * ((unit, exn) result Promise.u) + let sentinel = + let _, r = Promise.create () in + Promise.resolve_ok r (); + 0, r + end) + +type state = + | Active + | Paused + | Closed + +type t = + { mutable buffer : bigstring + ; mutable scheduled_pos : int (* How much of [buffer] is in [scheduled] *) + ; mutable write_pos : int (* How much of [buffer] has been written to *) + ; scheduled : Buffers.t + ; flushed : Flushes.t + ; mutable bytes_received : int (* Total scheduled bytes. Wraps. *) + ; mutable bytes_written : int (* Total written bytes. Wraps. *) + ; mutable state : state + ; mutable wake_writer : unit -> unit + ; mutable printf : (Format.formatter * bool ref) option + } +(* Invariant: [write_pos >= scheduled_pos] *) + +exception Flush_aborted + +let writable_exn t = + match t.state with + | Active | Paused -> () + | Closed -> + failwith "cannot write to closed writer" + +let wake_writer t = + match t.state with + | Paused -> () + | Active | Closed -> + let wake = t.wake_writer in + if wake != ignore then ( + t.wake_writer <- ignore; + wake () + ) + +(* Schedule [cs] now, without any checks. Users use {!schedule_cstruct} instead. *) +let schedule_iovec t cs = + t.bytes_received <- t.bytes_received + Cstruct.length cs; + Buffers.enqueue cs t.scheduled + +(* Schedule all pending data in [buffer]. *) +let flush_buffer t = + let len = t.write_pos - t.scheduled_pos in + if len > 0 then begin + let off = t.scheduled_pos in + schedule_iovec t (Cstruct.of_bigarray ~off ~len t.buffer); + t.scheduled_pos <- t.write_pos + end + +let free_bytes_in_buffer t = + let buf_len = Bigstringaf.length t.buffer in + buf_len - t.write_pos + +let schedule_cstruct t cs = + writable_exn t; + flush_buffer t; + if Cstruct.length cs > 0 then ( + schedule_iovec t cs; + wake_writer t; + ) + +let ensure_space t len = + if free_bytes_in_buffer t < len then begin + flush_buffer t; + t.buffer <- Bigstringaf.create (max (Bigstringaf.length t.buffer) len); + t.write_pos <- 0; + t.scheduled_pos <- 0 + end + +let advance_pos t n = + t.write_pos <- t.write_pos + n; + wake_writer t + +let write_gen t ~blit ~off ~len a = + writable_exn t; + ensure_space t len; + blit a ~src_off:off t.buffer ~dst_off:t.write_pos ~len; + advance_pos t len + +let string = + let blit = Bigstringaf.blit_from_string in + fun t ?(off=0) ?len a -> + let len = + match len with + | None -> String.length a - off + | Some len -> len + in + write_gen t ~blit ~off ~len a + +let bytes = + let blit = Bigstringaf.blit_from_bytes in + fun t ?(off=0) ?len a -> + let len = + match len with + | None -> Bytes.length a - off + | Some len -> len + in + write_gen t ~blit ~off ~len a + +let cstruct t { Cstruct.buffer; off; len } = + write_gen t ~off ~len buffer + ~blit:Bigstringaf.unsafe_blit + +let char t c = + writable_exn t; + ensure_space t 1; + Bigstringaf.unsafe_set t.buffer t.write_pos c; + advance_pos t 1 + +let uint8 t b = + writable_exn t; + ensure_space t 1; + Bigstringaf.unsafe_set t.buffer t.write_pos (Char.unsafe_chr b); + advance_pos t 1 + +module BE = struct + let uint16 t i = + writable_exn t; + ensure_space t 2; + Bigstringaf.unsafe_set_int16_be t.buffer t.write_pos i; + advance_pos t 2 + + let uint32 t i = + writable_exn t; + ensure_space t 4; + Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos i; + advance_pos t 4 + + let uint48 t i = + writable_exn t; + ensure_space t 6; + Bigstringaf.unsafe_set_int16_be t.buffer t.write_pos + Int64.(to_int (shift_right_logical i 32)); + Bigstringaf.unsafe_set_int32_be t.buffer (t.write_pos + 2) + Int64.(to_int32 i); + advance_pos t 6 + + let uint64 t i = + writable_exn t; + ensure_space t 8; + Bigstringaf.unsafe_set_int64_be t.buffer t.write_pos i; + advance_pos t 8 + + let float t f = + writable_exn t; + ensure_space t 4; + Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos (Int32.bits_of_float f); + advance_pos t 4 + + let double t d = + writable_exn t; + ensure_space t 8; + Bigstringaf.unsafe_set_int64_be t.buffer t.write_pos (Int64.bits_of_float d); + advance_pos t 8 +end + +module LE = struct + let uint16 t i = + writable_exn t; + ensure_space t 2; + Bigstringaf.unsafe_set_int16_le t.buffer t.write_pos i; + advance_pos t 2 + + let uint32 t i = + writable_exn t; + ensure_space t 4; + Bigstringaf.unsafe_set_int32_le t.buffer t.write_pos i; + advance_pos t 4 + + let uint48 t i = + writable_exn t; + ensure_space t 6; + Bigstringaf.unsafe_set_int16_le t.buffer t.write_pos + Int64.(to_int i); + Bigstringaf.unsafe_set_int32_le t.buffer (t.write_pos + 2) + Int64.(to_int32 (shift_right_logical i 16)); + advance_pos t 6 + + let uint64 t i = + writable_exn t; + ensure_space t 8; + Bigstringaf.unsafe_set_int64_le t.buffer t.write_pos i; + advance_pos t 8 + + let float t f = + writable_exn t; + ensure_space t 4; + Bigstringaf.unsafe_set_int32_le t.buffer t.write_pos (Int32.bits_of_float f); + advance_pos t 4 + + let double t d = + writable_exn t; + ensure_space t 8; + Bigstringaf.unsafe_set_int64_le t.buffer t.write_pos (Int64.bits_of_float d); + advance_pos t 8 +end + +let close t = + t.state <- Closed; + flush_buffer t; + wake_writer t + +let is_closed t = + match t.state with + | Closed -> true + | Active | Paused -> false + +let abort t = + close t; + let rec aux () = + match Flushes.dequeue_exn t.flushed with + | exception Dequeue_empty -> () + | (_threshold, r) -> + Promise.resolve_error r Flush_aborted; + aux () + in + aux () + +let of_buffer ?sw buffer = + let t = { buffer + ; write_pos = 0 + ; scheduled_pos = 0 + ; scheduled = Buffers.create 4 + ; flushed = Flushes.create 1 + ; bytes_received = 0 + ; bytes_written = 0 + ; state = Active + ; wake_writer = ignore + ; printf = None + } + in + begin match sw with + | Some sw -> Switch.on_release sw (fun () -> abort t) + | None -> () + end; + t + +let create ?sw size = + of_buffer ?sw (Bigstringaf.create size) + +let pending_bytes t = + (t.write_pos - t.scheduled_pos) + (t.bytes_received - t.bytes_written) + +let has_pending_output t = + pending_bytes t <> 0 + +let pause t = + match t.state with + | Active -> t.state <- Paused + | Paused | Closed -> () + +let unpause t = + match t.state with + | Active | Closed -> () + | Paused -> + t.state <- Active; + if has_pending_output t then + wake_writer t + +let flush t = + flush_buffer t; + unpause t; + if not (Buffers.is_empty t.scheduled) then ( + let p, r = Promise.create () in + Flushes.enqueue (t.bytes_received, r) t.flushed; + Promise.await_exn p + ) + +let make_formatter t = + Format.make_formatter + (fun buf off len -> write_gen t buf ~off ~len ~blit:Bigstringaf.blit_from_string) + (fun () -> flush t) + +let printf t = + let ppf, is_formatting = + match t.printf with + | Some (_, is_formatting as x) -> + is_formatting := true; + x + | None -> + let is_formatting = ref true in + let ppf = + Format.make_formatter + (fun buf off len -> write_gen t buf ~off ~len ~blit:Bigstringaf.blit_from_string) + (fun () -> + (* As per the Format module manual, an explicit flush writes to the + output channel and ensures that "all pending text is displayed" + and "these explicit flush calls [...] could dramatically impact efficiency". + Therefore it is clear that we need to call `flush t` instead of `flush_buffer t`. *) + if !is_formatting then flush t) + in + t.printf <- Some (ppf, is_formatting); + ppf, is_formatting + in + Format.kfprintf (fun ppf -> + if not !is_formatting then raise (Sys_error "Buf_write.printf: invalid concurrent access"); + (* Ensure that [ppf]'s internal buffer is flushed to [t], but without flushing [t] itself: *) + is_formatting := false; + Format.pp_print_flush ppf () + ) ppf + +let rec shift_buffers t written = + match Buffers.dequeue_exn t.scheduled with + | { Cstruct.len; _ } as iovec -> + if len <= written then + shift_buffers t (written - len) + else + Buffers.enqueue_front (Cstruct.shift iovec written) t.scheduled + | exception Dequeue_empty -> + assert (written = 0); + if t.scheduled_pos = t.write_pos then begin + t.scheduled_pos <- 0; + t.write_pos <- 0 + end + +(* Resolve any flushes that are now due. *) +let rec shift_flushes t = + match Flushes.dequeue_exn t.flushed with + | exception Dequeue_empty -> () + | (threshold, r) as flush -> + (* Be careful: [bytes_written] and [threshold] both wrap, so subtract first. *) + if t.bytes_written - threshold >= 0 then ( + (* We have written at least up to [threshold] + (or we're more than [max_int] behind, which we assume won't happen). *) + Promise.resolve_ok r (); + shift_flushes t + ) else ( + Flushes.enqueue_front flush t.flushed + ) + +let shift t written = + shift_buffers t written; + t.bytes_written <- t.bytes_written + written; + shift_flushes t + +let rec await_batch t = + flush_buffer t; + match t.state, has_pending_output t with + | Closed, false -> raise End_of_file + | (Active | Closed), true -> Buffers.to_list t.scheduled + | Paused, _ | Active, false -> + Suspend.enter "Buf_write.await_batch" (fun ctx enqueue -> + Fiber_context.set_cancel_fn ctx (fun ex -> + t.wake_writer <- ignore; + enqueue (Error ex) + ); + t.wake_writer <- (fun () -> + (* Our caller has already set [wake_writer <- ignore]. *) + Fiber_context.clear_cancel_fn ctx; + enqueue (Ok ()) + ); + ); + await_batch t + +(* We have to do our own copy, because we can't [shift] until the write is complete. *) +let copy t flow = + let rec aux () = + let iovecs = await_batch t in + let wrote = Flow.single_write flow iovecs in + shift t wrote; + aux () + in + try aux () + with End_of_file -> () + +let with_flow ?(initial_size=0x1000) flow fn = + Switch.run ~name:"Buf_write.with_flow" @@ fun sw -> + let t = create ~sw initial_size in + Fiber.fork ~sw (fun () -> copy t flow); + match fn t with + | x -> + close t; + x + | exception ex -> + close t; + (* Raising the exception will cancel the writer thread, so do a flush first. + We don't want to flush if cancelled, but in that case the switch will + end the writer thread itself (and [flush] will raise). *) + flush t; + raise ex + +let rec serialize t writev = + match await_batch t with + | exception End_of_file -> Ok () + | iovecs -> + match writev iovecs with + | Error `Closed as e -> close t; e + | Ok n -> + shift t n; + if not (Buffers.is_empty t.scheduled) then Fiber.yield (); + serialize t writev + +let serialize_to_string t = + close t; + match await_batch t with + | exception End_of_file -> "" + | iovecs -> + let len = Cstruct.lenv iovecs in + let bytes = Bytes.create len in + let pos = ref 0 in + List.iter (function + | { Cstruct.buffer; off; len } -> + Bigstringaf.unsafe_blit_to_bytes buffer ~src_off:off bytes ~dst_off:!pos ~len; + pos := !pos + len) + iovecs; + shift t len; + assert (not (has_pending_output t)); + Bytes.unsafe_to_string bytes + +let serialize_to_cstruct t = + close t; + match await_batch t with + | exception End_of_file -> Cstruct.empty + | iovecs -> + let data = Cstruct.concat iovecs in + shift t (Cstruct.length data); + assert (not (has_pending_output t)); + data + +let drain = + let rec loop t acc = + match await_batch t with + | exception End_of_file -> acc + | iovecs -> + let len = Cstruct.lenv iovecs in + shift t len; + loop t (len + acc) + in + fun t -> loop t 0 diff --git a/lib_eio/buf_write.mli b/lib_eio/buf_write.mli index 219843c29..238246739 100644 --- a/lib_eio/buf_write.mli +++ b/lib_eio/buf_write.mli @@ -1,334 +1,334 @@ -(* This module is based on code from Faraday (0.7.2), which had the following - license: - - ---------------------------------------------------------------------------- - Copyright (c) 2016 Inhabited Type LLC. - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - ----------------------------------------------------------------------------*) - -(** Serialization primitives built for speed and memory-efficiency. - - - Buf_write is designed for writing fast and memory-efficient serializers. - It is based on the Faraday library, but adapted for Eio. - Its core type and related operation gives the user fine-grained control - over copying and allocation behavior while serializing user-defined types, - and presents the output in a form that makes it possible to use vectorized - write operations, such as the [writev][] system call, or any other platform - or application-specific output APIs. - - A Buf_write serializer manages an internal buffer and a queue of output - buffers. The output buffers may be a sub range of the serializer's - internal buffer or one that is user-provided. Buffered writes such as - {!string}, {!char}, {!cstruct}, etc., copy the source bytes into the - serializer's internal buffer. Unbuffered writes are done with - {!schedule_cstruct}, which performs no copying. Instead, it enqueues the - source bytes into the serializer's write queue directly. - - Example: - - {[ - module Write = Eio.Buf_write - - let () = - Eio_mock.Backend.run @@ fun () -> - let stdout = Eio_mock.Flow.make "stdout" in - Write.with_flow stdout (fun w -> - Write.string w "foo"; - Write.string w "bar"; - Eio.Fiber.yield (); - Write.string w "baz"; - ) - ]} - - This combines the first two writes, giving: - - {[ - +stdout: wrote "foobar" - +stdout: wrote "baz" - ]} - *) - -type t -(** The type of a serializer. *) - -exception Flush_aborted -(** Raised when waiting for a flush to complete if the buffer is destroyed instead. *) - -(** {2 Running} *) - -val with_flow : ?initial_size:int -> _ Flow.sink -> (t -> 'a) -> 'a -(** [with_flow flow fn] runs [fn writer], where [writer] is a buffer that flushes to [flow]. - - Concurrently with [fn], it also runs a fiber that copies from [writer] to [flow]. - If this fiber runs out of data to copy then it will suspend itself. - Writing to [writer] will automatically schedule it to be resumed. - This means that pending data is flushed automatically before the process sleeps. - - When [fn] returns, [writer] is automatically closed and any remaining data is flushed - before [with_flow] itself returns. - - @param initial_size The initial size of the buffer used to collect writes. - New buffers will be allocated as needed, with the same size. - If the buffer is too small to contain a write, the size is increased. *) - - -(** {2 Buffered Writes} - - A serializer manages an internal buffer for coalescing small writes. The - size of this buffer is determined when the serializer is created. If the - buffer does not contain sufficient space to service a caller's buffered - write, the serializer will allocate a new buffer of the sufficient size and - use it for the current and subsequent writes. The old buffer will be - garbage collected once all of its contents have been {!flush}ed. *) - -val string : t -> ?off:int -> ?len:int -> string -> unit -(** [string t ?off ?len str] copies [str] into the serializer's - internal buffer. *) - -val bytes : t -> ?off:int -> ?len:int -> Bytes.t -> unit -(** [bytes t ?off ?len bytes] copies [bytes] into the serializer's - internal buffer. It is safe to modify [bytes] after this call returns. *) - -val cstruct : t -> Cstruct.t -> unit -(** [cstruct t cs] copies [cs] into the serializer's internal buffer. - It is safe to modify [cs] after this call returns. - For large cstructs, it may be more efficient to use {!schedule_cstruct}. *) - -val printf : t -> ('a, Format.formatter, unit) format -> 'a -(** [printf t fmt ...] formats the arguments according to the format string [fmt]. - - It supports all formatting and pretty-printing features of the Format module. - The formatter's internal buffer is flushed to [t] after the call, without flushing [t] itself. - Explicit flushes (e.g. using [@.] or [%!]) perform a full (blocking) flush of [t]. *) - -val make_formatter : t -> Format.formatter -(** [make_formatter t] creates a new formatter that writes to [t]. - - Flushing the formatter also flushes [t] itself. *) - -val write_gen - : t - -> blit:('a -> src_off:int -> Cstruct.buffer -> dst_off:int -> len:int -> unit) - -> off:int - -> len:int - -> 'a -> unit -(** [write_gen t ~blit ~off ~len x] copies [x] into the serializer's - internal buffer using the provided [blit] operation. - See {!Bigstring.blit} for documentation of the arguments. *) - -val char : t -> char -> unit -(** [char t c] copies [c] into the serializer's internal buffer. *) - -val uint8 : t -> int -> unit -(** [uint8 t n] copies the lower 8 bits of [n] into the serializer's - internal buffer. *) - - -(** Big endian serializers *) -module BE : sig - val uint16 : t -> int -> unit - (** [uint16 t n] copies the lower 16 bits of [n] into the serializer's - internal buffer in big-endian byte order. *) - - val uint32 : t -> int32 -> unit - (** [uint32 t n] copies [n] into the serializer's internal buffer in - big-endian byte order. *) - - val uint48 : t -> int64 -> unit - (** [uint48 t n] copies the lower 48 bits of [n] into the serializer's - internal buffer in big-endian byte order. *) - - val uint64 : t -> int64 -> unit - (** [uint64 t n] copies [n] into the serializer's internal buffer in - big-endian byte order. *) - - val float : t -> float -> unit - (** [float t n] copies the lower 32 bits of [n] into the serializer's - internal buffer in big-endian byte order. *) - - val double : t -> float -> unit - (** [double t n] copies [n] into the serializer's internal buffer in - big-endian byte order. *) -end - - -(** Little endian serializers *) -module LE : sig - val uint16 : t -> int -> unit - (** [uint16 t n] copies the lower 16 bits of [n] into the - serializer's internal buffer in little-endian byte order. *) - - val uint32 : t -> int32 -> unit - (** [uint32 t n] copies [n] into the serializer's internal buffer in - little-endian byte order. *) - - val uint48 : t -> int64 -> unit - (** [uint48 t n] copies the lower 48 bits of [n] into the serializer's - internal buffer in little-endian byte order. *) - - val uint64 : t -> int64 -> unit - (** [uint64 t n] copies [n] into the serializer's internal buffer in - little-endian byte order. *) - - val float : t -> float -> unit - (** [float t n] copies the lower 32 bits of [n] into the serializer's - internal buffer in little-endian byte order. *) - - val double : t -> float -> unit - (** [double t n] copies [n] into the serializer's internal buffer in - little-endian byte order. *) -end - - -(** {2 Unbuffered Writes} - - Unbuffered writes do not involve copying bytes to the serializer's internal - buffer. *) - -val schedule_cstruct : t -> Cstruct.t -> unit -(** [schedule_cstruct t cs] schedules [cs] to be written. - [cs] is not copied in this process, - so [cs] should only be modified after [t] has been {!flush}ed. *) - - -(** {2 Querying A Serializer's State} *) - -val free_bytes_in_buffer : t -> int -(** [free_bytes_in_buffer t] returns the free space, in bytes, of the - serializer's write buffer. If a write call has a length that exceeds - this value, the serializer will allocate a new buffer that will replace the - serializer's internal buffer for that and subsequent calls. *) - -val has_pending_output : t -> bool -(** [has_pending_output t] is [true] if [t]'s output queue is non-empty. It may - be the case that [t]'s queued output is being serviced by some other thread - of control, but has not yet completed. *) - -val pending_bytes : t -> int -(** [pending_bytes t] is the size of the next write, in bytes, that [t] will - surface to the caller via {!await_batch}. *) - - -(** {2 Control Operations} *) - -val pause : t -> unit -(** [pause t] causes [t] to stop surfacing writes to the user. - This gives the serializer an opportunity to collect additional writes - before sending them to the underlying device, which will increase the write - batch size. - - As one example, code may want to call this function if it's about to - release the OCaml lock and perform a blocking system call, but would like - to batch output across that system call. - - Call {!unpause} to resume writing later. - Note that calling {!flush} or {!close} will automatically call {!unpause} too. *) - -val unpause : t -> unit -(** [unpause t] resumes writing data after a previous call to {!pause}. *) - -val flush : t -> unit -(** [flush t] waits until all prior writes have been successfully completed. - If [t] has no pending writes, [flush] returns immediately. - If [t] is paused then it is unpaused first. - @raise Flush_aborted if {!abort} is called before the data is written. *) - -val close : t -> unit -(** [close t] closes [t]. All subsequent write calls will raise, and any - subsequent {!pause} calls will be ignored. If the serializer has - any pending writes, user code will have an opportunity to service them - before receiving [End_of_file]. Flush callbacks will continue to - be invoked while output is {!shift}ed out of [t] as needed. *) - -val is_closed : t -> bool -(** [is_closed t] is [true] if [close] has been called on [t] and [false] - otherwise. A closed [t] may still have pending output. *) - - -(** {2 Low-level API} - - Low-level operations for running a serializer. *) - -val create : ?sw:Switch.t -> int -> t -(** [create ~sw len] creates a serializer with a fixed-length internal buffer of - length [len]. See the Buffered writes section for details about what happens - when [len] is not large enough to support a write. - @param sw When the switch is finished, {!abort} is called. - If you don't pass a switch, you may want to call [abort] manually on error. *) - -val of_buffer : ?sw:Switch.t -> Cstruct.buffer -> t -(** [of_buffer ~sw buf] creates a serializer, using [buf] as its internal - buffer. The serializer takes ownership of [buf] until the serializer has - been closed and flushed of all output. *) - -val abort : t -> unit -(** [abort t] is like {!close} followed by {!drain}, except that any pending - flush operations fail instead of completing successfully. *) - -val await_batch : t -> Cstruct.t list -(** [await_batch t] returns a list of buffers that should be written. - If no data is currently available, it waits until some is. - After performing a write, call {!shift} with the number of bytes written. - You must accurately report the number of bytes written. Failure to do so - will result in the same bytes being surfaced multiple times. - @raises End_of_file [t] is closed and there is nothing left to write. *) - -val shift : t -> int -> unit -(** [shift t n] removes the first [n] bytes in [t]'s write queue. Any flush - operations called within this span of the write queue will be scheduled - to resume. *) - - -(** {2 Convenience Functions} - - These functions are included for testing, debugging, and general - development. They are not the suggested way of driving a serializer in a - production setting. *) - -val serialize : t -> (Cstruct.t list -> (int, [`Closed]) result) -> (unit, [> `Closed]) result -(** [serialize t writev] calls [writev bufs] each time [t] is ready to write. - In the event that [writev] indicates a partial write, {!serialize} will - call {!Fiber.yield} before continuing. *) - -val serialize_to_string : t -> string -(** [serialize_to_string t] runs [t], collecting the output into a string and - returning it. [serializie_to_string t] immediately closes [t]. *) - -val serialize_to_cstruct : t -> Cstruct.t -(** [serialize_to_cstruct t] runs [t], collecting the output into a cstruct - and returning it. [serialize_to_cstruct t] immediately closes [t]. *) - -val drain : t -> int -(** [drain t] removes all pending writes from [t], returning the number of - bytes that were enqueued to be written and freeing any scheduled - buffers in the process. Note that this does not close [t] itself, - and does not return until [t] has been closed. *) +(* This module is based on code from Faraday (0.7.2), which had the following + license: + + ---------------------------------------------------------------------------- + Copyright (c) 2016 Inhabited Type LLC. + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + ----------------------------------------------------------------------------*) + +(** Serialization primitives built for speed and memory-efficiency. + + + Buf_write is designed for writing fast and memory-efficient serializers. + It is based on the Faraday library, but adapted for Eio. + Its core type and related operation gives the user fine-grained control + over copying and allocation behavior while serializing user-defined types, + and presents the output in a form that makes it possible to use vectorized + write operations, such as the [writev][] system call, or any other platform + or application-specific output APIs. + + A Buf_write serializer manages an internal buffer and a queue of output + buffers. The output buffers may be a sub range of the serializer's + internal buffer or one that is user-provided. Buffered writes such as + {!string}, {!char}, {!cstruct}, etc., copy the source bytes into the + serializer's internal buffer. Unbuffered writes are done with + {!schedule_cstruct}, which performs no copying. Instead, it enqueues the + source bytes into the serializer's write queue directly. + + Example: + + {[ + module Write = Eio.Buf_write + + let () = + Eio_mock.Backend.run @@ fun () -> + let stdout = Eio_mock.Flow.make "stdout" in + Write.with_flow stdout (fun w -> + Write.string w "foo"; + Write.string w "bar"; + Eio.Fiber.yield (); + Write.string w "baz"; + ) + ]} + + This combines the first two writes, giving: + + {[ + +stdout: wrote "foobar" + +stdout: wrote "baz" + ]} + *) + +type t +(** The type of a serializer. *) + +exception Flush_aborted +(** Raised when waiting for a flush to complete if the buffer is destroyed instead. *) + +(** {2 Running} *) + +val with_flow : ?initial_size:int -> _ Flow.sink -> (t -> 'a) -> 'a +(** [with_flow flow fn] runs [fn writer], where [writer] is a buffer that flushes to [flow]. + + Concurrently with [fn], it also runs a fiber that copies from [writer] to [flow]. + If this fiber runs out of data to copy then it will suspend itself. + Writing to [writer] will automatically schedule it to be resumed. + This means that pending data is flushed automatically before the process sleeps. + + When [fn] returns, [writer] is automatically closed and any remaining data is flushed + before [with_flow] itself returns. + + @param initial_size The initial size of the buffer used to collect writes. + New buffers will be allocated as needed, with the same size. + If the buffer is too small to contain a write, the size is increased. *) + + +(** {2 Buffered Writes} + + A serializer manages an internal buffer for coalescing small writes. The + size of this buffer is determined when the serializer is created. If the + buffer does not contain sufficient space to service a caller's buffered + write, the serializer will allocate a new buffer of the sufficient size and + use it for the current and subsequent writes. The old buffer will be + garbage collected once all of its contents have been {!flush}ed. *) + +val string : t -> ?off:int -> ?len:int -> string -> unit +(** [string t ?off ?len str] copies [str] into the serializer's + internal buffer. *) + +val bytes : t -> ?off:int -> ?len:int -> Bytes.t -> unit +(** [bytes t ?off ?len bytes] copies [bytes] into the serializer's + internal buffer. It is safe to modify [bytes] after this call returns. *) + +val cstruct : t -> Cstruct.t -> unit +(** [cstruct t cs] copies [cs] into the serializer's internal buffer. + It is safe to modify [cs] after this call returns. + For large cstructs, it may be more efficient to use {!schedule_cstruct}. *) + +val printf : t -> ('a, Format.formatter, unit) format -> 'a +(** [printf t fmt ...] formats the arguments according to the format string [fmt]. + + It supports all formatting and pretty-printing features of the Format module. + The formatter's internal buffer is flushed to [t] after the call, without flushing [t] itself. + Explicit flushes (e.g. using [@.] or [%!]) perform a full (blocking) flush of [t]. *) + +val make_formatter : t -> Format.formatter +(** [make_formatter t] creates a new formatter that writes to [t]. + + Flushing the formatter also flushes [t] itself. *) + +val write_gen + : t + -> blit:('a -> src_off:int -> Cstruct.buffer -> dst_off:int -> len:int -> unit) + -> off:int + -> len:int + -> 'a -> unit +(** [write_gen t ~blit ~off ~len x] copies [x] into the serializer's + internal buffer using the provided [blit] operation. + See {!Bigstring.blit} for documentation of the arguments. *) + +val char : t -> char -> unit +(** [char t c] copies [c] into the serializer's internal buffer. *) + +val uint8 : t -> int -> unit +(** [uint8 t n] copies the lower 8 bits of [n] into the serializer's + internal buffer. *) + + +(** Big endian serializers *) +module BE : sig + val uint16 : t -> int -> unit + (** [uint16 t n] copies the lower 16 bits of [n] into the serializer's + internal buffer in big-endian byte order. *) + + val uint32 : t -> int32 -> unit + (** [uint32 t n] copies [n] into the serializer's internal buffer in + big-endian byte order. *) + + val uint48 : t -> int64 -> unit + (** [uint48 t n] copies the lower 48 bits of [n] into the serializer's + internal buffer in big-endian byte order. *) + + val uint64 : t -> int64 -> unit + (** [uint64 t n] copies [n] into the serializer's internal buffer in + big-endian byte order. *) + + val float : t -> float -> unit + (** [float t n] copies the lower 32 bits of [n] into the serializer's + internal buffer in big-endian byte order. *) + + val double : t -> float -> unit + (** [double t n] copies [n] into the serializer's internal buffer in + big-endian byte order. *) +end + + +(** Little endian serializers *) +module LE : sig + val uint16 : t -> int -> unit + (** [uint16 t n] copies the lower 16 bits of [n] into the + serializer's internal buffer in little-endian byte order. *) + + val uint32 : t -> int32 -> unit + (** [uint32 t n] copies [n] into the serializer's internal buffer in + little-endian byte order. *) + + val uint48 : t -> int64 -> unit + (** [uint48 t n] copies the lower 48 bits of [n] into the serializer's + internal buffer in little-endian byte order. *) + + val uint64 : t -> int64 -> unit + (** [uint64 t n] copies [n] into the serializer's internal buffer in + little-endian byte order. *) + + val float : t -> float -> unit + (** [float t n] copies the lower 32 bits of [n] into the serializer's + internal buffer in little-endian byte order. *) + + val double : t -> float -> unit + (** [double t n] copies [n] into the serializer's internal buffer in + little-endian byte order. *) +end + + +(** {2 Unbuffered Writes} + + Unbuffered writes do not involve copying bytes to the serializer's internal + buffer. *) + +val schedule_cstruct : t -> Cstruct.t -> unit +(** [schedule_cstruct t cs] schedules [cs] to be written. + [cs] is not copied in this process, + so [cs] should only be modified after [t] has been {!flush}ed. *) + + +(** {2 Querying A Serializer's State} *) + +val free_bytes_in_buffer : t -> int +(** [free_bytes_in_buffer t] returns the free space, in bytes, of the + serializer's write buffer. If a write call has a length that exceeds + this value, the serializer will allocate a new buffer that will replace the + serializer's internal buffer for that and subsequent calls. *) + +val has_pending_output : t -> bool +(** [has_pending_output t] is [true] if [t]'s output queue is non-empty. It may + be the case that [t]'s queued output is being serviced by some other thread + of control, but has not yet completed. *) + +val pending_bytes : t -> int +(** [pending_bytes t] is the size of the next write, in bytes, that [t] will + surface to the caller via {!await_batch}. *) + + +(** {2 Control Operations} *) + +val pause : t -> unit +(** [pause t] causes [t] to stop surfacing writes to the user. + This gives the serializer an opportunity to collect additional writes + before sending them to the underlying device, which will increase the write + batch size. + + As one example, code may want to call this function if it's about to + release the OCaml lock and perform a blocking system call, but would like + to batch output across that system call. + + Call {!unpause} to resume writing later. + Note that calling {!flush} or {!close} will automatically call {!unpause} too. *) + +val unpause : t -> unit +(** [unpause t] resumes writing data after a previous call to {!pause}. *) + +val flush : t -> unit +(** [flush t] waits until all prior writes have been successfully completed. + If [t] has no pending writes, [flush] returns immediately. + If [t] is paused then it is unpaused first. + @raise Flush_aborted if {!abort} is called before the data is written. *) + +val close : t -> unit +(** [close t] closes [t]. All subsequent write calls will raise, and any + subsequent {!pause} calls will be ignored. If the serializer has + any pending writes, user code will have an opportunity to service them + before receiving [End_of_file]. Flush callbacks will continue to + be invoked while output is {!shift}ed out of [t] as needed. *) + +val is_closed : t -> bool +(** [is_closed t] is [true] if [close] has been called on [t] and [false] + otherwise. A closed [t] may still have pending output. *) + + +(** {2 Low-level API} + + Low-level operations for running a serializer. *) + +val create : ?sw:Switch.t -> int -> t +(** [create ~sw len] creates a serializer with a fixed-length internal buffer of + length [len]. See the Buffered writes section for details about what happens + when [len] is not large enough to support a write. + @param sw When the switch is finished, {!abort} is called. + If you don't pass a switch, you may want to call [abort] manually on error. *) + +val of_buffer : ?sw:Switch.t -> Cstruct.buffer -> t +(** [of_buffer ~sw buf] creates a serializer, using [buf] as its internal + buffer. The serializer takes ownership of [buf] until the serializer has + been closed and flushed of all output. *) + +val abort : t -> unit +(** [abort t] is like {!close} followed by {!drain}, except that any pending + flush operations fail instead of completing successfully. *) + +val await_batch : t -> Cstruct.t list +(** [await_batch t] returns a list of buffers that should be written. + If no data is currently available, it waits until some is. + After performing a write, call {!shift} with the number of bytes written. + You must accurately report the number of bytes written. Failure to do so + will result in the same bytes being surfaced multiple times. + @raises End_of_file [t] is closed and there is nothing left to write. *) + +val shift : t -> int -> unit +(** [shift t n] removes the first [n] bytes in [t]'s write queue. Any flush + operations called within this span of the write queue will be scheduled + to resume. *) + + +(** {2 Convenience Functions} + + These functions are included for testing, debugging, and general + development. They are not the suggested way of driving a serializer in a + production setting. *) + +val serialize : t -> (Cstruct.t list -> (int, [`Closed]) result) -> (unit, [> `Closed]) result +(** [serialize t writev] calls [writev bufs] each time [t] is ready to write. + In the event that [writev] indicates a partial write, {!serialize} will + call {!Fiber.yield} before continuing. *) + +val serialize_to_string : t -> string +(** [serialize_to_string t] runs [t], collecting the output into a string and + returning it. [serializie_to_string t] immediately closes [t]. *) + +val serialize_to_cstruct : t -> Cstruct.t +(** [serialize_to_cstruct t] runs [t], collecting the output into a cstruct + and returning it. [serialize_to_cstruct t] immediately closes [t]. *) + +val drain : t -> int +(** [drain t] removes all pending writes from [t], returning the number of + bytes that were enqueued to be written and freeing any scheduled + buffers in the process. Note that this does not close [t] itself, + and does not return until [t] has been closed. *) diff --git a/lib_eio/condition.ml b/lib_eio/condition.ml index b74feb1a8..c231af5a0 100644 --- a/lib_eio/condition.ml +++ b/lib_eio/condition.ml @@ -1,119 +1,119 @@ -(* Import these directly because we copy this file for the dscheck tests. *) -module Fiber_context = Eio__core.Private.Fiber_context -module Suspend = Eio__core.Private.Suspend -module Cancel = Eio__core.Cancel - -type t = Broadcast.t - -let create () = Broadcast.create () - -let lock_protected m = - Cancel.protect (fun () -> Eio_mutex.lock m) - -let await_generic ?mutex t = - match - Suspend.enter_unchecked "Condition.await" (fun ctx enqueue -> - match Fiber_context.get_error ctx with - | Some ex -> - Option.iter Eio_mutex.unlock mutex; - enqueue (Error ex) - | None -> - match Broadcast.suspend t (fun () -> enqueue (Ok ())) with - | None -> - Option.iter Eio_mutex.unlock mutex - | Some request -> - Option.iter Eio_mutex.unlock mutex; - Fiber_context.set_cancel_fn ctx (fun ex -> - if Broadcast.cancel request then enqueue (Error ex) - (* else already succeeded *) - ) - ) - with - | () -> Option.iter lock_protected mutex - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - Option.iter lock_protected mutex; - Printexc.raise_with_backtrace ex bt - -let await t mutex = await_generic ~mutex t -let await_no_mutex t = await_generic t - -let broadcast = Broadcast.resume_all - -type request = Broadcast.request option - -let register_immediate = Broadcast.suspend - -let cancel = function - | Some request -> Broadcast.cancel request - | None -> false - -let ensure_cancelled x = ignore (cancel x : bool) - -type state = - | Init - | Waiting of ((unit, exn) result -> unit) - | Done - -(* There main property want is that we don't suspend forever if a broadcast - happened after [fn] started, or if the fiber is cancelled. - - 1. We start in the Init state. - 2. If a broadcast happens here we move to Done. If we later try to suspend, we'll resume immediately. - 3. We run [fn]. If a broadcast happens during this we'll transition to Done as before. - 4. If [fn] raises or wants to stop normally, we return without suspending at all. - 5. Otherwise, we suspend the fiber. - 6. We try to transition from Init to Waiting. - If a broadcast transitioned to Done before this, we resume immediately. - If a broadcast transitions afterwards, [wake] will see the [enqueue] function and wake us. - Therefore, we can only sleep forever if a broadcast never happens after starting [fn]. - 7. If the fiber is cancelled before suspending, we raise on suspend. - If cancelled after suspending and before the request succeeds, we cancel the request and raise. - If cancelled after the request succeeds, [wake] will resume us. -*) -let rec loop_no_mutex t fn = - let state = Atomic.make Init in - let wake () = - match Atomic.exchange state Done with - | Init -> () (* Broadcast happened before we suspended; suspend will notice *) - | Waiting enqueue -> enqueue (Ok ()) - | Done -> assert false - in - let request = Broadcast.suspend t wake in - (* Note: to avoid memory leaks, make sure that [request] is finished in all cases. *) - match fn () with - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - ensure_cancelled request; - Printexc.raise_with_backtrace ex bt - | Some x -> - ensure_cancelled request; - x - | None -> - Suspend.enter_unchecked "Condition.loop_no_mutex" (fun ctx enqueue -> - match Fiber_context.get_error ctx with - | Some ex -> - ensure_cancelled request; - (* If a broadcast already happened, we still cancel. *) - enqueue (Error ex) - | None -> - let waiting = Waiting enqueue in - if Atomic.compare_and_set state Init waiting then ( - (* We were in Init, so [wake] hasn't yet done anything. - When it runs, it will resume us. - We're also not currently cancelled, because we checked above - and cancellations only come from the same thread. *) - Fiber_context.set_cancel_fn ctx (fun ex -> - if cancel request then ( - (* We could set the state to Done here, but there's no need; - we're not racing with anything now. [wake] never runs. *) - enqueue (Error ex) - ) (* else we already got resumed *) - ) - ) else ( - (* State is already Done, but [wake] couldn't wake us then - because we hadn't moved to [waiting]. Resume now. *) - enqueue (Ok ()) - ) - ); - loop_no_mutex t fn +(* Import these directly because we copy this file for the dscheck tests. *) +module Fiber_context = Eio__core.Private.Fiber_context +module Suspend = Eio__core.Private.Suspend +module Cancel = Eio__core.Cancel + +type t = Broadcast.t + +let create () = Broadcast.create () + +let lock_protected m = + Cancel.protect (fun () -> Eio_mutex.lock m) + +let await_generic ?mutex t = + match + Suspend.enter_unchecked "Condition.await" (fun ctx enqueue -> + match Fiber_context.get_error ctx with + | Some ex -> + Option.iter Eio_mutex.unlock mutex; + enqueue (Error ex) + | None -> + match Broadcast.suspend t (fun () -> enqueue (Ok ())) with + | None -> + Option.iter Eio_mutex.unlock mutex + | Some request -> + Option.iter Eio_mutex.unlock mutex; + Fiber_context.set_cancel_fn ctx (fun ex -> + if Broadcast.cancel request then enqueue (Error ex) + (* else already succeeded *) + ) + ) + with + | () -> Option.iter lock_protected mutex + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + Option.iter lock_protected mutex; + Printexc.raise_with_backtrace ex bt + +let await t mutex = await_generic ~mutex t +let await_no_mutex t = await_generic t + +let broadcast = Broadcast.resume_all + +type request = Broadcast.request option + +let register_immediate = Broadcast.suspend + +let cancel = function + | Some request -> Broadcast.cancel request + | None -> false + +let ensure_cancelled x = ignore (cancel x : bool) + +type state = + | Init + | Waiting of ((unit, exn) result -> unit) + | Done + +(* There main property want is that we don't suspend forever if a broadcast + happened after [fn] started, or if the fiber is cancelled. + + 1. We start in the Init state. + 2. If a broadcast happens here we move to Done. If we later try to suspend, we'll resume immediately. + 3. We run [fn]. If a broadcast happens during this we'll transition to Done as before. + 4. If [fn] raises or wants to stop normally, we return without suspending at all. + 5. Otherwise, we suspend the fiber. + 6. We try to transition from Init to Waiting. + If a broadcast transitioned to Done before this, we resume immediately. + If a broadcast transitions afterwards, [wake] will see the [enqueue] function and wake us. + Therefore, we can only sleep forever if a broadcast never happens after starting [fn]. + 7. If the fiber is cancelled before suspending, we raise on suspend. + If cancelled after suspending and before the request succeeds, we cancel the request and raise. + If cancelled after the request succeeds, [wake] will resume us. +*) +let rec loop_no_mutex t fn = + let state = Atomic.make Init in + let wake () = + match Atomic.exchange state Done with + | Init -> () (* Broadcast happened before we suspended; suspend will notice *) + | Waiting enqueue -> enqueue (Ok ()) + | Done -> assert false + in + let request = Broadcast.suspend t wake in + (* Note: to avoid memory leaks, make sure that [request] is finished in all cases. *) + match fn () with + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + ensure_cancelled request; + Printexc.raise_with_backtrace ex bt + | Some x -> + ensure_cancelled request; + x + | None -> + Suspend.enter_unchecked "Condition.loop_no_mutex" (fun ctx enqueue -> + match Fiber_context.get_error ctx with + | Some ex -> + ensure_cancelled request; + (* If a broadcast already happened, we still cancel. *) + enqueue (Error ex) + | None -> + let waiting = Waiting enqueue in + if Atomic.compare_and_set state Init waiting then ( + (* We were in Init, so [wake] hasn't yet done anything. + When it runs, it will resume us. + We're also not currently cancelled, because we checked above + and cancellations only come from the same thread. *) + Fiber_context.set_cancel_fn ctx (fun ex -> + if cancel request then ( + (* We could set the state to Done here, but there's no need; + we're not racing with anything now. [wake] never runs. *) + enqueue (Error ex) + ) (* else we already got resumed *) + ) + ) else ( + (* State is already Done, but [wake] couldn't wake us then + because we hadn't moved to [waiting]. Resume now. *) + enqueue (Ok ()) + ) + ); + loop_no_mutex t fn diff --git a/lib_eio/condition.mli b/lib_eio/condition.mli index 368eec88e..2945c6aaf 100644 --- a/lib_eio/condition.mli +++ b/lib_eio/condition.mli @@ -1,103 +1,103 @@ -(** Waiters call {!await} in a loop as long as some condition is false. - Fibers that modify inputs to the condition must call [broadcast] soon - afterwards so that waiters can re-check the condition. - - Example: - - {[ - let x = ref 0 - let cond = Eio.Condition.create () - let mutex = Eio.Mutex.create () - - let set_x value = - Eio.Mutex.use_rw ~protect:false mutex (fun () -> x := value); - Eio.Condition.broadcast cond - - let await_x p = - Eio.Mutex.use_ro mutex (fun () -> - while not (p !x) do (* [x] cannot change, as mutex is locked. *) - Eio.Condition.await cond mutex (* Mutex is unlocked while suspended. *) - done - ) - ]} - - It is used like this: - - {[ - Fiber.both - (fun () -> - traceln "x = %d" !x; - await_x ((=) 42); - traceln "x = %d" !x - ) - (fun () -> - set_x 5; - Fiber.yield (); - set_x 7; - set_x 42; - ) - ]} -*) - -type t - -val create : unit -> t -(** [create ()] creates a new condition variable. *) - -val await : t -> Eio_mutex.t -> unit -(** [await t mutex] suspends the current fiber until it is notified by [t]. - - You should lock [mutex] before testing whether the condition is true, - and leave it locked while calling this function. - It will be unlocked while the fiber is waiting and locked again before - returning (it is also locked again if the wait is cancelled). *) - -val await_no_mutex : t -> unit -(** [await_no_mutex t] suspends the current fiber until it is notified by [t]. - - This is only safe to use in the case where [t] is only used within a single domain, - and the test for the condition was done without switching fibers. - i.e. you know the condition is still false, and no notification of a change can be sent - until [await_no_mutex] has finished suspending the fiber. *) - -val loop_no_mutex : t -> (unit -> 'a option) -> 'a -(** [loop_no_mutex t update] runs [update ()] until it returns [Some x], then returns [x]. - - If [update ()] returns [None] then it waits until {!broadcast} is called before retrying. - If {!broadcast} is called while [update] is running, [update] runs again immediately. - - For example, if [broadcast config_changed] is performed after some configuration file is changed, then - you can ensure [load_config] will always eventually have seen the latest configuration like this: - - {[ - Fiber.fork_daemon ~sw (fun () -> - loop_no_mutex config_changed (fun () -> load_config (); None) - ) - ]} - - Note that, since there is no lock, [load_config] may see a half-written update if the configuration - is changed again before it finishes reading it, - so it should just log the error and wait to be called again. *) - -val broadcast : t -> unit -(** [broadcast t] wakes up any waiting fibers (by appending them to the run-queue to resume later). - - If no fibers are waiting, nothing happens. *) - -(** {2 Low-level API} - - This is intended only for integrating Eio with other IO libraries. *) - -type request - -val register_immediate : t -> (unit -> unit) -> request -(** [register_immediate t fn] will call [fn ()] the next time {!broadcast} is called. - - [fn] runs immediately from the caller's context, which might not be an Eio thread, or may be a signal handler, etc. - Therefore, care is needed here. This is typically used to send a wake-up event to some non-Eio library. *) - -val cancel : request -> bool -(** [cancel request] tries to cancel a request created with {!register_unsafe}. - - It returns [true] if the request was cancelled (the callback will never be called), - or [false] if the request was already complete (the callback has already been called). *) +(** Waiters call {!await} in a loop as long as some condition is false. + Fibers that modify inputs to the condition must call [broadcast] soon + afterwards so that waiters can re-check the condition. + + Example: + + {[ + let x = ref 0 + let cond = Eio.Condition.create () + let mutex = Eio.Mutex.create () + + let set_x value = + Eio.Mutex.use_rw ~protect:false mutex (fun () -> x := value); + Eio.Condition.broadcast cond + + let await_x p = + Eio.Mutex.use_ro mutex (fun () -> + while not (p !x) do (* [x] cannot change, as mutex is locked. *) + Eio.Condition.await cond mutex (* Mutex is unlocked while suspended. *) + done + ) + ]} + + It is used like this: + + {[ + Fiber.both + (fun () -> + traceln "x = %d" !x; + await_x ((=) 42); + traceln "x = %d" !x + ) + (fun () -> + set_x 5; + Fiber.yield (); + set_x 7; + set_x 42; + ) + ]} +*) + +type t + +val create : unit -> t +(** [create ()] creates a new condition variable. *) + +val await : t -> Eio_mutex.t -> unit +(** [await t mutex] suspends the current fiber until it is notified by [t]. + + You should lock [mutex] before testing whether the condition is true, + and leave it locked while calling this function. + It will be unlocked while the fiber is waiting and locked again before + returning (it is also locked again if the wait is cancelled). *) + +val await_no_mutex : t -> unit +(** [await_no_mutex t] suspends the current fiber until it is notified by [t]. + + This is only safe to use in the case where [t] is only used within a single domain, + and the test for the condition was done without switching fibers. + i.e. you know the condition is still false, and no notification of a change can be sent + until [await_no_mutex] has finished suspending the fiber. *) + +val loop_no_mutex : t -> (unit -> 'a option) -> 'a +(** [loop_no_mutex t update] runs [update ()] until it returns [Some x], then returns [x]. + + If [update ()] returns [None] then it waits until {!broadcast} is called before retrying. + If {!broadcast} is called while [update] is running, [update] runs again immediately. + + For example, if [broadcast config_changed] is performed after some configuration file is changed, then + you can ensure [load_config] will always eventually have seen the latest configuration like this: + + {[ + Fiber.fork_daemon ~sw (fun () -> + loop_no_mutex config_changed (fun () -> load_config (); None) + ) + ]} + + Note that, since there is no lock, [load_config] may see a half-written update if the configuration + is changed again before it finishes reading it, + so it should just log the error and wait to be called again. *) + +val broadcast : t -> unit +(** [broadcast t] wakes up any waiting fibers (by appending them to the run-queue to resume later). + + If no fibers are waiting, nothing happens. *) + +(** {2 Low-level API} + + This is intended only for integrating Eio with other IO libraries. *) + +type request + +val register_immediate : t -> (unit -> unit) -> request +(** [register_immediate t fn] will call [fn ()] the next time {!broadcast} is called. + + [fn] runs immediately from the caller's context, which might not be an Eio thread, or may be a signal handler, etc. + Therefore, care is needed here. This is typically used to send a wake-up event to some non-Eio library. *) + +val cancel : request -> bool +(** [cancel request] tries to cancel a request created with {!register_unsafe}. + + It returns [true] if the request was cancelled (the callback will never be called), + or [false] if the request was already complete (the callback has already been called). *) diff --git a/lib_eio/core/broadcast.ml b/lib_eio/core/broadcast.ml index 82539e36e..2716b49a8 100644 --- a/lib_eio/core/broadcast.ml +++ b/lib_eio/core/broadcast.ml @@ -1,108 +1,108 @@ -(* See the Cells module for an overview of this system. - - Each new waiter atomically increments the "suspend" pointer and writes - a callback there. The waking fiber removes all the callbacks and calls them. - In this version, "resume" never gets ahead of "suspend" (broadcasting just - brings it up-to-date with the "suspend" pointer). - - When the resume fiber runs, some of the cells reserved for callbacks might - not yet have been filled. In this case, the resuming fiber just marks them - as needing to be resumed. When the suspending fiber continues, it will - notice this and continue immediately. *) - -module Cell = struct - (* For any given cell, there are two actors running in parallel: the - suspender and the resumer. - - The resumer only performs a single operation (resume). - - The consumer waits to be resumed and then, optionally, cancels. - - This means we only have three cases to think about: - - 1. Consumer adds request (Empty -> Request). - 1a. Provider fulfills it (Request -> Resumed). - 1b. Consumer cancels it (Request -> Cancelled). - 2. Provider gets to cell first (Empty -> Resumed). - When the consumer tries to wait, it resumes immediately. - - The Resumed state should never been seen. It exists only to allow the - request to be GC'd promptly. We could replace it with Empty, but having - separate states is clearer for debugging. *) - - type _ t = - | Request of (unit -> unit) - | Cancelled - | Resumed - | Empty - - let init = Empty - - let segment_order = 2 - - let dump f = function - | Request _ -> Fmt.string f "Request" - | Empty -> Fmt.string f "Empty" - | Resumed -> Fmt.string f "Resumed" - | Cancelled -> Fmt.string f "Cancelled" -end - -module Cells = Cells.Make(Cell) - -type cell = unit Cell.t -type t = unit Cells.t - -type request = unit Cells.segment * cell Atomic.t - -let rec resume cell = - match (Atomic.get cell : cell) with - | Request r as cur -> - (* The common case: we have a waiter for the value *) - if Atomic.compare_and_set cell cur Resumed then r (); - (* else it was cancelled at the same time; ignore *) - | Empty -> - (* The consumer has reserved this cell but not yet stored the request. - We place Resumed there and it will handle it soon. *) - if Atomic.compare_and_set cell Empty Resumed then - () (* The consumer will deal with it *) - else - resume cell (* The Request was added concurrently; use it *) - | Cancelled -> () - | Resumed -> - (* This state is unreachable because we (the provider) haven't set this yet *) - assert false - -let cancel (segment, cell) = - match (Atomic.get cell : cell) with - | Request _ as old -> - if Atomic.compare_and_set cell old Cancelled then ( - Cells.cancel_cell segment; - true - ) else false (* We got resumed first *) - | Resumed -> false (* We got resumed first *) - | Cancelled -> invalid_arg "Already cancelled!" - | Empty -> - (* To call [cancel] the user needs a [request] value, - which they only get once we've reached the [Request] state. - [Empty] is unreachable from [Request]. *) - assert false - -let suspend t k = - let (_, cell) as request = Cells.next_suspend t in - if Atomic.compare_and_set cell Empty (Request k) then Some request - else match Atomic.get cell with - | Resumed -> - (* Resumed before we could add the waiter *) - k (); - None - | Cancelled | Request _ | Empty -> - (* These are unreachable from the previously-observed non-Empty state - without us taking some action first *) - assert false - -let resume_all t = - Cells.resume_all t resume - -let create = Cells.make - -let dump f t = Cells.dump f t +(* See the Cells module for an overview of this system. + + Each new waiter atomically increments the "suspend" pointer and writes + a callback there. The waking fiber removes all the callbacks and calls them. + In this version, "resume" never gets ahead of "suspend" (broadcasting just + brings it up-to-date with the "suspend" pointer). + + When the resume fiber runs, some of the cells reserved for callbacks might + not yet have been filled. In this case, the resuming fiber just marks them + as needing to be resumed. When the suspending fiber continues, it will + notice this and continue immediately. *) + +module Cell = struct + (* For any given cell, there are two actors running in parallel: the + suspender and the resumer. + + The resumer only performs a single operation (resume). + + The consumer waits to be resumed and then, optionally, cancels. + + This means we only have three cases to think about: + + 1. Consumer adds request (Empty -> Request). + 1a. Provider fulfills it (Request -> Resumed). + 1b. Consumer cancels it (Request -> Cancelled). + 2. Provider gets to cell first (Empty -> Resumed). + When the consumer tries to wait, it resumes immediately. + + The Resumed state should never been seen. It exists only to allow the + request to be GC'd promptly. We could replace it with Empty, but having + separate states is clearer for debugging. *) + + type _ t = + | Request of (unit -> unit) + | Cancelled + | Resumed + | Empty + + let init = Empty + + let segment_order = 2 + + let dump f = function + | Request _ -> Fmt.string f "Request" + | Empty -> Fmt.string f "Empty" + | Resumed -> Fmt.string f "Resumed" + | Cancelled -> Fmt.string f "Cancelled" +end + +module Cells = Cells.Make(Cell) + +type cell = unit Cell.t +type t = unit Cells.t + +type request = unit Cells.segment * cell Atomic.t + +let rec resume cell = + match (Atomic.get cell : cell) with + | Request r as cur -> + (* The common case: we have a waiter for the value *) + if Atomic.compare_and_set cell cur Resumed then r (); + (* else it was cancelled at the same time; ignore *) + | Empty -> + (* The consumer has reserved this cell but not yet stored the request. + We place Resumed there and it will handle it soon. *) + if Atomic.compare_and_set cell Empty Resumed then + () (* The consumer will deal with it *) + else + resume cell (* The Request was added concurrently; use it *) + | Cancelled -> () + | Resumed -> + (* This state is unreachable because we (the provider) haven't set this yet *) + assert false + +let cancel (segment, cell) = + match (Atomic.get cell : cell) with + | Request _ as old -> + if Atomic.compare_and_set cell old Cancelled then ( + Cells.cancel_cell segment; + true + ) else false (* We got resumed first *) + | Resumed -> false (* We got resumed first *) + | Cancelled -> invalid_arg "Already cancelled!" + | Empty -> + (* To call [cancel] the user needs a [request] value, + which they only get once we've reached the [Request] state. + [Empty] is unreachable from [Request]. *) + assert false + +let suspend t k = + let (_, cell) as request = Cells.next_suspend t in + if Atomic.compare_and_set cell Empty (Request k) then Some request + else match Atomic.get cell with + | Resumed -> + (* Resumed before we could add the waiter *) + k (); + None + | Cancelled | Request _ | Empty -> + (* These are unreachable from the previously-observed non-Empty state + without us taking some action first *) + assert false + +let resume_all t = + Cells.resume_all t resume + +let create = Cells.make + +let dump f t = Cells.dump f t diff --git a/lib_eio/core/broadcast.mli b/lib_eio/core/broadcast.mli index 2602caf9a..9b134a7a3 100644 --- a/lib_eio/core/broadcast.mli +++ b/lib_eio/core/broadcast.mli @@ -1,37 +1,37 @@ -(** A lock-free queue of waiters that should all be resumed at once. - - This uses {!Cells} internally. *) - -type t - -type request -(** A handle to a pending request that can be used to cancel it. *) - -val create : unit -> t -(** [create ()] is a fresh broadcast queue. *) - -val suspend : t -> (unit -> unit) -> request option -(** [suspend t fn] arranges for [fn ()] to be called on {!resume_all}. - - [fn ()] may be called from the caller's context, or by [resume_all], - so it needs to be able to cope with running in any context where that - can run. For example, [fn] must be safe to call from a signal handler - if [resume_all] can be called from one. [fn] must not raise. - - The returned request can be used to cancel. It can be [None] in the - (unlikely) event that [t] got resumed before the function returned. *) - -val resume_all : t -> unit -(** [resume_all t] calls all non-cancelled callbacks attached to [t], - in the order in which they were suspended. - - This function is lock-free and can be used safely even from a signal handler or GC finalizer. *) - -val cancel : request -> bool -(** [cancel request] attempts to remove a pending request. - - It returns [true] if the request was cancelled, or [false] if it got - resumed before that could happen. *) - -val dump : Format.formatter -> t -> unit -(** Display the internal state of a queue, for debugging. *) +(** A lock-free queue of waiters that should all be resumed at once. + + This uses {!Cells} internally. *) + +type t + +type request +(** A handle to a pending request that can be used to cancel it. *) + +val create : unit -> t +(** [create ()] is a fresh broadcast queue. *) + +val suspend : t -> (unit -> unit) -> request option +(** [suspend t fn] arranges for [fn ()] to be called on {!resume_all}. + + [fn ()] may be called from the caller's context, or by [resume_all], + so it needs to be able to cope with running in any context where that + can run. For example, [fn] must be safe to call from a signal handler + if [resume_all] can be called from one. [fn] must not raise. + + The returned request can be used to cancel. It can be [None] in the + (unlikely) event that [t] got resumed before the function returned. *) + +val resume_all : t -> unit +(** [resume_all t] calls all non-cancelled callbacks attached to [t], + in the order in which they were suspended. + + This function is lock-free and can be used safely even from a signal handler or GC finalizer. *) + +val cancel : request -> bool +(** [cancel request] attempts to remove a pending request. + + It returns [true] if the request was cancelled, or [false] if it got + resumed before that could happen. *) + +val dump : Format.formatter -> t -> unit +(** Display the internal state of a queue, for debugging. *) diff --git a/lib_eio/core/cancel.ml b/lib_eio/core/cancel.ml index cb584d646..f43afc2dc 100644 --- a/lib_eio/core/cancel.ml +++ b/lib_eio/core/cancel.ml @@ -1,235 +1,235 @@ -exception Cancelled = Exn.Cancelled - -type state = - | On - | Cancelling of exn * Printexc.raw_backtrace - | Finished - -(* There is a tree of cancellation contexts for each domain. - A fiber is always in exactly one context, but can move to a new child and back (see [sub]). - While a fiber is performing a cancellable operation, it sets a cancel function. - When a context is cancelled, we call each fiber's cancellation function (first replacing it with [ignore]). - Cancelling always happens from the fiber's own domain. - An operation may either finish normally or be cancelled (not both). - If a function can succeed in a separate domain, - the user's cancel function is responsible for ensuring that this is done atomically. *) -type t = { - id : Trace.id; - mutable state : state; - children : t Lwt_dllist.t; - fibers : fiber_context Lwt_dllist.t; - protected : bool; - domain : Domain.id; (* Prevent access from other domains *) -} -and fiber_context = { - tid : Trace.id; - mutable cancel_context : t; - mutable cancel_node : fiber_context Lwt_dllist.node option; (* Our entry in [cancel_context.fibers] *) - mutable cancel_fn : exn -> unit; (* Encourage the current operation to finish *) - mutable vars : Hmap.t; -} - -type _ Effect.t += Get_context : fiber_context Effect.t - -let pp_state f t = - begin match t.state with - | On -> Fmt.string f "on" - | Cancelling (ex, _) -> Fmt.pf f "cancelling(%a)" Fmt.exn ex - | Finished -> Fmt.string f "finished" - end; - if t.protected then Fmt.pf f " (protected)" - -let pp_fiber f fiber = - Fmt.pf f "%d" (fiber.tid :> int) - -let pp_lwt_dlist ~sep pp f t = - let first = ref true in - t |> Lwt_dllist.iter_l (fun item -> - if !first then first := false - else sep f (); - pp f item; - ) - -let rec dump f t = - Fmt.pf f "@[%a [%a]%a@]" - pp_state t - (pp_lwt_dlist ~sep:(Fmt.any ",") pp_fiber) t.fibers - pp_children t.children -and pp_children f ts = - ts |> Lwt_dllist.iter_l (fun t -> - Fmt.cut f (); - dump f t - ) - -let is_on t = - match t.state with - | On -> true - | Cancelling _ | Finished -> false - -let check t = - match t.state with - | On -> () - | Cancelling (ex, _) -> raise (Cancelled ex) - | Finished -> invalid_arg "Cancellation context finished!" - -let get_error t = - match t.state with - | On -> None - | Cancelling (ex, _) -> Some (Cancelled ex) - | Finished -> Some (Invalid_argument "Cancellation context finished!") - -let is_finished t = - match t.state with - | Finished -> true - | On | Cancelling _ -> false - -let move_fiber_to t fiber = - let new_node = Lwt_dllist.add_r fiber t.fibers in (* Add to new context *) - fiber.cancel_context <- t; - Option.iter Lwt_dllist.remove fiber.cancel_node; (* Remove from old context *) - fiber.cancel_node <- Some new_node - -(* Note: the new value is not linked into the cancellation tree. *) -let create ~protected purpose = - let children = Lwt_dllist.create () in - let fibers = Lwt_dllist.create () in - let id = Trace.mint_id () in - Trace.create_cc id purpose; - { id; state = Finished; children; protected; fibers; domain = Domain.self () } - -(* Links [t] into the tree as a child of [parent] and returns a function to remove it again. *) -let activate t ~parent = - assert (t.state = Finished); - assert (parent.state <> Finished); - t.state <- On; - let node = Lwt_dllist.add_r t parent.children in - fun () -> - assert (parent.state <> Finished); - t.state <- Finished; - Lwt_dllist.remove node - -(* Runs [fn] with a fresh cancellation context. *) -let with_cc ~ctx:fiber ~parent ~protected purpose fn = - if not protected then check parent; - let t = create ~protected purpose in - let deactivate = activate t ~parent in - move_fiber_to t fiber; - let cleanup () = move_fiber_to parent fiber; deactivate () in - match fn t with - | x -> cleanup (); Trace.exit_cc (); x - | exception ex -> cleanup (); Trace.exit_cc (); raise ex - -let protect fn = - let ctx = Effect.perform Get_context in - with_cc ~ctx ~parent:ctx.cancel_context ~protected:true Protect @@ fun _ -> - (* Note: there is no need to check the new context after [fn] returns; - the goal of cancellation is only to finish the thread promptly, not to report the error. - We also do not check the parent context, to make sure the caller has a chance to handle the result. *) - fn () - -(* Mark the cancellation tree rooted at [t] as Cancelling (stopping at protected sub-contexts), - and return a list of all fibers in the newly-cancelling contexts. Since modifying the cancellation - tree can only be done from our domain, this is effectively an atomic operation. Once it returns, - new (non-protected) fibers cannot be added to any of the cancelling contexts. *) -let rec cancel_internal t ex acc_fibers = - match t.state with - | Finished -> invalid_arg "Cancellation context finished!" - | Cancelling _ -> acc_fibers - | On -> - let bt = Printexc.get_raw_backtrace () in - t.state <- Cancelling (ex, bt); - Trace.error t.id ex; - let acc_fibers = Lwt_dllist.fold_r List.cons t.fibers acc_fibers in - Lwt_dllist.fold_r (cancel_child ex) t.children acc_fibers -and cancel_child ex t acc = - if t.protected then acc - else cancel_internal t ex acc - -let check_our_domain t = - if Domain.self () <> t.domain then invalid_arg "Cancellation context accessed from wrong domain!" - -let cancel t ex = - check_our_domain t; - let fibers = cancel_internal t ex [] in - let cex = Cancelled ex in - let rec aux = function - | [] -> [] - | x :: xs -> - let fn = x.cancel_fn in - x.cancel_fn <- ignore; - match fn cex with - | () -> aux xs - | exception ex2 -> - let bt = Printexc.get_raw_backtrace () in - (ex2, bt) :: aux xs - in - if fibers <> [] then ( - match aux fibers with - | [] -> () - | ex :: exs -> - let ex, bt = List.fold_left Exn.combine ex exs in - Printexc.raise_with_backtrace ex bt - ) - -let sub_checked ?name purpose fn = - let ctx = Effect.perform Get_context in - let parent = ctx.cancel_context in - with_cc ~ctx ~parent ~protected:false purpose @@ fun t -> - Option.iter (Trace.name t.id) name; - fn t - -let sub fn = - sub_checked Sub fn - -(* Like [sub], but it's OK if the new context is cancelled. - (instead, return the parent context on exit so the caller can check that) *) -let sub_unchecked purpose fn = - let ctx = Effect.perform Get_context in - let parent = ctx.cancel_context in - with_cc ~ctx ~parent ~protected:false purpose @@ fun t -> - fn t; - parent - -module Fiber_context = struct - type t = fiber_context - - let tid t = t.tid - let cancellation_context t = t.cancel_context - - let get_error t = get_error t.cancel_context - - let set_cancel_fn t fn = - t.cancel_fn <- fn - - let clear_cancel_fn t = - t.cancel_fn <- ignore - - let make ~cc ~vars = - let tid = Trace.mint_id () in - Trace.create_fiber tid ~cc:cc.id; - let t = { tid; cancel_context = cc; cancel_node = None; cancel_fn = ignore; vars } in - t.cancel_node <- Some (Lwt_dllist.add_r t cc.fibers); - t - - let make_root () = - let cc = create ~protected:false Root in - cc.state <- On; - make ~cc ~vars:Hmap.empty - - let destroy t = - Trace.exit_fiber t.tid; - Option.iter Lwt_dllist.remove t.cancel_node - - let vars t = t.vars - - let get_vars () = - vars (Effect.perform Get_context) - - let with_vars t vars fn = - let old_vars = t.vars in - t.vars <- vars; - let cleanup () = t.vars <- old_vars in - match fn () with - | x -> cleanup (); x - | exception ex -> cleanup (); raise ex -end +exception Cancelled = Exn.Cancelled + +type state = + | On + | Cancelling of exn * Printexc.raw_backtrace + | Finished + +(* There is a tree of cancellation contexts for each domain. + A fiber is always in exactly one context, but can move to a new child and back (see [sub]). + While a fiber is performing a cancellable operation, it sets a cancel function. + When a context is cancelled, we call each fiber's cancellation function (first replacing it with [ignore]). + Cancelling always happens from the fiber's own domain. + An operation may either finish normally or be cancelled (not both). + If a function can succeed in a separate domain, + the user's cancel function is responsible for ensuring that this is done atomically. *) +type t = { + id : Trace.id; + mutable state : state; + children : t Lwt_dllist.t; + fibers : fiber_context Lwt_dllist.t; + protected : bool; + domain : Domain.id; (* Prevent access from other domains *) +} +and fiber_context = { + tid : Trace.id; + mutable cancel_context : t; + mutable cancel_node : fiber_context Lwt_dllist.node option; (* Our entry in [cancel_context.fibers] *) + mutable cancel_fn : exn -> unit; (* Encourage the current operation to finish *) + mutable vars : Hmap.t; +} + +type _ Effect.t += Get_context : fiber_context Effect.t + +let pp_state f t = + begin match t.state with + | On -> Fmt.string f "on" + | Cancelling (ex, _) -> Fmt.pf f "cancelling(%a)" Fmt.exn ex + | Finished -> Fmt.string f "finished" + end; + if t.protected then Fmt.pf f " (protected)" + +let pp_fiber f fiber = + Fmt.pf f "%d" (fiber.tid :> int) + +let pp_lwt_dlist ~sep pp f t = + let first = ref true in + t |> Lwt_dllist.iter_l (fun item -> + if !first then first := false + else sep f (); + pp f item; + ) + +let rec dump f t = + Fmt.pf f "@[%a [%a]%a@]" + pp_state t + (pp_lwt_dlist ~sep:(Fmt.any ",") pp_fiber) t.fibers + pp_children t.children +and pp_children f ts = + ts |> Lwt_dllist.iter_l (fun t -> + Fmt.cut f (); + dump f t + ) + +let is_on t = + match t.state with + | On -> true + | Cancelling _ | Finished -> false + +let check t = + match t.state with + | On -> () + | Cancelling (ex, _) -> raise (Cancelled ex) + | Finished -> invalid_arg "Cancellation context finished!" + +let get_error t = + match t.state with + | On -> None + | Cancelling (ex, _) -> Some (Cancelled ex) + | Finished -> Some (Invalid_argument "Cancellation context finished!") + +let is_finished t = + match t.state with + | Finished -> true + | On | Cancelling _ -> false + +let move_fiber_to t fiber = + let new_node = Lwt_dllist.add_r fiber t.fibers in (* Add to new context *) + fiber.cancel_context <- t; + Option.iter Lwt_dllist.remove fiber.cancel_node; (* Remove from old context *) + fiber.cancel_node <- Some new_node + +(* Note: the new value is not linked into the cancellation tree. *) +let create ~protected purpose = + let children = Lwt_dllist.create () in + let fibers = Lwt_dllist.create () in + let id = Trace.mint_id () in + Trace.create_cc id purpose; + { id; state = Finished; children; protected; fibers; domain = Domain.self () } + +(* Links [t] into the tree as a child of [parent] and returns a function to remove it again. *) +let activate t ~parent = + assert (t.state = Finished); + assert (parent.state <> Finished); + t.state <- On; + let node = Lwt_dllist.add_r t parent.children in + fun () -> + assert (parent.state <> Finished); + t.state <- Finished; + Lwt_dllist.remove node + +(* Runs [fn] with a fresh cancellation context. *) +let with_cc ~ctx:fiber ~parent ~protected purpose fn = + if not protected then check parent; + let t = create ~protected purpose in + let deactivate = activate t ~parent in + move_fiber_to t fiber; + let cleanup () = move_fiber_to parent fiber; deactivate () in + match fn t with + | x -> cleanup (); Trace.exit_cc (); x + | exception ex -> cleanup (); Trace.exit_cc (); raise ex + +let protect fn = + let ctx = Effect.perform Get_context in + with_cc ~ctx ~parent:ctx.cancel_context ~protected:true Protect @@ fun _ -> + (* Note: there is no need to check the new context after [fn] returns; + the goal of cancellation is only to finish the thread promptly, not to report the error. + We also do not check the parent context, to make sure the caller has a chance to handle the result. *) + fn () + +(* Mark the cancellation tree rooted at [t] as Cancelling (stopping at protected sub-contexts), + and return a list of all fibers in the newly-cancelling contexts. Since modifying the cancellation + tree can only be done from our domain, this is effectively an atomic operation. Once it returns, + new (non-protected) fibers cannot be added to any of the cancelling contexts. *) +let rec cancel_internal t ex acc_fibers = + match t.state with + | Finished -> invalid_arg "Cancellation context finished!" + | Cancelling _ -> acc_fibers + | On -> + let bt = Printexc.get_raw_backtrace () in + t.state <- Cancelling (ex, bt); + Trace.error t.id ex; + let acc_fibers = Lwt_dllist.fold_r List.cons t.fibers acc_fibers in + Lwt_dllist.fold_r (cancel_child ex) t.children acc_fibers +and cancel_child ex t acc = + if t.protected then acc + else cancel_internal t ex acc + +let check_our_domain t = + if Domain.self () <> t.domain then invalid_arg "Cancellation context accessed from wrong domain!" + +let cancel t ex = + check_our_domain t; + let fibers = cancel_internal t ex [] in + let cex = Cancelled ex in + let rec aux = function + | [] -> [] + | x :: xs -> + let fn = x.cancel_fn in + x.cancel_fn <- ignore; + match fn cex with + | () -> aux xs + | exception ex2 -> + let bt = Printexc.get_raw_backtrace () in + (ex2, bt) :: aux xs + in + if fibers <> [] then ( + match aux fibers with + | [] -> () + | ex :: exs -> + let ex, bt = List.fold_left Exn.combine ex exs in + Printexc.raise_with_backtrace ex bt + ) + +let sub_checked ?name purpose fn = + let ctx = Effect.perform Get_context in + let parent = ctx.cancel_context in + with_cc ~ctx ~parent ~protected:false purpose @@ fun t -> + Option.iter (Trace.name t.id) name; + fn t + +let sub fn = + sub_checked Sub fn + +(* Like [sub], but it's OK if the new context is cancelled. + (instead, return the parent context on exit so the caller can check that) *) +let sub_unchecked purpose fn = + let ctx = Effect.perform Get_context in + let parent = ctx.cancel_context in + with_cc ~ctx ~parent ~protected:false purpose @@ fun t -> + fn t; + parent + +module Fiber_context = struct + type t = fiber_context + + let tid t = t.tid + let cancellation_context t = t.cancel_context + + let get_error t = get_error t.cancel_context + + let set_cancel_fn t fn = + t.cancel_fn <- fn + + let clear_cancel_fn t = + t.cancel_fn <- ignore + + let make ~cc ~vars = + let tid = Trace.mint_id () in + Trace.create_fiber tid ~cc:cc.id; + let t = { tid; cancel_context = cc; cancel_node = None; cancel_fn = ignore; vars } in + t.cancel_node <- Some (Lwt_dllist.add_r t cc.fibers); + t + + let make_root () = + let cc = create ~protected:false Root in + cc.state <- On; + make ~cc ~vars:Hmap.empty + + let destroy t = + Trace.exit_fiber t.tid; + Option.iter Lwt_dllist.remove t.cancel_node + + let vars t = t.vars + + let get_vars () = + vars (Effect.perform Get_context) + + let with_vars t vars fn = + let old_vars = t.vars in + t.vars <- vars; + let cleanup () = t.vars <- old_vars in + match fn () with + | x -> cleanup (); x + | exception ex -> cleanup (); raise ex +end diff --git a/lib_eio/core/cells.ml b/lib_eio/core/cells.ml index 32f9fdb87..c043ead56 100644 --- a/lib_eio/core/cells.ml +++ b/lib_eio/core/cells.ml @@ -1,483 +1,483 @@ -module type CELL = sig - type 'a t - val init : 'a t - val segment_order : int - val dump : _ t Fmt.t -end - -(* To avoid worrying about wrapping on 32-bit platforms, - we use 63-bit integers for indexes in all cases. - On 64-bit platforms, this is just [int]. *) -module Int63 = struct - include Optint.Int63 - - (* Fallback for 32-bit platforms. *) - let rec fetch_and_add_fallback t delta = - let old = Atomic.get t in - if Atomic.compare_and_set t old (add old (of_int delta)) then old - else fetch_and_add_fallback t delta - - let fetch_and_add : t Atomic.t -> int -> t = - match is_immediate with - | True -> Atomic.fetch_and_add - | False -> fetch_and_add_fallback -end - -module Make(Cell : CELL) = struct - let cells_per_segment = 1 lsl Cell.segment_order - let segment_mask = cells_per_segment - 1 - - (* An index identifies a cell. It is a pair of the segment ID and the offset - within the segment, packed into a single integer so we can increment it - atomically. *) - module Index : sig - type t - type segment_id = Int63.t - - val of_segment : segment_id -> t - (* [of_segment x] is the index of the first cell in segment [x]. *) - - val segment : t -> segment_id - val offset : t -> int - - val zero : t - val succ : t -> t - val pred : t -> t - - val next : t Atomic.t -> t - - (* val pp : t Fmt.t *) - end = struct - type t = Int63.t - type segment_id = Int63.t - - let segment t = Int63.shift_right_logical t Cell.segment_order - let of_segment id = Int63.shift_left id Cell.segment_order - - let offset t = Int63.to_int t land segment_mask - - let zero = Int63.zero - let succ = Int63.succ - let pred = Int63.pred - - let next t_atomic = - Int63.fetch_and_add t_atomic (+1) - - (* let pp f t = Fmt.pf f "%d:%d" (segment t) (offset t) *) - end - - (* A pair with counts for the number of cancelled cells in a segment and the - number of pointers to it, packed as an integer so it can be adjusted atomically. *) - module Count : sig - type t - - val create : pointers:int -> t - (* [create ~pointers] is a new counter for a segment. - Initially there are no cancelled cells. *) - - val removed : t -> bool - (* [removed t] is true if a segment with this count should be removed - (i.e. all cells are cancelled and it has no pointers). - Once this returns [true], it will always return [true] in future. *) - - val incr_cancelled : t -> bool - (* Increment the count of cancelled cells, then return [removed t] for the new state. *) - - val try_inc_pointers : t -> bool - (* Atomically increment the pointers count, unless [removed t]. - Returns [true] on success. *) - - val dec_pointers : t -> bool - (* Decrement the pointers count, then return [removed t] for the new state. *) - - val validate : expected_pointers:int -> t -> unit - (* [validate ~expected_pointers t] check that [t] is a valid count for a non-removed segment. *) - - val dump : t Fmt.t - end = struct - type t = int Atomic.t - - (* We use 16 bits for the cancelled count, which should be plenty. - The remaining bits (at least 15) are used for the pointer count, - which normally doesn't go above 2 (except temporarily, and limited - by the number of domains). *) - let () = assert (cells_per_segment < 0x10000) - - let v ~pointers ~cancelled = (pointers lsl 16) lor cancelled - let v_removed = v ~pointers:0 ~cancelled:cells_per_segment - let pointers v = v lsr 16 - let cancelled v = v land 0xffff - - let create ~pointers = Atomic.make (v ~pointers ~cancelled:0) - - let dump f t = - let v = Atomic.get t in - Fmt.pf f "pointers=%d, cancelled=%d" (pointers v) (cancelled v) - - let incr_cancelled t = - Atomic.fetch_and_add t 1 = v_removed - 1 - - let rec try_inc_pointers t = - let v = Atomic.get t in - if v = v_removed then false - else ( - if Atomic.compare_and_set t v (v + (1 lsl 16)) then true - else try_inc_pointers t - ) - - let dec_pointers t = - Atomic.fetch_and_add t (-1 lsl 16) = v_removed + (1 lsl 16) - - let removed t = - Atomic.get t = v_removed - - let validate ~expected_pointers t = - let v = Atomic.get t in - assert (cancelled v >= 0 && cancelled v <= cells_per_segment); - if cancelled v = cells_per_segment then assert (pointers v > 0); - if pointers v <> expected_pointers then - Fmt.failwith "Bad pointer count!" - end - - (* A segment is a node in a linked list containing an array of [cells_per_segment] cells. *) - module Segment : sig - type 'a t - - val make_init : unit -> 'a t - (* [make_init ()] is a new initial segment. *) - - val id : _ t -> Index.segment_id - - val get : 'a t -> int -> 'a Cell.t Atomic.t - (* [get t offset] is the cell at [offset] within [t]. *) - - val try_inc_pointers : _ t -> bool - (* Atomically increment the pointers count if the segment isn't removed. - Returns [true] on success, or [false] if the segment was removed first. *) - - val dec_pointers : _ t -> unit - (* Decrement the pointers count, removing the segment if it is no longer - needed. *) - - val find : 'a t -> Index.segment_id -> 'a t - (* [find t id] finds the segment [id] searching forwards from [t]. - - If the target segment has not yet been created, this creates it (atomically). - If the target segment has been removed, this returns the next non-removed segment. *) - - val clear_prev : _ t -> unit - (* Called when the resumer has reached this segment, - so it will never need to skip over any previous segments. - Therefore, the previous pointer is no longer required and - previous segments can be GC'd. *) - - val cancel_cell : _ t -> unit - (* Increment the cancelled-cells counter, and remove the segment if it is no longer useful. *) - - val validate : 'a t -> suspend:'a t -> resume:'a t -> unit - (* [validate t ~suspend ~resume] checks that [t] is in a valid state, - assuming there are no operations currently in progress. - [suspend] and [resume] are the segments of the suspend and resume pointers. - It checks that both are reachable from [t]. *) - - val dump_list : label:Index.t Fmt.t -> 'a t Fmt.t - (* [dump_list] formats this segment and all following ones for debugging. - @param label Used to annotate indexes. *) - end = struct - type 'a t = { - id : Index.segment_id; - count : Count.t; - cells : 'a Cell.t Atomic.t array; - prev : 'a t option Atomic.t; (* None if first, or [prev] is no longer needed *) - next : 'a t option Atomic.t; (* None if not yet created *) - } - - let id t = t.id - - let get t i = Array.get t.cells i - - let pp_id f t = Int63.pp f t.id - - let dump_cells ~label f t = - let idx = ref (Index.of_segment t.id) in - for i = 0 to Array.length t.cells - 1 do - Fmt.pf f "@,%a" Cell.dump (Atomic.get t.cells.(i)); - label f !idx; - idx := Index.succ !idx - done - - let rec dump_list ~label f t = - Fmt.pf f "@[Segment %a (prev=%a, %a):%a@]" - pp_id t - (Fmt.Dump.option pp_id) (Atomic.get t.prev) - Count.dump t.count - (dump_cells ~label) t; - let next = Atomic.get t.next in - begin match next with - | Some next when next.id = Int63.succ t.id -> - () (* We'll show the labels at the start of the next segment *) - | _ -> - Fmt.pf f "@,End%a" - label (Index.of_segment (Int63.succ t.id)) - end; - Option.iter (fun next -> Fmt.cut f (); dump_list ~label f next) next - - let next t = - match Atomic.get t.next with - | Some s -> s - | None -> - let next = { - id = Int63.succ t.id; - count = Count.create ~pointers:0; - cells = Array.init cells_per_segment (fun (_ : int) -> Atomic.make Cell.init); - next = Atomic.make None; - prev = Atomic.make (Some t); - } in - if Atomic.compare_and_set t.next None (Some next) then next - else Atomic.get t.next |> Option.get - - let removed t = - Count.removed t.count - - (* Get the previous non-removed segment, if any. *) - let rec alive_prev t = - match Atomic.get t.prev with - | Some prev when removed prev -> alive_prev prev - | x -> x - - (* Get the next non-removed segment. *) - let alive_next t = - let next = Atomic.get t.next |> Option.get in - let rec live x = - if removed x then ( - match Atomic.get x.next with - | Some next -> live next - | None -> x (* The paper says to return "tail if all are removed", but can that ever happen? *) - ) else x - in - live next - - (* Remove [t] from the linked-list by splicing together - the previous live segment before us to the next live one afterwards. - The tricky case is when two adjacent segments get removed at the same time. - If that happens, the next and prev lists will still always be valid - (i.e. will include all live segments, in the correct order), but may not be optimal. - However, we will detect that case when it happens and fix it up immediately. *) - let rec remove t = - if Atomic.get t.next = None then () (* Can't remove tail. This shouldn't happen anyway. *) - else ( - let prev = alive_prev t - and next = alive_next t in - (* [prev] might have been removed by the time we do this, but it doesn't matter, - we're still only skipping removed segments (just not as many as desired). - We'll fix it up afterwards in that case. *) - Atomic.set next.prev prev; - (* Likewise [next] might have been removed too by now, but we'll correct later. *) - Option.iter (fun prev -> Atomic.set prev.next (Some next)) prev; - (* If either got removed by now, start again. *) - if removed next && Atomic.get next.next <> None then remove t - else match prev with - | Some prev when removed prev -> remove t - | _ -> () - ) - - let try_inc_pointers t = - Count.try_inc_pointers t.count - - let dec_pointers t = - if Count.dec_pointers t.count then remove t - - let cancel_cell t = - if Count.incr_cancelled t.count then remove t - - let rec find start id = - if start.id >= id && not (removed start) then start - else find (next start) id - - let make_init () = - { - id = Int63.zero; - count = Count.create ~pointers:2; - cells = Array.init cells_per_segment (fun (_ : int) -> Atomic.make Cell.init); - next = Atomic.make None; - prev = Atomic.make None; - } - - (* Note: this assumes the system is at rest (no operations in progress). *) - let rec validate t ~suspend ~resume ~seen_pointers = - let expected_pointers = - (if t == suspend then 1 else 0) + - (if t == resume then 1 else 0) - in - Count.validate ~expected_pointers t.count; - let seen_pointers = seen_pointers + expected_pointers in - match Atomic.get t.next with - | None -> assert (seen_pointers = 2) - | Some next -> - begin match Atomic.get next.prev with - | None -> assert (resume.id >= next.id) - | Some t2 -> assert (resume.id < next.id && t == t2) - end; - validate next ~suspend ~resume ~seen_pointers - - let validate = validate ~seen_pointers:0 - - let clear_prev t = - Atomic.set t.prev None - end - - (* A mutable pointer into the list of cells. *) - module Position : sig - type 'a t - - val of_segment : 'a Segment.t -> 'a t - (* [of_segment x] is a pointer to the first cell in [x]. *) - - val next : clear_prev:bool -> 'a t -> 'a Segment.t * 'a Cell.t Atomic.t - (* [next t ~clear_prev] returns the segment and cell of [t], and atomically increments it. - If [t]'s segment is all cancelled and no longer exists it will skip it and retry. - If [clear_prev] then the previous pointer is no longer required. *) - - val resume_all : 'a t -> stop:Index.t -> ('a Cell.t Atomic.t -> unit) -> unit - (* [resume_all t ~stop f] advances [t] to [stop], then calls [f cell] on each cell advanced over. *) - - val index : _ t -> Index.t - (* [index t] is the index of the cell currently pointed-to by [t]. *) - - val segment : 'a t -> 'a Segment.t - (* For debugging only. The segment containing the previously-returned cell (or the initial segment), - when the system is at rest. *) - end = struct - type 'a t = { - segment : 'a Segment.t Atomic.t; (* Note: can lag [idx] *) - idx : Index.t Atomic.t; - } - - let segment t = Atomic.get t.segment - let index t = Atomic.get t.idx - - let of_segment segment = - { - segment = Atomic.make segment; - idx = Atomic.make Index.zero; - } - - (* Set [t.segment] to [target] if [target] is ahead of us. - Returns [false] if [target] gets removed first. *) - let rec move_forward t (target : _ Segment.t) = - let cur = Atomic.get t.segment in - if Segment.id cur >= Segment.id target then true - else ( - if not (Segment.try_inc_pointers target) then false (* target already removed *) - else ( - if Atomic.compare_and_set t.segment cur target then ( - Segment.dec_pointers cur; - true - ) else ( - (* Concurrent update of [t]. Undo ref-count changes and retry. *) - Segment.dec_pointers target; - move_forward t target - ) - ) - ) - - (* Update [t] to the segment [id] (or the next non-removed segment after it). *) - let rec find_and_move_forward t start id = - let target = Segment.find start id in - if move_forward t target then target - else find_and_move_forward t start id (* Removed before we could increase the ref-count; rety *) - - let rec next ~clear_prev t = - (* Get the segment first before the index. Even if [idx] moves forwards after this, - we'll still be able to reach it from [r]. *) - let r = Atomic.get t.segment in - let i = Index.next t.idx in - let id = Index.segment i in - let s = find_and_move_forward t r id in - if clear_prev then Segment.clear_prev s; - if Segment.id s = id then ( - (s, Segment.get s (Index.offset i)) - ) else ( - (* The segment we wanted contains only cancelled cells. - Try to update the index to jump over those cells, then retry. *) - let s_index = Index.of_segment (Segment.id s) in - ignore (Atomic.compare_and_set t.idx (Index.succ i) s_index : bool); - next ~clear_prev t - ) - - let rec resume_all t ~stop f = - (* Get the segment first before the index. Even if [idx] moves forwards after this, - we'll still be able to reach it from [start_seg]. *) - let start_seg = Atomic.get t.segment in - let start = Atomic.get t.idx in - if start >= stop then () - else if not (Atomic.compare_and_set t.idx start stop) then ( - resume_all t ~stop f - ) else ( - (* We are now responsible for resuming all cells from [start] to [stop]. *) - (* Move [t.segment] forward so we can free older segments now. *) - ignore (find_and_move_forward t start_seg (Index.segment (Index.pred stop)) : _ Segment.t); - (* Resume all cells from [i] to [stop] (reachable via [seg]): *) - let rec aux seg i = - if i < stop then ( - let seg = Segment.find seg (Index.segment i) in - Segment.clear_prev seg; - let seg_start = Index.of_segment (Segment.id seg) in - if seg_start < stop then ( - let i = max i seg_start in - f (Segment.get seg (Index.offset i)); - aux seg (Index.succ i) - ) - ) - in - aux start_seg start - ) - end - - type 'a t = { - resume : 'a Position.t; - suspend : 'a Position.t; - } - - type 'a segment = 'a Segment.t - - let next_suspend t = - Position.next t.suspend ~clear_prev:false - - let next_resume t = - snd @@ Position.next t.resume ~clear_prev:true - - let resume_all t f = - Position.resume_all t.resume ~stop:(Position.index t.suspend) f - - let cancel_cell = Segment.cancel_cell - - let make () = - let init = Segment.make_init () in - { - resume = Position.of_segment init; - suspend = Position.of_segment init; - } - - let validate t = - let suspend = Position.segment t.suspend in - let resume = Position.segment t.resume in - let start = - if Segment.id suspend < Segment.id resume then suspend - else resume - in - Segment.validate start ~suspend ~resume - - let dump f t = - let suspend = Position.index t.suspend in - let resume = Position.index t.resume in - let start = - if suspend < resume then t.suspend - else t.resume - in - let label f i = - if i = suspend then Format.pp_print_string f " (suspend)"; - if i = resume then Format.pp_print_string f " (resume)"; - in - Format.fprintf f "@[%a@]" (Segment.dump_list ~label) (Position.segment start) -end +module type CELL = sig + type 'a t + val init : 'a t + val segment_order : int + val dump : _ t Fmt.t +end + +(* To avoid worrying about wrapping on 32-bit platforms, + we use 63-bit integers for indexes in all cases. + On 64-bit platforms, this is just [int]. *) +module Int63 = struct + include Optint.Int63 + + (* Fallback for 32-bit platforms. *) + let rec fetch_and_add_fallback t delta = + let old = Atomic.get t in + if Atomic.compare_and_set t old (add old (of_int delta)) then old + else fetch_and_add_fallback t delta + + let fetch_and_add : t Atomic.t -> int -> t = + match is_immediate with + | True -> Atomic.fetch_and_add + | False -> fetch_and_add_fallback +end + +module Make(Cell : CELL) = struct + let cells_per_segment = 1 lsl Cell.segment_order + let segment_mask = cells_per_segment - 1 + + (* An index identifies a cell. It is a pair of the segment ID and the offset + within the segment, packed into a single integer so we can increment it + atomically. *) + module Index : sig + type t + type segment_id = Int63.t + + val of_segment : segment_id -> t + (* [of_segment x] is the index of the first cell in segment [x]. *) + + val segment : t -> segment_id + val offset : t -> int + + val zero : t + val succ : t -> t + val pred : t -> t + + val next : t Atomic.t -> t + + (* val pp : t Fmt.t *) + end = struct + type t = Int63.t + type segment_id = Int63.t + + let segment t = Int63.shift_right_logical t Cell.segment_order + let of_segment id = Int63.shift_left id Cell.segment_order + + let offset t = Int63.to_int t land segment_mask + + let zero = Int63.zero + let succ = Int63.succ + let pred = Int63.pred + + let next t_atomic = + Int63.fetch_and_add t_atomic (+1) + + (* let pp f t = Fmt.pf f "%d:%d" (segment t) (offset t) *) + end + + (* A pair with counts for the number of cancelled cells in a segment and the + number of pointers to it, packed as an integer so it can be adjusted atomically. *) + module Count : sig + type t + + val create : pointers:int -> t + (* [create ~pointers] is a new counter for a segment. + Initially there are no cancelled cells. *) + + val removed : t -> bool + (* [removed t] is true if a segment with this count should be removed + (i.e. all cells are cancelled and it has no pointers). + Once this returns [true], it will always return [true] in future. *) + + val incr_cancelled : t -> bool + (* Increment the count of cancelled cells, then return [removed t] for the new state. *) + + val try_inc_pointers : t -> bool + (* Atomically increment the pointers count, unless [removed t]. + Returns [true] on success. *) + + val dec_pointers : t -> bool + (* Decrement the pointers count, then return [removed t] for the new state. *) + + val validate : expected_pointers:int -> t -> unit + (* [validate ~expected_pointers t] check that [t] is a valid count for a non-removed segment. *) + + val dump : t Fmt.t + end = struct + type t = int Atomic.t + + (* We use 16 bits for the cancelled count, which should be plenty. + The remaining bits (at least 15) are used for the pointer count, + which normally doesn't go above 2 (except temporarily, and limited + by the number of domains). *) + let () = assert (cells_per_segment < 0x10000) + + let v ~pointers ~cancelled = (pointers lsl 16) lor cancelled + let v_removed = v ~pointers:0 ~cancelled:cells_per_segment + let pointers v = v lsr 16 + let cancelled v = v land 0xffff + + let create ~pointers = Atomic.make (v ~pointers ~cancelled:0) + + let dump f t = + let v = Atomic.get t in + Fmt.pf f "pointers=%d, cancelled=%d" (pointers v) (cancelled v) + + let incr_cancelled t = + Atomic.fetch_and_add t 1 = v_removed - 1 + + let rec try_inc_pointers t = + let v = Atomic.get t in + if v = v_removed then false + else ( + if Atomic.compare_and_set t v (v + (1 lsl 16)) then true + else try_inc_pointers t + ) + + let dec_pointers t = + Atomic.fetch_and_add t (-1 lsl 16) = v_removed + (1 lsl 16) + + let removed t = + Atomic.get t = v_removed + + let validate ~expected_pointers t = + let v = Atomic.get t in + assert (cancelled v >= 0 && cancelled v <= cells_per_segment); + if cancelled v = cells_per_segment then assert (pointers v > 0); + if pointers v <> expected_pointers then + Fmt.failwith "Bad pointer count!" + end + + (* A segment is a node in a linked list containing an array of [cells_per_segment] cells. *) + module Segment : sig + type 'a t + + val make_init : unit -> 'a t + (* [make_init ()] is a new initial segment. *) + + val id : _ t -> Index.segment_id + + val get : 'a t -> int -> 'a Cell.t Atomic.t + (* [get t offset] is the cell at [offset] within [t]. *) + + val try_inc_pointers : _ t -> bool + (* Atomically increment the pointers count if the segment isn't removed. + Returns [true] on success, or [false] if the segment was removed first. *) + + val dec_pointers : _ t -> unit + (* Decrement the pointers count, removing the segment if it is no longer + needed. *) + + val find : 'a t -> Index.segment_id -> 'a t + (* [find t id] finds the segment [id] searching forwards from [t]. + + If the target segment has not yet been created, this creates it (atomically). + If the target segment has been removed, this returns the next non-removed segment. *) + + val clear_prev : _ t -> unit + (* Called when the resumer has reached this segment, + so it will never need to skip over any previous segments. + Therefore, the previous pointer is no longer required and + previous segments can be GC'd. *) + + val cancel_cell : _ t -> unit + (* Increment the cancelled-cells counter, and remove the segment if it is no longer useful. *) + + val validate : 'a t -> suspend:'a t -> resume:'a t -> unit + (* [validate t ~suspend ~resume] checks that [t] is in a valid state, + assuming there are no operations currently in progress. + [suspend] and [resume] are the segments of the suspend and resume pointers. + It checks that both are reachable from [t]. *) + + val dump_list : label:Index.t Fmt.t -> 'a t Fmt.t + (* [dump_list] formats this segment and all following ones for debugging. + @param label Used to annotate indexes. *) + end = struct + type 'a t = { + id : Index.segment_id; + count : Count.t; + cells : 'a Cell.t Atomic.t array; + prev : 'a t option Atomic.t; (* None if first, or [prev] is no longer needed *) + next : 'a t option Atomic.t; (* None if not yet created *) + } + + let id t = t.id + + let get t i = Array.get t.cells i + + let pp_id f t = Int63.pp f t.id + + let dump_cells ~label f t = + let idx = ref (Index.of_segment t.id) in + for i = 0 to Array.length t.cells - 1 do + Fmt.pf f "@,%a" Cell.dump (Atomic.get t.cells.(i)); + label f !idx; + idx := Index.succ !idx + done + + let rec dump_list ~label f t = + Fmt.pf f "@[Segment %a (prev=%a, %a):%a@]" + pp_id t + (Fmt.Dump.option pp_id) (Atomic.get t.prev) + Count.dump t.count + (dump_cells ~label) t; + let next = Atomic.get t.next in + begin match next with + | Some next when next.id = Int63.succ t.id -> + () (* We'll show the labels at the start of the next segment *) + | _ -> + Fmt.pf f "@,End%a" + label (Index.of_segment (Int63.succ t.id)) + end; + Option.iter (fun next -> Fmt.cut f (); dump_list ~label f next) next + + let next t = + match Atomic.get t.next with + | Some s -> s + | None -> + let next = { + id = Int63.succ t.id; + count = Count.create ~pointers:0; + cells = Array.init cells_per_segment (fun (_ : int) -> Atomic.make Cell.init); + next = Atomic.make None; + prev = Atomic.make (Some t); + } in + if Atomic.compare_and_set t.next None (Some next) then next + else Atomic.get t.next |> Option.get + + let removed t = + Count.removed t.count + + (* Get the previous non-removed segment, if any. *) + let rec alive_prev t = + match Atomic.get t.prev with + | Some prev when removed prev -> alive_prev prev + | x -> x + + (* Get the next non-removed segment. *) + let alive_next t = + let next = Atomic.get t.next |> Option.get in + let rec live x = + if removed x then ( + match Atomic.get x.next with + | Some next -> live next + | None -> x (* The paper says to return "tail if all are removed", but can that ever happen? *) + ) else x + in + live next + + (* Remove [t] from the linked-list by splicing together + the previous live segment before us to the next live one afterwards. + The tricky case is when two adjacent segments get removed at the same time. + If that happens, the next and prev lists will still always be valid + (i.e. will include all live segments, in the correct order), but may not be optimal. + However, we will detect that case when it happens and fix it up immediately. *) + let rec remove t = + if Atomic.get t.next = None then () (* Can't remove tail. This shouldn't happen anyway. *) + else ( + let prev = alive_prev t + and next = alive_next t in + (* [prev] might have been removed by the time we do this, but it doesn't matter, + we're still only skipping removed segments (just not as many as desired). + We'll fix it up afterwards in that case. *) + Atomic.set next.prev prev; + (* Likewise [next] might have been removed too by now, but we'll correct later. *) + Option.iter (fun prev -> Atomic.set prev.next (Some next)) prev; + (* If either got removed by now, start again. *) + if removed next && Atomic.get next.next <> None then remove t + else match prev with + | Some prev when removed prev -> remove t + | _ -> () + ) + + let try_inc_pointers t = + Count.try_inc_pointers t.count + + let dec_pointers t = + if Count.dec_pointers t.count then remove t + + let cancel_cell t = + if Count.incr_cancelled t.count then remove t + + let rec find start id = + if start.id >= id && not (removed start) then start + else find (next start) id + + let make_init () = + { + id = Int63.zero; + count = Count.create ~pointers:2; + cells = Array.init cells_per_segment (fun (_ : int) -> Atomic.make Cell.init); + next = Atomic.make None; + prev = Atomic.make None; + } + + (* Note: this assumes the system is at rest (no operations in progress). *) + let rec validate t ~suspend ~resume ~seen_pointers = + let expected_pointers = + (if t == suspend then 1 else 0) + + (if t == resume then 1 else 0) + in + Count.validate ~expected_pointers t.count; + let seen_pointers = seen_pointers + expected_pointers in + match Atomic.get t.next with + | None -> assert (seen_pointers = 2) + | Some next -> + begin match Atomic.get next.prev with + | None -> assert (resume.id >= next.id) + | Some t2 -> assert (resume.id < next.id && t == t2) + end; + validate next ~suspend ~resume ~seen_pointers + + let validate = validate ~seen_pointers:0 + + let clear_prev t = + Atomic.set t.prev None + end + + (* A mutable pointer into the list of cells. *) + module Position : sig + type 'a t + + val of_segment : 'a Segment.t -> 'a t + (* [of_segment x] is a pointer to the first cell in [x]. *) + + val next : clear_prev:bool -> 'a t -> 'a Segment.t * 'a Cell.t Atomic.t + (* [next t ~clear_prev] returns the segment and cell of [t], and atomically increments it. + If [t]'s segment is all cancelled and no longer exists it will skip it and retry. + If [clear_prev] then the previous pointer is no longer required. *) + + val resume_all : 'a t -> stop:Index.t -> ('a Cell.t Atomic.t -> unit) -> unit + (* [resume_all t ~stop f] advances [t] to [stop], then calls [f cell] on each cell advanced over. *) + + val index : _ t -> Index.t + (* [index t] is the index of the cell currently pointed-to by [t]. *) + + val segment : 'a t -> 'a Segment.t + (* For debugging only. The segment containing the previously-returned cell (or the initial segment), + when the system is at rest. *) + end = struct + type 'a t = { + segment : 'a Segment.t Atomic.t; (* Note: can lag [idx] *) + idx : Index.t Atomic.t; + } + + let segment t = Atomic.get t.segment + let index t = Atomic.get t.idx + + let of_segment segment = + { + segment = Atomic.make segment; + idx = Atomic.make Index.zero; + } + + (* Set [t.segment] to [target] if [target] is ahead of us. + Returns [false] if [target] gets removed first. *) + let rec move_forward t (target : _ Segment.t) = + let cur = Atomic.get t.segment in + if Segment.id cur >= Segment.id target then true + else ( + if not (Segment.try_inc_pointers target) then false (* target already removed *) + else ( + if Atomic.compare_and_set t.segment cur target then ( + Segment.dec_pointers cur; + true + ) else ( + (* Concurrent update of [t]. Undo ref-count changes and retry. *) + Segment.dec_pointers target; + move_forward t target + ) + ) + ) + + (* Update [t] to the segment [id] (or the next non-removed segment after it). *) + let rec find_and_move_forward t start id = + let target = Segment.find start id in + if move_forward t target then target + else find_and_move_forward t start id (* Removed before we could increase the ref-count; rety *) + + let rec next ~clear_prev t = + (* Get the segment first before the index. Even if [idx] moves forwards after this, + we'll still be able to reach it from [r]. *) + let r = Atomic.get t.segment in + let i = Index.next t.idx in + let id = Index.segment i in + let s = find_and_move_forward t r id in + if clear_prev then Segment.clear_prev s; + if Segment.id s = id then ( + (s, Segment.get s (Index.offset i)) + ) else ( + (* The segment we wanted contains only cancelled cells. + Try to update the index to jump over those cells, then retry. *) + let s_index = Index.of_segment (Segment.id s) in + ignore (Atomic.compare_and_set t.idx (Index.succ i) s_index : bool); + next ~clear_prev t + ) + + let rec resume_all t ~stop f = + (* Get the segment first before the index. Even if [idx] moves forwards after this, + we'll still be able to reach it from [start_seg]. *) + let start_seg = Atomic.get t.segment in + let start = Atomic.get t.idx in + if start >= stop then () + else if not (Atomic.compare_and_set t.idx start stop) then ( + resume_all t ~stop f + ) else ( + (* We are now responsible for resuming all cells from [start] to [stop]. *) + (* Move [t.segment] forward so we can free older segments now. *) + ignore (find_and_move_forward t start_seg (Index.segment (Index.pred stop)) : _ Segment.t); + (* Resume all cells from [i] to [stop] (reachable via [seg]): *) + let rec aux seg i = + if i < stop then ( + let seg = Segment.find seg (Index.segment i) in + Segment.clear_prev seg; + let seg_start = Index.of_segment (Segment.id seg) in + if seg_start < stop then ( + let i = max i seg_start in + f (Segment.get seg (Index.offset i)); + aux seg (Index.succ i) + ) + ) + in + aux start_seg start + ) + end + + type 'a t = { + resume : 'a Position.t; + suspend : 'a Position.t; + } + + type 'a segment = 'a Segment.t + + let next_suspend t = + Position.next t.suspend ~clear_prev:false + + let next_resume t = + snd @@ Position.next t.resume ~clear_prev:true + + let resume_all t f = + Position.resume_all t.resume ~stop:(Position.index t.suspend) f + + let cancel_cell = Segment.cancel_cell + + let make () = + let init = Segment.make_init () in + { + resume = Position.of_segment init; + suspend = Position.of_segment init; + } + + let validate t = + let suspend = Position.segment t.suspend in + let resume = Position.segment t.resume in + let start = + if Segment.id suspend < Segment.id resume then suspend + else resume + in + Segment.validate start ~suspend ~resume + + let dump f t = + let suspend = Position.index t.suspend in + let resume = Position.index t.resume in + let start = + if suspend < resume then t.suspend + else t.resume + in + let label f i = + if i = suspend then Format.pp_print_string f " (suspend)"; + if i = resume then Format.pp_print_string f " (resume)"; + in + Format.fprintf f "@[%a@]" (Segment.dump_list ~label) (Position.segment start) +end diff --git a/lib_eio/core/cells.mli b/lib_eio/core/cells.mli index 89aa630b1..b1d47030a 100644 --- a/lib_eio/core/cells.mli +++ b/lib_eio/core/cells.mli @@ -1,111 +1,111 @@ -(** A lock-free queue-like structure with suspension and cancellation. - - This module provides an infinite sequence of atomic cells, which can be used for whatever you like. - There are two pointers into this sequence: a suspend (consumer) pointer and a resume (producer) pointer. - These are similar to the head and tail pointers in a traditional queue, - except that the consumer is also permitted to get ahead of the producer. - - To use this as a plain queue, each producer calls {!Make.next_resume} to get the - cell at the resume (tail) pointer (and advance it atomically), then stores - its value in the cell. Each consumer calls {!Make.next_suspend} to get the next - cell at the head of the queue (and advance the suspend pointer). - - The consumer/suspender is permitted to get ahead of the producer. In this - case, the consumer will CAS the cell from its initial state to a Request - state containing a callback to receive the value when it arrives. When a - producer later tries to CAS the cell from the initial state to holding a - value, it will fail and find the Request with the callback function - instead. It can then provide the value directly to the callback. - - A suspender can be cancelled by CASing the Request to a Cancelled state. - It should also call {!Make.cancel_cell} (if the CAS succeeds), to allow the cell to be freed. - If a resumer's CAS fails because the cell is cancelled, it can retry with a fresh cell. - - For efficiency, cells are grouped into segments, which are stored in a linked list. - Once all the cells in a segment are cancelled, the whole segment may be freed. - - This is based on {{:https://arxiv.org/pdf/2111.12682.pdf}A formally-verified - framework for fair synchronization in kotlin coroutines, Appendix C}, - which contains more details and examples of use. - - This module also adds the {!Make.resume_all} function, which is useful for broadcasting. -*) - -(** The signature for user-defined cell contents. *) -module type CELL = sig - type 'a t - - val init : 'a t - (** The value to give newly-allocated cells. *) - - val segment_order : int - (** The number of bits to use for the offset into the segment. - - The number of cells per segment is [2 ** segment_order]. *) - - val dump : _ t Fmt.t - (** Display the cell state for debugging. *) -end - -module Make(Cell : CELL) : sig - type 'a t - - type 'a segment - - val make : unit -> 'a t - (** [make ()] is a fresh sequence of cells. *) - - val next_suspend : 'a t -> 'a segment * 'a Cell.t Atomic.t - (** [next_suspend t] atomically returns the next suspend cell and its segment. - - If multiple domains call this at the same time, they will each get a different location. - - The cell might or might not have already been filled in by a resumer. - You need to handle both cases (typically by using {!Atomic.compare_and_set}). - - The segment can be used with {!cancel_cell}. - - This function is lock-free and is safe to call even from a signal handler or GC finalizer. *) - - val next_resume : 'a t -> 'a Cell.t Atomic.t - (** [next_resume t] atomically returns the next resume cell. - - If multiple domains call this at the same time, they will each get a different cell. - - The cell might or might not contain a request from a suspender that got there first. - You need to handle both cases (typically by using {!Atomic.compare_and_set}). - - Note: cancelled cells may or may not be skipped (you need to handle the case of the - cell you get being cancelled before you can write to it, but you also - can't rely on seeing every cancelled cell, as cancelled segments may be deleted). - - This function is lock-free and is safe to call even from a signal handler or GC finalizer. *) - - val resume_all : 'a t -> ('a Cell.t Atomic.t -> unit) -> unit - (** [resume_all t f] advances the resume position to the current suspend position, - then calls [f cell] on each cell advanced over. - - Note: as with {!next_resume}, [f] may be called for some cancelled cells but not others. - - [f] must not raise an exception (if it does, it will not be called on the remaining cells). - - If the resume position is ahead of the suspend position, then calling this function does nothing. - - This function is lock-free and is safe to call even from a signal handler or GC finalizer. *) - - val cancel_cell : 'a segment -> unit - (** [cancel_cell segment] increments the segment's count of the number of cancelled cells. - - Once all cells are cancelled it may be possible to discard the whole segment. - This avoids leaking memory if a user keeps suspending and then cancelling. - - You must not call this more than once per cell. - - This function is lock-free and is safe to call even from a signal handler or GC finalizer. *) - - val validate : _ t -> unit - (** [validate t] checks that [t] is in a valid state, assuming there are no operations currently in progress. *) - - val dump : _ t Fmt.t - (** [dump] outputs the internal state of a [_ t], for debugging. *) -end +(** A lock-free queue-like structure with suspension and cancellation. + + This module provides an infinite sequence of atomic cells, which can be used for whatever you like. + There are two pointers into this sequence: a suspend (consumer) pointer and a resume (producer) pointer. + These are similar to the head and tail pointers in a traditional queue, + except that the consumer is also permitted to get ahead of the producer. + + To use this as a plain queue, each producer calls {!Make.next_resume} to get the + cell at the resume (tail) pointer (and advance it atomically), then stores + its value in the cell. Each consumer calls {!Make.next_suspend} to get the next + cell at the head of the queue (and advance the suspend pointer). + + The consumer/suspender is permitted to get ahead of the producer. In this + case, the consumer will CAS the cell from its initial state to a Request + state containing a callback to receive the value when it arrives. When a + producer later tries to CAS the cell from the initial state to holding a + value, it will fail and find the Request with the callback function + instead. It can then provide the value directly to the callback. + + A suspender can be cancelled by CASing the Request to a Cancelled state. + It should also call {!Make.cancel_cell} (if the CAS succeeds), to allow the cell to be freed. + If a resumer's CAS fails because the cell is cancelled, it can retry with a fresh cell. + + For efficiency, cells are grouped into segments, which are stored in a linked list. + Once all the cells in a segment are cancelled, the whole segment may be freed. + + This is based on {{:https://arxiv.org/pdf/2111.12682.pdf}A formally-verified + framework for fair synchronization in kotlin coroutines, Appendix C}, + which contains more details and examples of use. + + This module also adds the {!Make.resume_all} function, which is useful for broadcasting. +*) + +(** The signature for user-defined cell contents. *) +module type CELL = sig + type 'a t + + val init : 'a t + (** The value to give newly-allocated cells. *) + + val segment_order : int + (** The number of bits to use for the offset into the segment. + + The number of cells per segment is [2 ** segment_order]. *) + + val dump : _ t Fmt.t + (** Display the cell state for debugging. *) +end + +module Make(Cell : CELL) : sig + type 'a t + + type 'a segment + + val make : unit -> 'a t + (** [make ()] is a fresh sequence of cells. *) + + val next_suspend : 'a t -> 'a segment * 'a Cell.t Atomic.t + (** [next_suspend t] atomically returns the next suspend cell and its segment. + + If multiple domains call this at the same time, they will each get a different location. + + The cell might or might not have already been filled in by a resumer. + You need to handle both cases (typically by using {!Atomic.compare_and_set}). + + The segment can be used with {!cancel_cell}. + + This function is lock-free and is safe to call even from a signal handler or GC finalizer. *) + + val next_resume : 'a t -> 'a Cell.t Atomic.t + (** [next_resume t] atomically returns the next resume cell. + + If multiple domains call this at the same time, they will each get a different cell. + + The cell might or might not contain a request from a suspender that got there first. + You need to handle both cases (typically by using {!Atomic.compare_and_set}). + + Note: cancelled cells may or may not be skipped (you need to handle the case of the + cell you get being cancelled before you can write to it, but you also + can't rely on seeing every cancelled cell, as cancelled segments may be deleted). + + This function is lock-free and is safe to call even from a signal handler or GC finalizer. *) + + val resume_all : 'a t -> ('a Cell.t Atomic.t -> unit) -> unit + (** [resume_all t f] advances the resume position to the current suspend position, + then calls [f cell] on each cell advanced over. + + Note: as with {!next_resume}, [f] may be called for some cancelled cells but not others. + + [f] must not raise an exception (if it does, it will not be called on the remaining cells). + + If the resume position is ahead of the suspend position, then calling this function does nothing. + + This function is lock-free and is safe to call even from a signal handler or GC finalizer. *) + + val cancel_cell : 'a segment -> unit + (** [cancel_cell segment] increments the segment's count of the number of cancelled cells. + + Once all cells are cancelled it may be possible to discard the whole segment. + This avoids leaking memory if a user keeps suspending and then cancelling. + + You must not call this more than once per cell. + + This function is lock-free and is safe to call even from a signal handler or GC finalizer. *) + + val validate : _ t -> unit + (** [validate t] checks that [t] is in a valid state, assuming there are no operations currently in progress. *) + + val dump : _ t Fmt.t + (** [dump] outputs the internal state of a [_ t], for debugging. *) +end diff --git a/lib_eio/core/debug.ml b/lib_eio/core/debug.ml index b4f132ca0..1f32f32ac 100644 --- a/lib_eio/core/debug.ml +++ b/lib_eio/core/debug.ml @@ -1,51 +1,51 @@ -type traceln = { - traceln : 'a. ?__POS__:string * int * int * int -> ('a, Format.formatter, unit, unit) format4 -> 'a; -} [@@unboxed] - -let traceln_key : traceln Fiber.key = Fiber.create_key () - -let traceln_mutex = Mutex.create () - -let default_traceln ?__POS__:pos fmt = - let k go = - Trace.with_span "traceln" @@ fun () -> - let b = Buffer.create 512 in - let f = Format.formatter_of_buffer b in - go f; - Option.iter (fun (file, lnum, _, _) -> Format.fprintf f " [%s:%d]" file lnum) pos; - Format.pp_close_box f (); - Format.pp_print_flush f (); - let msg = Buffer.contents b in - Trace.log msg; - let lines = String.split_on_char '\n' msg in - Mutex.lock traceln_mutex; - Fun.protect ~finally:(fun () -> Mutex.unlock traceln_mutex) @@ fun () -> - List.iter (Printf.eprintf "+%s\n") lines; - flush stderr - in - Format.kdprintf k ("@[" ^^ fmt) - -let get () = - match Fiber.get traceln_key with - | Some traceln -> traceln - | None - | exception (Effect.Unhandled _) -> { traceln = default_traceln } - -let with_trace_prefix prefix fn = - let { traceln } = get () in - let traceln ?__POS__ fmt = - traceln ?__POS__ ("%t" ^^ fmt) prefix - in - Fiber.with_binding traceln_key { traceln } fn - -let traceln ?__POS__ fmt = - let { traceln } = get () in - traceln ?__POS__ fmt - -type t = < - traceln : traceln Fiber.key; -> - -let v = object - method traceln = traceln_key -end +type traceln = { + traceln : 'a. ?__POS__:string * int * int * int -> ('a, Format.formatter, unit, unit) format4 -> 'a; +} [@@unboxed] + +let traceln_key : traceln Fiber.key = Fiber.create_key () + +let traceln_mutex = Mutex.create () + +let default_traceln ?__POS__:pos fmt = + let k go = + Trace.with_span "traceln" @@ fun () -> + let b = Buffer.create 512 in + let f = Format.formatter_of_buffer b in + go f; + Option.iter (fun (file, lnum, _, _) -> Format.fprintf f " [%s:%d]" file lnum) pos; + Format.pp_close_box f (); + Format.pp_print_flush f (); + let msg = Buffer.contents b in + Trace.log msg; + let lines = String.split_on_char '\n' msg in + Mutex.lock traceln_mutex; + Fun.protect ~finally:(fun () -> Mutex.unlock traceln_mutex) @@ fun () -> + List.iter (Printf.eprintf "+%s\n") lines; + flush stderr + in + Format.kdprintf k ("@[" ^^ fmt) + +let get () = + match Fiber.get traceln_key with + | Some traceln -> traceln + | None + | exception (Effect.Unhandled _) -> { traceln = default_traceln } + +let with_trace_prefix prefix fn = + let { traceln } = get () in + let traceln ?__POS__ fmt = + traceln ?__POS__ ("%t" ^^ fmt) prefix + in + Fiber.with_binding traceln_key { traceln } fn + +let traceln ?__POS__ fmt = + let { traceln } = get () in + traceln ?__POS__ fmt + +type t = < + traceln : traceln Fiber.key; +> + +let v = object + method traceln = traceln_key +end diff --git a/lib_eio/core/dune b/lib_eio/core/dune index 4bda7916d..50a793351 100644 --- a/lib_eio/core/dune +++ b/lib_eio/core/dune @@ -1,4 +1,4 @@ -(library - (name eio__core) - (public_name eio.core) - (libraries hmap lwt-dllist fmt optint eio.runtime_events)) +(library + (name eio__core) + (public_name eio.core) + (libraries hmap lwt-dllist fmt optint eio.runtime_events)) diff --git a/lib_eio/core/eio__core.ml b/lib_eio/core/eio__core.ml index 54795859c..52ffa6b3d 100644 --- a/lib_eio/core/eio__core.ml +++ b/lib_eio/core/eio__core.ml @@ -1,22 +1,22 @@ -module Promise = Promise -module Fiber = Fiber -module Switch = Switch -module Cancel = Cancel -module Exn = Exn -module Private = struct - module Suspend = Suspend - module Cells = Cells - module Broadcast = Broadcast - module Single_waiter = Single_waiter - module Trace = Trace - module Fiber_context = Cancel.Fiber_context - module Debug = Debug - - module Effects = struct - type 'a enqueue = 'a Suspend.enqueue - type _ Effect.t += - | Suspend = Suspend.Suspend - | Fork = Fiber.Fork - | Get_context = Cancel.Get_context - end -end +module Promise = Promise +module Fiber = Fiber +module Switch = Switch +module Cancel = Cancel +module Exn = Exn +module Private = struct + module Suspend = Suspend + module Cells = Cells + module Broadcast = Broadcast + module Single_waiter = Single_waiter + module Trace = Trace + module Fiber_context = Cancel.Fiber_context + module Debug = Debug + + module Effects = struct + type 'a enqueue = 'a Suspend.enqueue + type _ Effect.t += + | Suspend = Suspend.Suspend + | Fork = Fiber.Fork + | Get_context = Cancel.Get_context + end +end diff --git a/lib_eio/core/eio__core.mli b/lib_eio/core/eio__core.mli index d51cafe43..6f8d11777 100644 --- a/lib_eio/core/eio__core.mli +++ b/lib_eio/core/eio__core.mli @@ -1,785 +1,785 @@ -(** Private internal module. Use {!Eio} instead. *) - -(** @canonical Eio.Switch *) -module Switch : sig - (** Many resources in Eio (such as fibers and file handles) require a switch to - be provided when they are created. The resource cannot outlive its switch. - - If a function wants to create such resources, and was not passed a switch - as an argument, it will need to create a switch using {!run}. - This doesn't return until all resources attached to it have been freed, - preventing the function from leaking resources. - - Any function creating resources that outlive it needs to be given a - switch by its caller. - - Each switch includes its own {!Cancel.t} context. - Calling {!fail} cancels all fibers attached to the switch and, once they - have exited, reports the error. - - Note: this concept is known as a "nursery" or "bundle" in some other systems. - - Example: - {[ - Switch.run (fun sw -> - let flow = Dir.open_in ~sw dir "myfile.txt" in - ... - ); - (* [flow] will have been closed by this point *) - ]} - *) - - type t - (** A switch contains a group of fibers and other resources (such as open file handles). *) - - (** {2 Switch creation} *) - - val run : ?name:string -> (t -> 'a) -> 'a - (** [run fn] runs [fn] with a fresh switch (initially on). - - When [fn] finishes, [run] waits for all fibers registered with the switch to finish, - and then releases all attached resources. - - If {!fail} is called, [run] will re-raise the exception (after everything is cleaned up). - If [fn] raises an exception, it is passed to {!fail}. - - @param name Used to name the switch when tracing. *) - - val run_protected : ?name:string -> (t -> 'a) -> 'a - (** [run_protected fn] is like [run] but ignores cancellation requests from the parent context. *) - - (** {2 Cancellation and failure} *) - - val check : t -> unit - (** [check t] checks that [t] is still on. - @raise Cancel.Cancelled If the switch has been cancelled. *) - - val get_error : t -> exn option - (** [get_error t] is like [check t] except that it returns the exception instead of raising it. - If [t] is finished, this returns (rather than raising) the [Invalid_argument] exception too. *) - - val fail : ?bt:Printexc.raw_backtrace -> t -> exn -> unit - (** [fail t ex] adds [ex] to [t]'s set of failures and - ensures that the switch's cancellation context is cancelled, - to encourage all fibers to exit as soon as possible. - - [fail] returns immediately, without waiting for the shutdown actions to complete. - The exception will be raised later by {!run}, and [run]'s caller is responsible for handling it. - {!Exn.combine} is used to avoid duplicate or unnecessary exceptions. - @param bt A backtrace to attach to [ex] *) - - (** {2 Cleaning up resources} - - It is possible to attach clean-up hooks to a switch. - Once all fibers within the switch have finished, these hooks are called. - For example, when a file is opened it will register a release hook to close it. - - Functions that create such resources will take a switch argument - and call these functions for you. - You usually don't need to call these directly. *) - - val on_release : t -> (unit -> unit) -> unit - (** [on_release t fn] registers [fn] to be called once [t]'s main function has returned - and all fibers have finished. - - If [fn] raises an exception, it is passed to {!fail}. - - Release handlers are run in LIFO order, in series. - - Note that [fn] is called within a {!Cancel.protect}, since aborting clean-up actions is usually a bad idea - and the switch may have been cancelled by the time it runs. - You cannot attach new resources to a switch once the cancel hooks start to run. - - This function is thread-safe (but not signal-safe). - If the switch finishes before [fn] can be registered, - it raises [Invalid_argument] and runs [fn] immediately instead. *) - - type hook - (** A handle for removing a clean-up callback. *) - - val null_hook : hook - (** A dummy hook. [try_remove_hook null_hook = false]. *) - - val on_release_cancellable : t -> (unit -> unit) -> hook - (** Like [on_release], but the handler can be removed later. - - For example, opening a file will call [on_release_cancellable] to ensure the file is closed later. - However, if the file is manually closed before that, it will use {!remove_hook} to remove the hook, - which is no longer needed. - - This function is thread-safe (but not signal-safe). *) - - val try_remove_hook : hook -> bool - (** [try_remove_hook h] removes a previously-added hook. - Returns [true] if the hook was successfully removed, or [false] if another - domain ran it or removed it first. - - This function is thread-safe (but not signal-safe). *) - - val remove_hook : hook -> unit - (** [remove_hook h] is [ignore (try_remove_hook h)]. - - For multi-domain code, consider using {!try_remove_hook} instead - so that you can handle the case of trying to close a resource - just as another domain is closing it or finishing the switch. *) - - (** {2 Debugging} *) - - val dump : t Fmt.t - (** Dump out details of the switch's state for debugging. *) -end - -(** @canonical Eio.Promise *) -module Promise : sig - (** Unlike lazy values, you cannot "force" promises; - a promise is resolved when the maker of the promise is ready. - - Promises are thread-safe and so can be shared between domains and used - to communicate between them. - - Example: - {[ - let promise, resolver = Promise.create () in - Fiber.both - (fun () -> traceln "Got %d" (Promise.await promise)) - (fun () -> Promise.resolve resolver 42) - ]} *) - - type +!'a t - (** An ['a t] is a promise for a value of type ['a]. *) - - type -!'a u - (** An ['a u] is a resolver for a promise of type ['a]. *) - - val create : ?label:string -> unit -> 'a t * 'a u - (** [create ()] is a fresh promise/resolver pair. - The promise is initially unresolved. *) - - val create_resolved : 'a -> 'a t - (** [create_resolved x] is a promise that is already resolved with result [x]. *) - - val await : 'a t -> 'a - (** [await t] blocks until [t] is resolved. - If [t] is already resolved then this returns immediately. *) - - val resolve : 'a u -> 'a -> unit - (** [resolve u v] resolves [u]'s promise with the value [v]. - Any threads waiting for the result will be added to the run queue. - @raise Invalid_argument if [u] is already resolved. *) - - val try_resolve : 'a u -> 'a -> bool - (** [try_resolve] is like {!resolve} but returns [false] instead of raising [Invalid_argument]. - - Returns [true] on success. *) - - val peek : 'a t -> 'a option - (** [peek t] is [Some v] if the promise has been resolved to [v], or [None] otherwise. - If the result is [None] then it may change in future, otherwise it won't. - If another domain has access to the resolver then the state may have already - changed by the time this call returns. *) - - val is_resolved : 'a t -> bool - (** [is_resolved t] is [Option.is_some (peek t)]. *) - - (** {1 Result promises} *) - - type 'a or_exn = ('a, exn) result t - - val resolve_ok : ('a, 'b) result u -> 'a -> unit - (** [resolve_ok u x] is [resolve u (Ok x)]. *) - - val resolve_error : ('a, 'b) result u -> 'b -> unit - (** [resolve_error u x] is [resolve u (Error x)]. *) - - val await_exn : 'a or_exn -> 'a - (** [await_exn t] is like [await t], but if the result is [Error ex] then it raises [ex]. *) -end - -(** @canonical Eio.Fiber *) -module Fiber : sig - (** Within a domain, only one fiber can be running at a time. - A fiber runs until it performs an IO operation (directly or indirectly). - At that point, it may be suspended and the next fiber on the run queue runs. *) - - val both : (unit -> unit) -> (unit -> unit) -> unit - (** [both f g] runs [f ()] and [g ()] concurrently. - - They run in a new cancellation sub-context, and - if either raises an exception, the other is cancelled. - [both] waits for both functions to finish even if one raises - (it will then re-raise the original exception). - - [f] runs immediately, without switching to any other thread. - [g] is inserted at the head of the run-queue, so it runs next even if other threads are already enqueued. - You can get other scheduling orders by adding calls to {!yield} in various places. - e.g. to append both fibers to the end of the run-queue, yield immediately before calling [both]. - - If both fibers fail, {!Exn.combine} is used to combine the exceptions. *) - - val pair : (unit -> 'a) -> (unit -> 'b) -> 'a * 'b - (** [pair f g] is like [both], but returns the two results. *) - - val all : (unit -> unit) list -> unit - (** [all fs] is like [both], but for any number of fibers. - [all []] returns immediately. *) - - val first : ?combine:('a -> 'a -> 'a) -> (unit -> 'a) -> (unit -> 'a) -> 'a - (** [first f g] runs [f ()] and [g ()] concurrently. - - They run in a new cancellation sub-context, and when one finishes the other is cancelled. - If one raises, the other is cancelled and the exception is reported. - - As with [both], [f] runs immediately and [g] is scheduled next, ahead of any other queued work. - - If both fibers fail, {!Exn.combine} is used to combine the exceptions. - - Warning: it is always possible that {i both} operations will succeed. - This is because there is a period of time after the first operation succeeds - when it is waiting in the run-queue to resume - during which the other operation may also succeed. - - If both fibers succeed, [combine a b] is used to combine the results - (where [a] is the result of the first fiber to return and [b] is the second result). - The default is [fun a _ -> a], which discards the later result. *) - - val any : ?combine:('a -> 'a -> 'a) -> (unit -> 'a) list -> 'a - (** [any fs] is like [first], but for any number of fibers. - - [any []] just waits forever (or until cancelled). *) - - val n_any : (unit -> 'a) list -> 'a list - (** [n_any fs] is like [any], expect that if multiple fibers return values - then they are all returned, in the order in which the fibers finished. *) - - val await_cancel : unit -> 'a - (** [await_cancel ()] waits until cancelled. - @raise Cancel.Cancelled *) - - val fork : sw:Switch.t -> (unit -> unit) -> unit - (** [fork ~sw fn] runs [fn ()] in a new fiber, but does not wait for it to complete. - - The new fiber is attached to [sw] (which can't finish until the fiber ends). - - The new fiber inherits [sw]'s cancellation context. - If the fiber raises an exception, [Switch.fail sw] is called. - If [sw] is already off then [fn] fails immediately, but the calling thread continues. - - [fn] runs immediately, without switching to any other fiber first. - The calling fiber is placed at the head of the run queue, ahead of any previous items. *) - - val fork_promise : sw:Switch.t -> (unit -> 'a) -> 'a Promise.or_exn - (** [fork_promise ~sw fn] schedules [fn ()] to run in a new fiber and returns a promise for its result. - - This is just a convenience wrapper around {!fork}. - If [fn] raises an exception then the promise is resolved to the error, but [sw] is not failed. *) - - val fork_seq : sw:Switch.t -> (('a -> unit) -> unit) -> 'a Seq.t - (** [fork_seq ~sw fn] creates (but does not start) a new fiber to run [fn yield]. - - Requesting the next item from the returned sequence resumes the fiber until it - calls [yield x], using [x] value as the next item in the sequence. If [fn] - returns without producing a value then the result is {!Seq.Nil} (end-of-sequence). - - The returned sequence can be consumed safely from another domain. - [fn] itself always runs in the domain that called [fork_seq]. - - Example: - {[ - Switch.run @@ fun sw -> - let seq = Fiber.fork_seq ~sw (fun yield -> - for i = 1 to 3 do - traceln "Yielding %d" i; - yield i - done - ) in - Seq.iter (traceln "Got: %d") seq - ]} - - If [fn] raises an exception then the consumer receives it. - If the consumer cancels while awaiting a value, the producer is cancelled when - it next calls [yield]. - It is an error to request two items at once, or to request items out of sequence. - - @param sw When the switch finishes, the fiber is cancelled (if still running). - Attempting to read from the sequence after this raises an exception. *) - - val fork_daemon : sw:Switch.t -> (unit -> [`Stop_daemon]) -> unit - (** [fork_daemon] is like {!fork} except that instead of waiting for the fiber to finish, - the switch will cancel it once all non-daemon fibers are done. - - The switch will still wait for the daemon fiber to finish cancelling. - - The return type of [[`Stop_daemon]] instead of [unit] is just to catch mistakes, - as daemons normally aren't expected to return. *) - - val check : unit -> unit - (** [check ()] checks that the fiber's context hasn't been cancelled. - Many operations automatically check this before starting. - @raise Cancel.Cancelled if the fiber's context has been cancelled. *) - - val is_cancelled : unit -> bool - (** [is_cancelled ()] is [true] iff {!check} would raise an exception. *) - - val yield : unit -> unit - (** [yield ()] asks the scheduler to switch to the next runnable task. - The current task remains runnable, but goes to the back of the queue. - Automatically calls {!check} just before resuming. *) - - (** Concurrent list operations. *) - module List : sig - (** These functions behave like the ones in the standard library's [List] - module, except that multiple items can be processed concurrently. - - They correspond to Lwt's [Lwt_list.*_p] operations. e.g. - [Lwt_list.iter_p] becomes [Fiber.List.iter]. - For the [Lwt_list.*_s] operations, just use the standard library function. - e.g. [Lwt_list.iter_s] can be replaced by a plain [List.iter]. *) - - val filter : ?max_fibers:int -> ('a -> bool) -> 'a list -> 'a list - (** [filter f x] is like [List.filter f x] except that the invocations of [f] are - run concurrently in separate fibers. - @param max_fibers Maximum number of fibers to run concurrently *) - - val map : ?max_fibers:int -> ('a -> 'b) -> 'a list -> 'b list - (** [map f x] is like [List.map f x] except that the invocations of [f] are - run concurrently in separate fibers. - @param max_fibers Maximum number of fibers to run concurrently *) - - val filter_map : ?max_fibers:int -> ('a -> 'b option) -> 'a list -> 'b list - (** [filter_map f x] is like [List.filter_map f x] except that the - invocations of [f] are run concurrently in separate fibers. - @param max_fibers Maximum number of fibers to run concurrently *) - - val iter : ?max_fibers:int -> ('a -> unit) -> 'a list -> unit - (** [iter f x] is like [List.iter f x] except that the invocations of [f] are - run concurrently in separate fibers. - @param max_fibers Maximum number of fibers to run concurrently *) - end - - (** {2 Fiber-local variables} - - Each fiber maintains a map of additional variables associated with it, - which can be used to store fiber-related state or context. This map is - propagated to any forked fibers. - - While fiber-local variables can be useful, they can also make code much - harder to reason about, as they effectively act as another form of global - state. When possible, prefer passing arguments around explicitly. - - Fiber-local variables are particularly useful for attaching extra - information for debugging, such as a request ID that the log system can - include in all logged messages. - *) - - type 'a key - (** ['a key] is a fiber-local variable of type ['a]. - - Since the key is required to get or set a variable, a library can keep its - key private to control how the variable can be accessed. *) - - val create_key : unit -> 'a key - (** [create_key ()] creates a new fiber-local variable. *) - - val get : 'a key -> 'a option - (** [get key] reads [key] from the map of fiber local variables, returning its - value or {!None} if it has not been bound. *) - - val with_binding : 'a key -> 'a -> (unit -> 'b) -> 'b - (** [with_binding key value fn] runs [fn] with [key] bound to the provided - [value]. - - Whilst this binding only exists for the duration of this function {i on - this fiber}, it will be propagated to any forked fibers. If [fn] creates - fibers using an external switch, the bound value may be continue to be - used after this function returns. *) - - val without_binding : 'a key -> (unit -> 'b) -> 'b - (** [with_binding key value fn] runs [fn] with any binding for [key] removed. - *) -end - -(** @canonical Eio.Exn *) -module Exn : sig - type with_bt = exn * Printexc.raw_backtrace - - type err = .. - (** Describes the particular error that occurred. - - They are typically nested (e.g. [Fs (Permission_denied (Unix_error ...))]) - so that you can match e.g. all IO errors, all file-system errors, all - permission denied errors, etc. - - If you extend this, use {!register_pp} to add a printer for the new error. *) - - type context - (** Extra information attached to an IO error. - This provides contextual information about what caused the error. *) - - exception Io of err * context - (** A general purpose IO exception. - - This is used for most errors interacting with the outside world, - and is similar to {!Unix.Unix_error}, but more general. - An unknown [Io] error should typically be reported to the user, but does - not generally indicate a bug in the program. *) - - type err += Multiple_io of (err * context * Printexc.raw_backtrace) list - (** Error code used when multiple IO errors occur. - - This is useful if you want to catch and report all IO errors. *) - - val create : err -> exn - (** [create err] is an {!Io} exception with an empty context. *) - - val add_context : exn -> ('a, Format.formatter, unit, exn) format4 -> 'a - (** [add_context ex msg] returns a new exception with [msg] added to [ex]'s context, - if [ex] is an {!Io} exception. - - If [ex] is not an [Io] exception, this function just returns the original exception. *) - - val reraise_with_context : exn -> Printexc.raw_backtrace -> ('a, Format.formatter, unit, 'b) format4 -> 'a - (** [reraise_with_context ex bt msg] raises [ex] extended with additional information [msg]. - - [ex] should be an {!Io} exception (if not, is re-raised unmodified). - - Example: - {[ - try connect addr - with Eio.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - reraise_with_context ex bt "connecting to %S" addr - ]} - - You must get the backtrace before calling any other function - in the exception handler to prevent corruption of the backtrace. *) - - val register_pp : (Format.formatter -> err -> bool) -> unit - (** [register_pp pp] adds [pp] as a pretty-printer of errors. - - [pp f err] should format [err] using [f], if possible. - It should return [true] on success, or [false] if it didn't - recognise [err]. *) - - val pp : exn Fmt.t - (** [pp] is a formatter for exceptions. - - This is similar to {!Fmt.exn}, but can do a better job on {!Io} exceptions - because it can format them directly without having to convert to a string first. *) - - val pp_err : err Fmt.t - (** [pp_err] formats an error code. *) - - val empty_backtrace : Printexc.raw_backtrace - (** A backtrace with no frames. *) - - (** Extensible backend-specific exceptions. *) - module Backend : sig - type t = .. - - val show : bool ref - (** Controls the behaviour of {!pp}. *) - - val register_pp : (Format.formatter -> t -> bool) -> unit - (** [register_pp pp] adds [pp] as a pretty-printer of backend errors. - - [pp f err] should format [err] using [f], if possible. - It should return [true] on success, or [false] if it didn't - recognise [err]. *) - - val pp : t Fmt.t - (** [pp] behaves like {!pp} except that if display of backend errors has been turned off - (with {!show}) then it just prints a place-holder. - - This is useful for formatting the backend-specific part of exceptions, - which should be hidden in expect-style testing that needs to work on multiple backends. *) - end - - type err += X of Backend.t - (** A top-level code for backend errors that don't yet have a cross-platform classification in Eio. - - You should avoid matching on these (in portable code). Instead, request a proper Eio code for them. *) - - exception Multiple of with_bt list - (** Raised if multiple fibers fail, to report all the exceptions. - - This usually indicates a bug in the program. - - Note: If multiple {b IO} errors occur, then you will get [Io (Multiple_io _, _)] instead of this. *) - - val combine : with_bt -> with_bt -> with_bt - (** [combine x y] returns a single exception and backtrace to use to represent two errors. - - The resulting exception is typically just [Multiple [y; x]], - but various heuristics are used to simplify the result: - - Combining with a {!Cancel.Cancelled} exception does nothing, as these don't need to be reported. - The result is only [Cancelled] if there is no other exception available. - - If both errors are [Io] errors, then the result is [Io (Multiple_io _)]. *) -end - -(** @canonical Eio.Cancel *) -module Cancel : sig - (** This is the low-level interface to cancellation. - Every {!Switch} includes a cancellation context and most users will just use that API instead. - - Each domain has a tree of cancellation contexts, and every fiber is registered with one context. - A fiber can switch to a different context (e.g. by calling {!sub}). - When a context is cancelled, all registered fibers have their current cancellation function (if any) - called and removed. Child contexts are cancelled too, recursively, unless marked as protected. - - Many operations also check that the current context hasn't been cancelled, - so if a fiber is performing a non-cancellable operation it will still get cancelled soon afterwards. - This check is typically done when starting an operation, not at the end. - If an operation is cancelled after succeeding, but while still waiting on the run queue, - it will still return the operation's result. - A notable exception is {!Fiber.yield}, which checks at the end. - You can also use {!Fiber.check} to check manually. - - Whether a fiber is cancelled through a cancellation function or by checking its context, - it will receive a {!Cancelled} exception. - It is possible the exception will get lost (if something catches it and forgets to re-raise). - It is also possible to get this exception even when not cancelled, for example by awaiting - a promise which another fiber has resolved to a cancelled exception. - When in doubt, use [Fiber.check ()] to find out if your fiber is really cancelled. - Ideally this should be done any time you have caught an exception and are planning to ignore it, - although if you forget then the next IO operation will typically abort anyway. - - When handling a [Cancelled] exception, quick clean-up actions - (such as releasing a mutex or deleting a temporary file) are OK, - but operations that may block should be avoided. - For example, a network connection should simply be closed, - without attempting to send a goodbye message. - - The purpose of the cancellation system is to stop fibers quickly, not to report errors. - Use {!Switch.fail} instead to record an error. *) - - type t - (** A cancellation context. *) - - exception Cancelled of exn - (** [Cancelled ex] indicates that the context was cancelled with exception [ex]. - It is usually not necessary to report a [Cancelled] exception to the user, - as the original problem will be handled elsewhere. - - The nested exception is only intended for debug-level logging and should generally be ignored. *) - - val sub : (t -> 'a) -> 'a - (** [sub fn] installs a new cancellation context [t], runs [fn t] inside it, and then restores the old context. - - If the old context is cancelled while [fn] is running then [t] is cancelled too. - [t] cannot be used after [sub] returns. *) - - val protect : (unit -> 'a) -> 'a - (** [protect fn] runs [fn] in a new cancellation context that isn't cancelled when its parent is. - - This can be used to clean up resources on cancellation. - However, it is usually better to use {!Switch.on_release} (which calls this for you). - - Note that [protect] does not check its parent context when it finishes. *) - - val check : t -> unit - (** [check t] checks that [t] hasn't been cancelled. - @raise Cancelled If the context has been cancelled. *) - - val get_error : t -> exn option - (** [get_error t] is like [check t] except that it returns the exception instead of raising it. - - If [t] is finished, this returns (rather than raising) the [Invalid_argument] exception too. *) - - val cancel : t -> exn -> unit - (** [cancel t ex] marks [t] and its child contexts as cancelled, recursively, - and calls all registered fibers' cancellation functions, passing [Cancelled ex] as the argument. - - All cancellation functions are run, even if some of them raise exceptions. - - If [t] is already cancelled then this does nothing. - - Note that the caller of this function is still responsible for handling the error somehow - (e.g. reporting it to the user); it does not become the responsibility of the cancelled thread(s). *) - - val dump : t Fmt.t - (** Show the cancellation sub-tree rooted at [t], for debugging. *) -end - -(** @canonical Eio.Private *) -module Private : sig - module Trace = Trace - - module Cells = Cells - module Broadcast = Broadcast - module Single_waiter = Single_waiter - - (** Every fiber has an associated context. *) - module Fiber_context : sig - type t - - val make_root : unit -> t - (** Make a new root context for a new domain. *) - - val destroy : t -> unit - (** [destroy t] removes [t] from its cancellation context. *) - - val tid : t -> Trace.id - - (** {2 Cancellation} - - The {!Cancel} module describes the user's view of cancellation. - - Internally, when the user calls a primitive operation that needs to block the fiber, - the [Suspend callback] effect is performed. - This suspends the fiber and calls [callback] from the scheduler's context, - passing it the suspended fiber's context. - If the operation can be cancelled, - the callback should use {!set_cancel_fn} to register a cancellation function. - - There are two possible outcomes for the operation: it may complete normally, - or it may be cancelled. - If it is cancelled then the registered cancellation function is called. - This function will always be called from the fiber's own domain, but care must be taken - if the operation could be completed by another domain at the same time. - - Consider the case of {!Stream.take}, which can be fulfilled by a {!Stream.add} from another domain. - We want to ensure that either the item is removed from the stream and returned to the waiting fiber, - or that the operation is cancelled and the item is not removed from the stream. - - Therefore, cancelling and completing both need to update an atomic value (with {!Atomic.compare_and_set}) - so that only one can succeed. The case where [Stream.take] succeeds before cancellation: - - + A fiber calls [Suspend] and is suspended. - The callback sets a cancel function and registers a waiter on the stream. - + When another domain has an item, it marks the atomic as finished (making the [take] uncancellable) - and begins resuming the fiber with the new item. - + If the taking fiber is cancelled after this, the cancellation must be ignored and the operation - will complete successfully. Future operations will fail immediately, however. - - The case of cancellation winning the race: - - + A fiber calls [Suspend] and is suspended. - The callback sets a cancel function and registers a waiter on the stream. - + The taking fiber is cancelled. Its cancellation function is called, - which updates the atomic and starts removing the waiter. - + If another domain tries to provide an item to the waiter as this is happening, - it will try to update the atomic too and fail. - The item will be given to the next waiter instead. - - Note: A fiber will only have a cancel function set while it is suspended. *) - - val cancellation_context : t -> Cancel.t - (** [cancellation_context t] is [t]'s current cancellation context. *) - - val set_cancel_fn : t -> (exn -> unit) -> unit - (** [set_cancel_fn t fn] sets [fn] as the fiber's cancel function. - - If [t]'s cancellation context is cancelled, the function is called. - It should attempt to make the current operation finish quickly, either with - a successful result or by raising the given exception. - - Just before being called, the fiber's cancel function is replaced with [ignore] - so that [fn] cannot be called twice. - - On success, the cancel function is cleared automatically when {!Suspend.enter} returns, - but for single-domain operations you may like to call {!clear_cancel_fn} - manually to remove it earlier. - - [fn] will be called from [t]'s domain (from the fiber that called [cancel]). - - [fn] must not switch fibers. If it did, this could happen: - - + Another suspended fiber in the same cancellation context resumes before - its cancel function is called. - + It enters a protected block and starts a new operation. - + [fn] returns. - + We cancel the protected operation. *) - - val clear_cancel_fn : t -> unit - (** [clear_cancel_fn t] is [set_cancel_fn t ignore]. - - This must only be called from the fiber's own domain. - - For single-domain operations, it can be useful to call this manually as soon as - the operation succeeds (i.e. when the fiber is added to the run-queue) - to prevent the cancel function from being called. - - For operations where another domain may resume the fiber, your cancel function - will need to cope with being called after the operation has succeeded. In that - case you should not call [clear_cancel_fn]. The backend will do it automatically - just before resuming your fiber. *) - - val get_error : t -> exn option - (** [get_error t] is [Cancel.get_error (cancellation_context t)] *) - end - - module Effects : sig - type 'a enqueue = ('a, exn) result -> unit - (** A function provided by the scheduler to reschedule a previously-suspended thread. *) - - type _ Effect.t += - | Suspend : (Fiber_context.t -> 'a enqueue -> unit) -> 'a Effect.t - (** [Suspend fn] is performed when a fiber must be suspended - (e.g. because it called {!Promise.await} on an unresolved promise). - The effect handler runs [fn fiber enqueue] in the scheduler context, - passing it the suspended fiber's context and a function to resume it. - [fn] should arrange for [enqueue] to be called once the thread is ready to run again. *) - - | Fork : Fiber_context.t * (unit -> unit) -> unit Effect.t - (** [perform (Fork new_context f)] creates a new fiber and runs [f] in it, with context [new_context]. - [f] must not raise an exception. See {!Fiber.fork}. *) - - | Get_context : Fiber_context.t Effect.t - (** [perform Get_context] immediately returns the current fiber's context (without switching fibers). *) - end - - (** Suspend a fiber and enter the scheduler. *) - module Suspend : sig - val enter : string -> (Fiber_context.t -> 'a Effects.enqueue -> unit) -> 'a - (** [enter op fn] suspends the calling fiber and calls [fn ctx enqueue] in the scheduler's context. - - This should arrange for [enqueue] to be called when the fiber should be resumed. - [enqueue] is thread-safe and so can be called from another domain or systhread. - - [ctx] should be used to set a cancellation function. Otherwise, the operation is non-interruptable. - If the caller's cancellation context is already cancelled, [enter] immediately aborts. - - [op] is used when tracing to label the operation. *) - - val enter_unchecked : string -> (Fiber_context.t -> 'a Effects.enqueue -> unit) -> 'a - (** [enter_unchecked] is like [enter] except that it does not perform the initial check - that the fiber isn't cancelled (this is useful if you want to do the check yourself, e.g. - because you need to unlock a mutex if cancelled). *) - end - - module Debug : sig - val traceln : - ?__POS__:string * int * int * int -> - ('a, Format.formatter, unit, unit) format4 -> 'a - (** Writes trace logging using the current fiber's configured traceln function. *) - - val with_trace_prefix : (Format.formatter -> unit) -> (unit -> 'a) -> 'a - (** [with_trace_prefix fmt fn] runs [fn ()] with a traceln that outputs [fmt] before each message. *) - - val traceln_mutex : Stdlib.Mutex.t - (** The mutex used to prevent two domains writing to stderr at once. - - This might be useful if you want to write to it directly yourself, - e.g. for a log reporter. *) - - val default_traceln : - ?__POS__:string * int * int * int -> - ('a, Format.formatter, unit, unit) format4 -> 'a - (** [default_traceln] is a suitable default implementation for {!Eio.Std.traceln}. - - It writes output to stderr, prefixing each line with a "+". - If [__POS__] is given, it also displays the file and line number from that. - It uses {!traceln_mutex} so that only one domain's output is written at a time. *) - - type traceln = { - traceln : 'a. ?__POS__:string * int * int * int -> ('a, Format.formatter, unit, unit) format4 -> 'a; - } [@@unboxed] - - type t = < - traceln : traceln Fiber.key; - > - - val v : t - (** Backends should use this for {!Eio.Stdenv.debug}. *) - end -end +(** Private internal module. Use {!Eio} instead. *) + +(** @canonical Eio.Switch *) +module Switch : sig + (** Many resources in Eio (such as fibers and file handles) require a switch to + be provided when they are created. The resource cannot outlive its switch. + + If a function wants to create such resources, and was not passed a switch + as an argument, it will need to create a switch using {!run}. + This doesn't return until all resources attached to it have been freed, + preventing the function from leaking resources. + + Any function creating resources that outlive it needs to be given a + switch by its caller. + + Each switch includes its own {!Cancel.t} context. + Calling {!fail} cancels all fibers attached to the switch and, once they + have exited, reports the error. + + Note: this concept is known as a "nursery" or "bundle" in some other systems. + + Example: + {[ + Switch.run (fun sw -> + let flow = Dir.open_in ~sw dir "myfile.txt" in + ... + ); + (* [flow] will have been closed by this point *) + ]} + *) + + type t + (** A switch contains a group of fibers and other resources (such as open file handles). *) + + (** {2 Switch creation} *) + + val run : ?name:string -> (t -> 'a) -> 'a + (** [run fn] runs [fn] with a fresh switch (initially on). + + When [fn] finishes, [run] waits for all fibers registered with the switch to finish, + and then releases all attached resources. + + If {!fail} is called, [run] will re-raise the exception (after everything is cleaned up). + If [fn] raises an exception, it is passed to {!fail}. + + @param name Used to name the switch when tracing. *) + + val run_protected : ?name:string -> (t -> 'a) -> 'a + (** [run_protected fn] is like [run] but ignores cancellation requests from the parent context. *) + + (** {2 Cancellation and failure} *) + + val check : t -> unit + (** [check t] checks that [t] is still on. + @raise Cancel.Cancelled If the switch has been cancelled. *) + + val get_error : t -> exn option + (** [get_error t] is like [check t] except that it returns the exception instead of raising it. + If [t] is finished, this returns (rather than raising) the [Invalid_argument] exception too. *) + + val fail : ?bt:Printexc.raw_backtrace -> t -> exn -> unit + (** [fail t ex] adds [ex] to [t]'s set of failures and + ensures that the switch's cancellation context is cancelled, + to encourage all fibers to exit as soon as possible. + + [fail] returns immediately, without waiting for the shutdown actions to complete. + The exception will be raised later by {!run}, and [run]'s caller is responsible for handling it. + {!Exn.combine} is used to avoid duplicate or unnecessary exceptions. + @param bt A backtrace to attach to [ex] *) + + (** {2 Cleaning up resources} + + It is possible to attach clean-up hooks to a switch. + Once all fibers within the switch have finished, these hooks are called. + For example, when a file is opened it will register a release hook to close it. + + Functions that create such resources will take a switch argument + and call these functions for you. + You usually don't need to call these directly. *) + + val on_release : t -> (unit -> unit) -> unit + (** [on_release t fn] registers [fn] to be called once [t]'s main function has returned + and all fibers have finished. + + If [fn] raises an exception, it is passed to {!fail}. + + Release handlers are run in LIFO order, in series. + + Note that [fn] is called within a {!Cancel.protect}, since aborting clean-up actions is usually a bad idea + and the switch may have been cancelled by the time it runs. + You cannot attach new resources to a switch once the cancel hooks start to run. + + This function is thread-safe (but not signal-safe). + If the switch finishes before [fn] can be registered, + it raises [Invalid_argument] and runs [fn] immediately instead. *) + + type hook + (** A handle for removing a clean-up callback. *) + + val null_hook : hook + (** A dummy hook. [try_remove_hook null_hook = false]. *) + + val on_release_cancellable : t -> (unit -> unit) -> hook + (** Like [on_release], but the handler can be removed later. + + For example, opening a file will call [on_release_cancellable] to ensure the file is closed later. + However, if the file is manually closed before that, it will use {!remove_hook} to remove the hook, + which is no longer needed. + + This function is thread-safe (but not signal-safe). *) + + val try_remove_hook : hook -> bool + (** [try_remove_hook h] removes a previously-added hook. + Returns [true] if the hook was successfully removed, or [false] if another + domain ran it or removed it first. + + This function is thread-safe (but not signal-safe). *) + + val remove_hook : hook -> unit + (** [remove_hook h] is [ignore (try_remove_hook h)]. + + For multi-domain code, consider using {!try_remove_hook} instead + so that you can handle the case of trying to close a resource + just as another domain is closing it or finishing the switch. *) + + (** {2 Debugging} *) + + val dump : t Fmt.t + (** Dump out details of the switch's state for debugging. *) +end + +(** @canonical Eio.Promise *) +module Promise : sig + (** Unlike lazy values, you cannot "force" promises; + a promise is resolved when the maker of the promise is ready. + + Promises are thread-safe and so can be shared between domains and used + to communicate between them. + + Example: + {[ + let promise, resolver = Promise.create () in + Fiber.both + (fun () -> traceln "Got %d" (Promise.await promise)) + (fun () -> Promise.resolve resolver 42) + ]} *) + + type +!'a t + (** An ['a t] is a promise for a value of type ['a]. *) + + type -!'a u + (** An ['a u] is a resolver for a promise of type ['a]. *) + + val create : ?label:string -> unit -> 'a t * 'a u + (** [create ()] is a fresh promise/resolver pair. + The promise is initially unresolved. *) + + val create_resolved : 'a -> 'a t + (** [create_resolved x] is a promise that is already resolved with result [x]. *) + + val await : 'a t -> 'a + (** [await t] blocks until [t] is resolved. + If [t] is already resolved then this returns immediately. *) + + val resolve : 'a u -> 'a -> unit + (** [resolve u v] resolves [u]'s promise with the value [v]. + Any threads waiting for the result will be added to the run queue. + @raise Invalid_argument if [u] is already resolved. *) + + val try_resolve : 'a u -> 'a -> bool + (** [try_resolve] is like {!resolve} but returns [false] instead of raising [Invalid_argument]. + + Returns [true] on success. *) + + val peek : 'a t -> 'a option + (** [peek t] is [Some v] if the promise has been resolved to [v], or [None] otherwise. + If the result is [None] then it may change in future, otherwise it won't. + If another domain has access to the resolver then the state may have already + changed by the time this call returns. *) + + val is_resolved : 'a t -> bool + (** [is_resolved t] is [Option.is_some (peek t)]. *) + + (** {1 Result promises} *) + + type 'a or_exn = ('a, exn) result t + + val resolve_ok : ('a, 'b) result u -> 'a -> unit + (** [resolve_ok u x] is [resolve u (Ok x)]. *) + + val resolve_error : ('a, 'b) result u -> 'b -> unit + (** [resolve_error u x] is [resolve u (Error x)]. *) + + val await_exn : 'a or_exn -> 'a + (** [await_exn t] is like [await t], but if the result is [Error ex] then it raises [ex]. *) +end + +(** @canonical Eio.Fiber *) +module Fiber : sig + (** Within a domain, only one fiber can be running at a time. + A fiber runs until it performs an IO operation (directly or indirectly). + At that point, it may be suspended and the next fiber on the run queue runs. *) + + val both : (unit -> unit) -> (unit -> unit) -> unit + (** [both f g] runs [f ()] and [g ()] concurrently. + + They run in a new cancellation sub-context, and + if either raises an exception, the other is cancelled. + [both] waits for both functions to finish even if one raises + (it will then re-raise the original exception). + + [f] runs immediately, without switching to any other thread. + [g] is inserted at the head of the run-queue, so it runs next even if other threads are already enqueued. + You can get other scheduling orders by adding calls to {!yield} in various places. + e.g. to append both fibers to the end of the run-queue, yield immediately before calling [both]. + + If both fibers fail, {!Exn.combine} is used to combine the exceptions. *) + + val pair : (unit -> 'a) -> (unit -> 'b) -> 'a * 'b + (** [pair f g] is like [both], but returns the two results. *) + + val all : (unit -> unit) list -> unit + (** [all fs] is like [both], but for any number of fibers. + [all []] returns immediately. *) + + val first : ?combine:('a -> 'a -> 'a) -> (unit -> 'a) -> (unit -> 'a) -> 'a + (** [first f g] runs [f ()] and [g ()] concurrently. + + They run in a new cancellation sub-context, and when one finishes the other is cancelled. + If one raises, the other is cancelled and the exception is reported. + + As with [both], [f] runs immediately and [g] is scheduled next, ahead of any other queued work. + + If both fibers fail, {!Exn.combine} is used to combine the exceptions. + + Warning: it is always possible that {i both} operations will succeed. + This is because there is a period of time after the first operation succeeds + when it is waiting in the run-queue to resume + during which the other operation may also succeed. + + If both fibers succeed, [combine a b] is used to combine the results + (where [a] is the result of the first fiber to return and [b] is the second result). + The default is [fun a _ -> a], which discards the later result. *) + + val any : ?combine:('a -> 'a -> 'a) -> (unit -> 'a) list -> 'a + (** [any fs] is like [first], but for any number of fibers. + + [any []] just waits forever (or until cancelled). *) + + val n_any : (unit -> 'a) list -> 'a list + (** [n_any fs] is like [any], expect that if multiple fibers return values + then they are all returned, in the order in which the fibers finished. *) + + val await_cancel : unit -> 'a + (** [await_cancel ()] waits until cancelled. + @raise Cancel.Cancelled *) + + val fork : sw:Switch.t -> (unit -> unit) -> unit + (** [fork ~sw fn] runs [fn ()] in a new fiber, but does not wait for it to complete. + + The new fiber is attached to [sw] (which can't finish until the fiber ends). + + The new fiber inherits [sw]'s cancellation context. + If the fiber raises an exception, [Switch.fail sw] is called. + If [sw] is already off then [fn] fails immediately, but the calling thread continues. + + [fn] runs immediately, without switching to any other fiber first. + The calling fiber is placed at the head of the run queue, ahead of any previous items. *) + + val fork_promise : sw:Switch.t -> (unit -> 'a) -> 'a Promise.or_exn + (** [fork_promise ~sw fn] schedules [fn ()] to run in a new fiber and returns a promise for its result. + + This is just a convenience wrapper around {!fork}. + If [fn] raises an exception then the promise is resolved to the error, but [sw] is not failed. *) + + val fork_seq : sw:Switch.t -> (('a -> unit) -> unit) -> 'a Seq.t + (** [fork_seq ~sw fn] creates (but does not start) a new fiber to run [fn yield]. + + Requesting the next item from the returned sequence resumes the fiber until it + calls [yield x], using [x] value as the next item in the sequence. If [fn] + returns without producing a value then the result is {!Seq.Nil} (end-of-sequence). + + The returned sequence can be consumed safely from another domain. + [fn] itself always runs in the domain that called [fork_seq]. + + Example: + {[ + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> + for i = 1 to 3 do + traceln "Yielding %d" i; + yield i + done + ) in + Seq.iter (traceln "Got: %d") seq + ]} + + If [fn] raises an exception then the consumer receives it. + If the consumer cancels while awaiting a value, the producer is cancelled when + it next calls [yield]. + It is an error to request two items at once, or to request items out of sequence. + + @param sw When the switch finishes, the fiber is cancelled (if still running). + Attempting to read from the sequence after this raises an exception. *) + + val fork_daemon : sw:Switch.t -> (unit -> [`Stop_daemon]) -> unit + (** [fork_daemon] is like {!fork} except that instead of waiting for the fiber to finish, + the switch will cancel it once all non-daemon fibers are done. + + The switch will still wait for the daemon fiber to finish cancelling. + + The return type of [[`Stop_daemon]] instead of [unit] is just to catch mistakes, + as daemons normally aren't expected to return. *) + + val check : unit -> unit + (** [check ()] checks that the fiber's context hasn't been cancelled. + Many operations automatically check this before starting. + @raise Cancel.Cancelled if the fiber's context has been cancelled. *) + + val is_cancelled : unit -> bool + (** [is_cancelled ()] is [true] iff {!check} would raise an exception. *) + + val yield : unit -> unit + (** [yield ()] asks the scheduler to switch to the next runnable task. + The current task remains runnable, but goes to the back of the queue. + Automatically calls {!check} just before resuming. *) + + (** Concurrent list operations. *) + module List : sig + (** These functions behave like the ones in the standard library's [List] + module, except that multiple items can be processed concurrently. + + They correspond to Lwt's [Lwt_list.*_p] operations. e.g. + [Lwt_list.iter_p] becomes [Fiber.List.iter]. + For the [Lwt_list.*_s] operations, just use the standard library function. + e.g. [Lwt_list.iter_s] can be replaced by a plain [List.iter]. *) + + val filter : ?max_fibers:int -> ('a -> bool) -> 'a list -> 'a list + (** [filter f x] is like [List.filter f x] except that the invocations of [f] are + run concurrently in separate fibers. + @param max_fibers Maximum number of fibers to run concurrently *) + + val map : ?max_fibers:int -> ('a -> 'b) -> 'a list -> 'b list + (** [map f x] is like [List.map f x] except that the invocations of [f] are + run concurrently in separate fibers. + @param max_fibers Maximum number of fibers to run concurrently *) + + val filter_map : ?max_fibers:int -> ('a -> 'b option) -> 'a list -> 'b list + (** [filter_map f x] is like [List.filter_map f x] except that the + invocations of [f] are run concurrently in separate fibers. + @param max_fibers Maximum number of fibers to run concurrently *) + + val iter : ?max_fibers:int -> ('a -> unit) -> 'a list -> unit + (** [iter f x] is like [List.iter f x] except that the invocations of [f] are + run concurrently in separate fibers. + @param max_fibers Maximum number of fibers to run concurrently *) + end + + (** {2 Fiber-local variables} + + Each fiber maintains a map of additional variables associated with it, + which can be used to store fiber-related state or context. This map is + propagated to any forked fibers. + + While fiber-local variables can be useful, they can also make code much + harder to reason about, as they effectively act as another form of global + state. When possible, prefer passing arguments around explicitly. + + Fiber-local variables are particularly useful for attaching extra + information for debugging, such as a request ID that the log system can + include in all logged messages. + *) + + type 'a key + (** ['a key] is a fiber-local variable of type ['a]. + + Since the key is required to get or set a variable, a library can keep its + key private to control how the variable can be accessed. *) + + val create_key : unit -> 'a key + (** [create_key ()] creates a new fiber-local variable. *) + + val get : 'a key -> 'a option + (** [get key] reads [key] from the map of fiber local variables, returning its + value or {!None} if it has not been bound. *) + + val with_binding : 'a key -> 'a -> (unit -> 'b) -> 'b + (** [with_binding key value fn] runs [fn] with [key] bound to the provided + [value]. + + Whilst this binding only exists for the duration of this function {i on + this fiber}, it will be propagated to any forked fibers. If [fn] creates + fibers using an external switch, the bound value may be continue to be + used after this function returns. *) + + val without_binding : 'a key -> (unit -> 'b) -> 'b + (** [with_binding key value fn] runs [fn] with any binding for [key] removed. + *) +end + +(** @canonical Eio.Exn *) +module Exn : sig + type with_bt = exn * Printexc.raw_backtrace + + type err = .. + (** Describes the particular error that occurred. + + They are typically nested (e.g. [Fs (Permission_denied (Unix_error ...))]) + so that you can match e.g. all IO errors, all file-system errors, all + permission denied errors, etc. + + If you extend this, use {!register_pp} to add a printer for the new error. *) + + type context + (** Extra information attached to an IO error. + This provides contextual information about what caused the error. *) + + exception Io of err * context + (** A general purpose IO exception. + + This is used for most errors interacting with the outside world, + and is similar to {!Unix.Unix_error}, but more general. + An unknown [Io] error should typically be reported to the user, but does + not generally indicate a bug in the program. *) + + type err += Multiple_io of (err * context * Printexc.raw_backtrace) list + (** Error code used when multiple IO errors occur. + + This is useful if you want to catch and report all IO errors. *) + + val create : err -> exn + (** [create err] is an {!Io} exception with an empty context. *) + + val add_context : exn -> ('a, Format.formatter, unit, exn) format4 -> 'a + (** [add_context ex msg] returns a new exception with [msg] added to [ex]'s context, + if [ex] is an {!Io} exception. + + If [ex] is not an [Io] exception, this function just returns the original exception. *) + + val reraise_with_context : exn -> Printexc.raw_backtrace -> ('a, Format.formatter, unit, 'b) format4 -> 'a + (** [reraise_with_context ex bt msg] raises [ex] extended with additional information [msg]. + + [ex] should be an {!Io} exception (if not, is re-raised unmodified). + + Example: + {[ + try connect addr + with Eio.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + reraise_with_context ex bt "connecting to %S" addr + ]} + + You must get the backtrace before calling any other function + in the exception handler to prevent corruption of the backtrace. *) + + val register_pp : (Format.formatter -> err -> bool) -> unit + (** [register_pp pp] adds [pp] as a pretty-printer of errors. + + [pp f err] should format [err] using [f], if possible. + It should return [true] on success, or [false] if it didn't + recognise [err]. *) + + val pp : exn Fmt.t + (** [pp] is a formatter for exceptions. + + This is similar to {!Fmt.exn}, but can do a better job on {!Io} exceptions + because it can format them directly without having to convert to a string first. *) + + val pp_err : err Fmt.t + (** [pp_err] formats an error code. *) + + val empty_backtrace : Printexc.raw_backtrace + (** A backtrace with no frames. *) + + (** Extensible backend-specific exceptions. *) + module Backend : sig + type t = .. + + val show : bool ref + (** Controls the behaviour of {!pp}. *) + + val register_pp : (Format.formatter -> t -> bool) -> unit + (** [register_pp pp] adds [pp] as a pretty-printer of backend errors. + + [pp f err] should format [err] using [f], if possible. + It should return [true] on success, or [false] if it didn't + recognise [err]. *) + + val pp : t Fmt.t + (** [pp] behaves like {!pp} except that if display of backend errors has been turned off + (with {!show}) then it just prints a place-holder. + + This is useful for formatting the backend-specific part of exceptions, + which should be hidden in expect-style testing that needs to work on multiple backends. *) + end + + type err += X of Backend.t + (** A top-level code for backend errors that don't yet have a cross-platform classification in Eio. + + You should avoid matching on these (in portable code). Instead, request a proper Eio code for them. *) + + exception Multiple of with_bt list + (** Raised if multiple fibers fail, to report all the exceptions. + + This usually indicates a bug in the program. + + Note: If multiple {b IO} errors occur, then you will get [Io (Multiple_io _, _)] instead of this. *) + + val combine : with_bt -> with_bt -> with_bt + (** [combine x y] returns a single exception and backtrace to use to represent two errors. + + The resulting exception is typically just [Multiple [y; x]], + but various heuristics are used to simplify the result: + - Combining with a {!Cancel.Cancelled} exception does nothing, as these don't need to be reported. + The result is only [Cancelled] if there is no other exception available. + - If both errors are [Io] errors, then the result is [Io (Multiple_io _)]. *) +end + +(** @canonical Eio.Cancel *) +module Cancel : sig + (** This is the low-level interface to cancellation. + Every {!Switch} includes a cancellation context and most users will just use that API instead. + + Each domain has a tree of cancellation contexts, and every fiber is registered with one context. + A fiber can switch to a different context (e.g. by calling {!sub}). + When a context is cancelled, all registered fibers have their current cancellation function (if any) + called and removed. Child contexts are cancelled too, recursively, unless marked as protected. + + Many operations also check that the current context hasn't been cancelled, + so if a fiber is performing a non-cancellable operation it will still get cancelled soon afterwards. + This check is typically done when starting an operation, not at the end. + If an operation is cancelled after succeeding, but while still waiting on the run queue, + it will still return the operation's result. + A notable exception is {!Fiber.yield}, which checks at the end. + You can also use {!Fiber.check} to check manually. + + Whether a fiber is cancelled through a cancellation function or by checking its context, + it will receive a {!Cancelled} exception. + It is possible the exception will get lost (if something catches it and forgets to re-raise). + It is also possible to get this exception even when not cancelled, for example by awaiting + a promise which another fiber has resolved to a cancelled exception. + When in doubt, use [Fiber.check ()] to find out if your fiber is really cancelled. + Ideally this should be done any time you have caught an exception and are planning to ignore it, + although if you forget then the next IO operation will typically abort anyway. + + When handling a [Cancelled] exception, quick clean-up actions + (such as releasing a mutex or deleting a temporary file) are OK, + but operations that may block should be avoided. + For example, a network connection should simply be closed, + without attempting to send a goodbye message. + + The purpose of the cancellation system is to stop fibers quickly, not to report errors. + Use {!Switch.fail} instead to record an error. *) + + type t + (** A cancellation context. *) + + exception Cancelled of exn + (** [Cancelled ex] indicates that the context was cancelled with exception [ex]. + It is usually not necessary to report a [Cancelled] exception to the user, + as the original problem will be handled elsewhere. + + The nested exception is only intended for debug-level logging and should generally be ignored. *) + + val sub : (t -> 'a) -> 'a + (** [sub fn] installs a new cancellation context [t], runs [fn t] inside it, and then restores the old context. + + If the old context is cancelled while [fn] is running then [t] is cancelled too. + [t] cannot be used after [sub] returns. *) + + val protect : (unit -> 'a) -> 'a + (** [protect fn] runs [fn] in a new cancellation context that isn't cancelled when its parent is. + + This can be used to clean up resources on cancellation. + However, it is usually better to use {!Switch.on_release} (which calls this for you). + + Note that [protect] does not check its parent context when it finishes. *) + + val check : t -> unit + (** [check t] checks that [t] hasn't been cancelled. + @raise Cancelled If the context has been cancelled. *) + + val get_error : t -> exn option + (** [get_error t] is like [check t] except that it returns the exception instead of raising it. + + If [t] is finished, this returns (rather than raising) the [Invalid_argument] exception too. *) + + val cancel : t -> exn -> unit + (** [cancel t ex] marks [t] and its child contexts as cancelled, recursively, + and calls all registered fibers' cancellation functions, passing [Cancelled ex] as the argument. + + All cancellation functions are run, even if some of them raise exceptions. + + If [t] is already cancelled then this does nothing. + + Note that the caller of this function is still responsible for handling the error somehow + (e.g. reporting it to the user); it does not become the responsibility of the cancelled thread(s). *) + + val dump : t Fmt.t + (** Show the cancellation sub-tree rooted at [t], for debugging. *) +end + +(** @canonical Eio.Private *) +module Private : sig + module Trace = Trace + + module Cells = Cells + module Broadcast = Broadcast + module Single_waiter = Single_waiter + + (** Every fiber has an associated context. *) + module Fiber_context : sig + type t + + val make_root : unit -> t + (** Make a new root context for a new domain. *) + + val destroy : t -> unit + (** [destroy t] removes [t] from its cancellation context. *) + + val tid : t -> Trace.id + + (** {2 Cancellation} + + The {!Cancel} module describes the user's view of cancellation. + + Internally, when the user calls a primitive operation that needs to block the fiber, + the [Suspend callback] effect is performed. + This suspends the fiber and calls [callback] from the scheduler's context, + passing it the suspended fiber's context. + If the operation can be cancelled, + the callback should use {!set_cancel_fn} to register a cancellation function. + + There are two possible outcomes for the operation: it may complete normally, + or it may be cancelled. + If it is cancelled then the registered cancellation function is called. + This function will always be called from the fiber's own domain, but care must be taken + if the operation could be completed by another domain at the same time. + + Consider the case of {!Stream.take}, which can be fulfilled by a {!Stream.add} from another domain. + We want to ensure that either the item is removed from the stream and returned to the waiting fiber, + or that the operation is cancelled and the item is not removed from the stream. + + Therefore, cancelling and completing both need to update an atomic value (with {!Atomic.compare_and_set}) + so that only one can succeed. The case where [Stream.take] succeeds before cancellation: + + + A fiber calls [Suspend] and is suspended. + The callback sets a cancel function and registers a waiter on the stream. + + When another domain has an item, it marks the atomic as finished (making the [take] uncancellable) + and begins resuming the fiber with the new item. + + If the taking fiber is cancelled after this, the cancellation must be ignored and the operation + will complete successfully. Future operations will fail immediately, however. + + The case of cancellation winning the race: + + + A fiber calls [Suspend] and is suspended. + The callback sets a cancel function and registers a waiter on the stream. + + The taking fiber is cancelled. Its cancellation function is called, + which updates the atomic and starts removing the waiter. + + If another domain tries to provide an item to the waiter as this is happening, + it will try to update the atomic too and fail. + The item will be given to the next waiter instead. + + Note: A fiber will only have a cancel function set while it is suspended. *) + + val cancellation_context : t -> Cancel.t + (** [cancellation_context t] is [t]'s current cancellation context. *) + + val set_cancel_fn : t -> (exn -> unit) -> unit + (** [set_cancel_fn t fn] sets [fn] as the fiber's cancel function. + + If [t]'s cancellation context is cancelled, the function is called. + It should attempt to make the current operation finish quickly, either with + a successful result or by raising the given exception. + + Just before being called, the fiber's cancel function is replaced with [ignore] + so that [fn] cannot be called twice. + + On success, the cancel function is cleared automatically when {!Suspend.enter} returns, + but for single-domain operations you may like to call {!clear_cancel_fn} + manually to remove it earlier. + + [fn] will be called from [t]'s domain (from the fiber that called [cancel]). + + [fn] must not switch fibers. If it did, this could happen: + + + Another suspended fiber in the same cancellation context resumes before + its cancel function is called. + + It enters a protected block and starts a new operation. + + [fn] returns. + + We cancel the protected operation. *) + + val clear_cancel_fn : t -> unit + (** [clear_cancel_fn t] is [set_cancel_fn t ignore]. + + This must only be called from the fiber's own domain. + + For single-domain operations, it can be useful to call this manually as soon as + the operation succeeds (i.e. when the fiber is added to the run-queue) + to prevent the cancel function from being called. + + For operations where another domain may resume the fiber, your cancel function + will need to cope with being called after the operation has succeeded. In that + case you should not call [clear_cancel_fn]. The backend will do it automatically + just before resuming your fiber. *) + + val get_error : t -> exn option + (** [get_error t] is [Cancel.get_error (cancellation_context t)] *) + end + + module Effects : sig + type 'a enqueue = ('a, exn) result -> unit + (** A function provided by the scheduler to reschedule a previously-suspended thread. *) + + type _ Effect.t += + | Suspend : (Fiber_context.t -> 'a enqueue -> unit) -> 'a Effect.t + (** [Suspend fn] is performed when a fiber must be suspended + (e.g. because it called {!Promise.await} on an unresolved promise). + The effect handler runs [fn fiber enqueue] in the scheduler context, + passing it the suspended fiber's context and a function to resume it. + [fn] should arrange for [enqueue] to be called once the thread is ready to run again. *) + + | Fork : Fiber_context.t * (unit -> unit) -> unit Effect.t + (** [perform (Fork new_context f)] creates a new fiber and runs [f] in it, with context [new_context]. + [f] must not raise an exception. See {!Fiber.fork}. *) + + | Get_context : Fiber_context.t Effect.t + (** [perform Get_context] immediately returns the current fiber's context (without switching fibers). *) + end + + (** Suspend a fiber and enter the scheduler. *) + module Suspend : sig + val enter : string -> (Fiber_context.t -> 'a Effects.enqueue -> unit) -> 'a + (** [enter op fn] suspends the calling fiber and calls [fn ctx enqueue] in the scheduler's context. + + This should arrange for [enqueue] to be called when the fiber should be resumed. + [enqueue] is thread-safe and so can be called from another domain or systhread. + + [ctx] should be used to set a cancellation function. Otherwise, the operation is non-interruptable. + If the caller's cancellation context is already cancelled, [enter] immediately aborts. + + [op] is used when tracing to label the operation. *) + + val enter_unchecked : string -> (Fiber_context.t -> 'a Effects.enqueue -> unit) -> 'a + (** [enter_unchecked] is like [enter] except that it does not perform the initial check + that the fiber isn't cancelled (this is useful if you want to do the check yourself, e.g. + because you need to unlock a mutex if cancelled). *) + end + + module Debug : sig + val traceln : + ?__POS__:string * int * int * int -> + ('a, Format.formatter, unit, unit) format4 -> 'a + (** Writes trace logging using the current fiber's configured traceln function. *) + + val with_trace_prefix : (Format.formatter -> unit) -> (unit -> 'a) -> 'a + (** [with_trace_prefix fmt fn] runs [fn ()] with a traceln that outputs [fmt] before each message. *) + + val traceln_mutex : Stdlib.Mutex.t + (** The mutex used to prevent two domains writing to stderr at once. + + This might be useful if you want to write to it directly yourself, + e.g. for a log reporter. *) + + val default_traceln : + ?__POS__:string * int * int * int -> + ('a, Format.formatter, unit, unit) format4 -> 'a + (** [default_traceln] is a suitable default implementation for {!Eio.Std.traceln}. + + It writes output to stderr, prefixing each line with a "+". + If [__POS__] is given, it also displays the file and line number from that. + It uses {!traceln_mutex} so that only one domain's output is written at a time. *) + + type traceln = { + traceln : 'a. ?__POS__:string * int * int * int -> ('a, Format.formatter, unit, unit) format4 -> 'a; + } [@@unboxed] + + type t = < + traceln : traceln Fiber.key; + > + + val v : t + (** Backends should use this for {!Eio.Stdenv.debug}. *) + end +end diff --git a/lib_eio/core/exn.ml b/lib_eio/core/exn.ml index b8a310a20..63490d99c 100644 --- a/lib_eio/core/exn.ml +++ b/lib_eio/core/exn.ml @@ -1,132 +1,132 @@ -let show_backend_exceptions = ref true - -type with_bt = exn * Printexc.raw_backtrace - -type err = .. - -type context = { - steps : string list; -} - -exception Io of err * context - -exception Multiple of (exn * Printexc.raw_backtrace) list (* Note: the last exception in list is the first one reported *) - -type err += Multiple_io of (err * context * Printexc.raw_backtrace) list - -exception Cancelled of exn - -let create err = Io (err, { steps = [] }) - -let empty_backtrace = Printexc.get_callstack 0 - -let add_context ex fmt = - fmt |> Fmt.kstr @@ fun msg -> - match ex with - | Io (code, t) -> Io (code, {steps = msg :: t.steps}) - | ex -> ex - -let reraise_with_context ex bt fmt = - fmt |> Fmt.kstr @@ fun msg -> - match ex with - | Io (code, t) -> - let context = { steps = msg :: t.steps } in - Printexc.raise_with_backtrace (Io (code, context)) bt - | _ -> - Printexc.raise_with_backtrace ex bt - -let err_printers : (Format.formatter -> err -> bool) list ref = ref [] - -let register_pp fn = - err_printers := fn :: !err_printers - -let break f _ = Format.pp_print_custom_break f - ~fits:(",", 1, "") - ~breaks:(",", 2, "") - -let pp_err f x = - let rec aux = function - | [] -> Fmt.string f "?" - | pp :: pps -> if not (pp f x) then aux pps - in - aux !err_printers - -let pp_with_context f (code, context) = - Fmt.pf f "%a%a" pp_err code - Fmt.(list ~sep:nop (break ++ string)) (List.rev context.steps) - -let pp_with_bt f (code, context, bt) = - match String.trim (Printexc.raw_backtrace_to_string bt) with - | "" -> - Fmt.pf f "- @[%a@]" - pp_with_context (code, context) - | bt -> - Fmt.pf f "- @[%a@,%a@]" - pp_with_context (code, context) - Fmt.lines bt - -let pp f = function - | Io (code, t) -> - Fmt.pf f "Eio.Io %a%a" - pp_err code - Fmt.(list ~sep:nop (break ++ string)) (List.rev t.steps) - | ex -> - Fmt.string f (Printexc.to_string ex) - -let pp_multiple f exns = - let pp_with_bt f (ex, bt) = - match String.trim (Printexc.raw_backtrace_to_string bt) with - | "" -> - Fmt.pf f "- @[%a@]" pp ex - | bt -> - Fmt.pf f "- @[%a@,%a@]" - pp ex - Fmt.lines bt - in - Fmt.pf f "@[Multiple exceptions:@,%a@]" - (Fmt.(list ~sep:cut) pp_with_bt) (List.rev exns) - -let () = - Printexc.register_printer @@ function - | Io _ as ex -> Some (Fmt.str "@[%a@]" pp ex) - | Multiple exns -> Some (Fmt.str "%a" pp_multiple exns) - | Cancelled ex -> Some ("Cancelled: " ^ Printexc.to_string ex) - | _ -> None - -let combine e1 e2 = - if fst e1 == fst e2 then e1 - else match e1, e2 with - | (Cancelled _, _), e - | e, (Cancelled _, _) -> e (* Don't need to report a cancelled exception if we have something better *) - | (Io (c1, t1), bt1), (Io (c2, t2), bt2) -> create (Multiple_io [(c1, t1, bt1); (c2, t2, bt2)]), empty_backtrace - | (Multiple exs, bt1), e2 -> Multiple (e2 :: exs), bt1 - | e1, e2 -> Multiple [e2; e1], empty_backtrace - -module Backend = struct - type t = .. - - let show = ref true - - let printers : (Format.formatter -> t -> bool) list ref = ref [] - - let register_pp fn = - printers := fn :: !printers - - let pp f x = - if !show then ( - let rec aux = function - | [] -> Fmt.string f "?" - | pp :: pps -> if not (pp f x) then aux pps - in - aux !printers - ) else Fmt.string f "_" -end - -type err += X of Backend.t - -let () = - register_pp (fun f -> function - | Multiple_io errs -> Fmt.pf f "Multiple_io@\n%a" (Fmt.(list ~sep:cut) pp_with_bt) errs; true - | X ex -> Backend.pp f ex; true - | _ -> false - ) +let show_backend_exceptions = ref true + +type with_bt = exn * Printexc.raw_backtrace + +type err = .. + +type context = { + steps : string list; +} + +exception Io of err * context + +exception Multiple of (exn * Printexc.raw_backtrace) list (* Note: the last exception in list is the first one reported *) + +type err += Multiple_io of (err * context * Printexc.raw_backtrace) list + +exception Cancelled of exn + +let create err = Io (err, { steps = [] }) + +let empty_backtrace = Printexc.get_callstack 0 + +let add_context ex fmt = + fmt |> Fmt.kstr @@ fun msg -> + match ex with + | Io (code, t) -> Io (code, {steps = msg :: t.steps}) + | ex -> ex + +let reraise_with_context ex bt fmt = + fmt |> Fmt.kstr @@ fun msg -> + match ex with + | Io (code, t) -> + let context = { steps = msg :: t.steps } in + Printexc.raise_with_backtrace (Io (code, context)) bt + | _ -> + Printexc.raise_with_backtrace ex bt + +let err_printers : (Format.formatter -> err -> bool) list ref = ref [] + +let register_pp fn = + err_printers := fn :: !err_printers + +let break f _ = Format.pp_print_custom_break f + ~fits:(",", 1, "") + ~breaks:(",", 2, "") + +let pp_err f x = + let rec aux = function + | [] -> Fmt.string f "?" + | pp :: pps -> if not (pp f x) then aux pps + in + aux !err_printers + +let pp_with_context f (code, context) = + Fmt.pf f "%a%a" pp_err code + Fmt.(list ~sep:nop (break ++ string)) (List.rev context.steps) + +let pp_with_bt f (code, context, bt) = + match String.trim (Printexc.raw_backtrace_to_string bt) with + | "" -> + Fmt.pf f "- @[%a@]" + pp_with_context (code, context) + | bt -> + Fmt.pf f "- @[%a@,%a@]" + pp_with_context (code, context) + Fmt.lines bt + +let pp f = function + | Io (code, t) -> + Fmt.pf f "Eio.Io %a%a" + pp_err code + Fmt.(list ~sep:nop (break ++ string)) (List.rev t.steps) + | ex -> + Fmt.string f (Printexc.to_string ex) + +let pp_multiple f exns = + let pp_with_bt f (ex, bt) = + match String.trim (Printexc.raw_backtrace_to_string bt) with + | "" -> + Fmt.pf f "- @[%a@]" pp ex + | bt -> + Fmt.pf f "- @[%a@,%a@]" + pp ex + Fmt.lines bt + in + Fmt.pf f "@[Multiple exceptions:@,%a@]" + (Fmt.(list ~sep:cut) pp_with_bt) (List.rev exns) + +let () = + Printexc.register_printer @@ function + | Io _ as ex -> Some (Fmt.str "@[%a@]" pp ex) + | Multiple exns -> Some (Fmt.str "%a" pp_multiple exns) + | Cancelled ex -> Some ("Cancelled: " ^ Printexc.to_string ex) + | _ -> None + +let combine e1 e2 = + if fst e1 == fst e2 then e1 + else match e1, e2 with + | (Cancelled _, _), e + | e, (Cancelled _, _) -> e (* Don't need to report a cancelled exception if we have something better *) + | (Io (c1, t1), bt1), (Io (c2, t2), bt2) -> create (Multiple_io [(c1, t1, bt1); (c2, t2, bt2)]), empty_backtrace + | (Multiple exs, bt1), e2 -> Multiple (e2 :: exs), bt1 + | e1, e2 -> Multiple [e2; e1], empty_backtrace + +module Backend = struct + type t = .. + + let show = ref true + + let printers : (Format.formatter -> t -> bool) list ref = ref [] + + let register_pp fn = + printers := fn :: !printers + + let pp f x = + if !show then ( + let rec aux = function + | [] -> Fmt.string f "?" + | pp :: pps -> if not (pp f x) then aux pps + in + aux !printers + ) else Fmt.string f "_" +end + +type err += X of Backend.t + +let () = + register_pp (fun f -> function + | Multiple_io errs -> Fmt.pf f "Multiple_io@\n%a" (Fmt.(list ~sep:cut) pp_with_bt) errs; true + | X ex -> Backend.pp f ex; true + | _ -> false + ) diff --git a/lib_eio/core/fiber.ml b/lib_eio/core/fiber.ml index 3113e8ccc..3d2d70f04 100644 --- a/lib_eio/core/fiber.ml +++ b/lib_eio/core/fiber.ml @@ -1,399 +1,399 @@ -[@@@alert "-unstable"] - -type _ Effect.t += Fork : Cancel.fiber_context * (unit -> unit) -> unit Effect.t - -let yield () = - let fiber = Suspend.enter "" (fun fiber enqueue -> enqueue (Ok fiber)) in - Cancel.check fiber.cancel_context - -(* Note: [f] must not raise an exception, as that would terminate the whole scheduler. *) -let fork_raw new_fiber f = - Effect.perform (Fork (new_fiber, f)) - -let fork ~sw f = - Switch.check_our_domain sw; - if Cancel.is_on sw.cancel then ( - let vars = Cancel.Fiber_context.get_vars () in - let new_fiber = Cancel.Fiber_context.make ~cc:sw.cancel ~vars in - fork_raw new_fiber @@ fun () -> - Switch.with_op sw @@ fun () -> - try - f () - with ex -> - let bt = Printexc.get_raw_backtrace () in - Switch.fail ~bt sw ex; (* The [with_op] ensures this will succeed *) - ) (* else the fiber should report the error to [sw], but [sw] is failed anyway *) - -let fork_daemon ~sw f = - Switch.check_our_domain sw; - if Cancel.is_on sw.cancel then ( - let vars = Cancel.Fiber_context.get_vars () in - let new_fiber = Cancel.Fiber_context.make ~cc:sw.cancel ~vars in - fork_raw new_fiber @@ fun () -> - Switch.with_daemon sw @@ fun () -> - match f () with - | `Stop_daemon -> - (* The daemon asked to stop. *) - () - | exception Cancel.Cancelled Exit when not (Cancel.is_on sw.cancel) -> - (* The daemon was cancelled because all non-daemon fibers are finished. *) - () - | exception ex -> - Switch.fail sw ex; (* The [with_daemon] ensures this will succeed *) - ) (* else the fiber should report the error to [sw], but [sw] is failed anyway *) - -let fork_promise ~sw f = - Switch.check_our_domain sw; - let vars = Cancel.Fiber_context.get_vars () in - let new_fiber = Cancel.Fiber_context.make ~cc:sw.Switch.cancel ~vars in - let p, r = Promise.create_with_id (Cancel.Fiber_context.tid new_fiber) in - fork_raw new_fiber (fun () -> - match Switch.with_op sw f with - | x -> Promise.resolve_ok r x - | exception ex -> Promise.resolve_error r ex (* Can't fail; only we have [r] *) - ); - p - -(* This is not exposed. On failure it fails [sw], but you need to make sure that - any fibers waiting on the promise will be cancelled. *) -let fork_promise_exn ~sw f = - Switch.check_our_domain sw; - let vars = Cancel.Fiber_context.get_vars () in - let new_fiber = Cancel.Fiber_context.make ~cc:sw.Switch.cancel ~vars in - let p, r = Promise.create_with_id (Cancel.Fiber_context.tid new_fiber) in - fork_raw new_fiber (fun () -> - match Switch.with_op sw f with - | x -> Promise.resolve r x - | exception ex -> - Switch.fail sw ex (* The [with_op] ensures this will succeed *) - ); - p - -(* Like [List.iter (fork ~sw)], but runs the last one in the current fiber - for efficiency and less cluttered traces. *) -let rec forks ~sw = function - | [] -> () - | [x] -> Switch.check sw; x () - | x :: xs -> - fork ~sw x; - forks ~sw xs - -let all xs = - Switch.run ~name:"all" @@ fun sw -> - forks ~sw xs - -let both f g = - Switch.run ~name:"both" @@ fun sw -> - forks ~sw [f; g] - -let pair f g = - Switch.run ~name:"pair" @@ fun sw -> - let x = fork_promise ~sw f in - let y = g () in - (Promise.await_exn x, y) - -exception Not_first - -let await_cancel () = - Suspend.enter "await_cancel" @@ fun fiber enqueue -> - Cancel.Fiber_context.set_cancel_fn fiber (fun ex -> enqueue (Error ex)) - -type 'a any_status = - | New - | Ex of (exn * Printexc.raw_backtrace) - | OK of 'a - -let any_gen ~return ~combine fs = - let r = ref New in - let parent_c = - Cancel.sub_unchecked Any (fun cc -> - let wrap h = - match h () with - | x -> - begin match !r with - | New -> r := OK (return x); Cancel.cancel cc Not_first - | OK prev -> r := OK (combine prev x) - | Ex _ -> () - end - | exception Cancel.Cancelled _ when not (Cancel.is_on cc) -> - (* If this is in response to us asking the fiber to cancel then we can just ignore it. - If it's in response to our parent context being cancelled (which also cancels [cc]) then - we'll check that context and raise it at the end anyway. *) - () - | exception ex -> - begin match !r with - | New -> r := Ex (ex, Printexc.get_raw_backtrace ()); Cancel.cancel cc ex - | OK _ -> r := Ex (ex, Printexc.get_raw_backtrace ()) - | Ex prev -> - let bt = Printexc.get_raw_backtrace () in - r := Ex (Exn.combine prev (ex, bt)) - end - in - let vars = Cancel.Fiber_context.get_vars () in - let rec aux = function - | [] -> await_cancel () - | [f] -> wrap f; [] - | f :: fs -> - let new_fiber = Cancel.Fiber_context.make ~cc ~vars in - let p, r = Promise.create_with_id (Cancel.Fiber_context.tid new_fiber) in - fork_raw new_fiber (fun () -> - match wrap f with - | () -> Promise.resolve_ok r () - | exception ex -> Promise.resolve_error r ex - ); - p :: aux fs - in - let ps = aux fs in - Cancel.protect (fun () -> List.iter Promise.await_exn ps) - ) - in - match !r, Cancel.get_error parent_c with - | OK r, None -> r - | (OK _ | New), Some ex -> raise ex - | Ex (ex, bt), None -> Printexc.raise_with_backtrace ex bt - | Ex ex1, Some ex2 -> - let bt2 = Printexc.get_raw_backtrace () in - let ex, bt = Exn.combine ex1 (ex2, bt2) in - Printexc.raise_with_backtrace ex bt - | New, None -> assert false - -let n_any fs = - List.rev (any_gen fs ~return:(fun x -> [x]) ~combine:(fun xs x -> x :: xs)) - -let any ?(combine=(fun x _ -> x)) fs = any_gen fs ~return:Fun.id ~combine - -let first ?combine f g = any ?combine [f; g] - -let is_cancelled () = - let ctx = Effect.perform Cancel.Get_context in - not (Cancel.is_on ctx.cancel_context) - -let check () = - let ctx = Effect.perform Cancel.Get_context in - Cancel.check ctx.cancel_context - -(* Some concurrent list operations *) -module List = struct - - let opt_cons x xs = - match x with - | None -> xs - | Some x -> x :: xs - - module Limiter : sig - (** This is a bit like using a semaphore, but it assumes that there is only a - single fiber using it. e.g. you must not call {!use}, {!fork}, etc from - two different fibers. *) - - type t - - val create : sw:Switch.t -> int -> t - (** [create ~sw n] is a limiter that allows running up to [n] jobs at once. *) - - val use : t -> ('a -> 'b) -> 'a -> 'b - (** [use t fn x] runs [fn x] in this fiber, counting it as one use of [t]. *) - - val fork : t -> ('a -> unit) -> 'a -> unit - (** [fork t fn x] runs [fn x] in a new fibre, once a fiber is free. *) - - val fork_promise_exn : t -> ('a -> 'b) -> 'a -> 'b Promise.t - (** [fork_promise_exn t fn x] runs [fn x] in a new fibre, once a fiber is free, - and returns a promise for the result. *) - end = struct - type t = { - mutable free_fibers : int; - cond : unit Single_waiter.t; - sw : Switch.t; - } - - let max_fibers_err n = - Fmt.failwith "max_fibers must be positive (got %d)" n - - let create ~sw max_fibers = - if max_fibers <= 0 then max_fibers_err max_fibers; - { - free_fibers = max_fibers; - cond = Single_waiter.create (); - sw; - } - - let await_free t = - if t.free_fibers = 0 then Single_waiter.await t.cond "Limiter.await_free" t.sw.cancel.id; - (* If we got woken up then there was a free fiber then. And since we're the - only fiber that uses [t], and we were sleeping, it must still be free. *) - assert (t.free_fibers > 0); - t.free_fibers <- t.free_fibers - 1 - - let release t = - t.free_fibers <- t.free_fibers + 1; - if t.free_fibers = 1 then Single_waiter.wake_if_sleeping t.cond - - let use t fn x = - await_free t; - let r = fn x in - release t; - r - - let fork_promise_exn t fn x = - await_free t; - fork_promise_exn ~sw:t.sw (fun () -> let r = fn x in release t; r) - - let fork t fn x = - await_free t; - fork ~sw:t.sw (fun () -> fn x; release t) - end - - let filter_map ?(max_fibers=max_int) fn items = - match items with - | [] -> [] (* Avoid creating a switch in the simple case *) - | items -> - Switch.run ~name:"filter_map" @@ fun sw -> - let limiter = Limiter.create ~sw max_fibers in - let rec aux = function - | [] -> [] - | [x] -> Option.to_list (Limiter.use limiter fn x) - | x :: xs -> - let x = Limiter.fork_promise_exn limiter fn x in - let xs = aux xs in - opt_cons (Promise.await x) xs - in - aux items - - let map ?max_fibers fn = filter_map ?max_fibers (fun x -> Some (fn x)) - let filter ?max_fibers fn = filter_map ?max_fibers (fun x -> if fn x then Some x else None) - - let iter ?(max_fibers=max_int) fn items = - match items with - | [] -> () (* Avoid creating a switch in the simple case *) - | items -> - Switch.run ~name:"iter" @@ fun sw -> - let limiter = Limiter.create ~sw max_fibers in - let rec aux = function - | [] -> () - | [x] -> Limiter.use limiter fn x - | x :: xs -> - Limiter.fork limiter fn x; - aux xs - in - aux items - -end - -type 'a key = 'a Hmap.key - -let create_key () = Hmap.Key.create () - -let get key = Hmap.find key (Cancel.Fiber_context.get_vars ()) - -let with_binding var value fn = - let ctx = Effect.perform Cancel.Get_context in - Cancel.Fiber_context.with_vars ctx (Hmap.add var value ctx.vars) fn - -let without_binding var fn = - let ctx = Effect.perform Cancel.Get_context in - Cancel.Fiber_context.with_vars ctx (Hmap.rem var ctx.vars) fn - -(* Coroutines. - - [fork_coroutine ~sw fn] creates a new fiber for [fn]. [fn] immediately suspends, setting its state to - [Ready enqueue]. A consumer can resume it by setting the state to [Running] and calling [enqueue], - while suspending itself. The consumer passes in its own [enqueue] function. They run alternatively - like this, switching between the [Ready] and [Running] states. - - To finish, the coroutine fiber can set the state to [Finished] or [Failed], - or the client can set the state to [Client_cancelled]. -*) - -(* Note: we could easily generalise this to [('in, 'out) coroutine] if that was useful. *) -type 'out coroutine = - [ `Init - | `Ready of [`Running of 'out Suspend.enqueue] Suspend.enqueue - | `Running of 'out Suspend.enqueue - | `Finished - | `Client_cancelled of exn - | `Failed of exn ] - -(* The only good reason for the state to change while the coroutine is running is if the client - cancels. Return the exception in that case. If the coroutine is buggy it might e.g. fork two - fibers and yield twice for a single request - return Invalid_argument in that case. *) -let unwrap_cancelled state = - match Atomic.get state with - | `Client_cancelled ex -> ex - | `Finished | `Failed _ -> Invalid_argument "Coroutine has already stopped!" - | `Ready _ -> Invalid_argument "Coroutine has already yielded!" - | `Init | `Running _ -> Invalid_argument "Coroutine in unexpected state!" - -let run_coroutine ~state fn = - let await_request ~prev ~on_suspend = - (* Suspend and wait for the consumer to resume us: *) - Suspend.enter "await-consumer" (fun ctx enqueue -> - let ready = `Ready enqueue in - if Atomic.compare_and_set state prev ready then ( - Cancel.Fiber_context.set_cancel_fn ctx (fun ex -> - if Atomic.compare_and_set state ready (`Failed ex) then - enqueue (Error ex); - (* else the client enqueued a resume for us; handle that instead *) - ); - on_suspend () - ) else ( - enqueue (Error (unwrap_cancelled state)) - ) - ) - in - let current_state = ref (await_request ~prev:`Init ~on_suspend:ignore) in - fn (fun v -> - (* The coroutine wants to yield the value [v] and suspend. *) - let `Running enqueue as prev = !current_state in - current_state := await_request ~prev ~on_suspend:(fun () -> enqueue (Ok (Some v))) - ); - (* [fn] has finished. End the stream. *) - if Atomic.compare_and_set state (!current_state :> _ coroutine) `Finished then ( - let `Running enqueue = !current_state in - enqueue (Ok None) - ) else ( - raise (unwrap_cancelled state) - ) - -let fork_coroutine ~sw fn = - let state = Atomic.make `Init in - fork_daemon ~sw (fun () -> - try - run_coroutine ~state fn; - `Stop_daemon - with ex -> - match ex, Atomic.exchange state (`Failed ex) with - | _, `Running enqueue -> - (* A client is waiting for us. Send the error there. Also do this if we were cancelled. *) - enqueue (Error ex); - `Stop_daemon - | Cancel.Cancelled _, _ -> - (* The client isn't waiting (probably it got cancelled, then we tried to yield to it and got cancelled too). - If it tries to resume us later it will see the error. *) - `Stop_daemon - | _ -> - (* Something unexpected happened. Re-raise. *) - raise ex - ); - fun () -> - Suspend.enter "await-producer" (fun ctx enqueue -> - let rec aux () = - match Atomic.get state with - | `Ready resume as prev -> - let running = `Running enqueue in - if Atomic.compare_and_set state prev running then ( - resume (Ok running); - Cancel.Fiber_context.set_cancel_fn ctx (fun ex -> - if Atomic.compare_and_set state running (`Client_cancelled ex) then - enqueue (Error ex) - ) - ) else aux () - | `Finished -> enqueue (Error (Invalid_argument "Coroutine has already finished!")) - | `Failed ex | `Client_cancelled ex -> enqueue (Error (Invalid_argument ("Coroutine has already failed: " ^ Printexc.to_string ex))) - | `Running _ -> enqueue (Error (Invalid_argument "Coroutine is still running!")) - | `Init -> assert false - in - aux () - ) - -let fork_seq ~sw fn = - Seq.of_dispenser (fork_coroutine ~sw fn) +[@@@alert "-unstable"] + +type _ Effect.t += Fork : Cancel.fiber_context * (unit -> unit) -> unit Effect.t + +let yield () = + let fiber = Suspend.enter "" (fun fiber enqueue -> enqueue (Ok fiber)) in + Cancel.check fiber.cancel_context + +(* Note: [f] must not raise an exception, as that would terminate the whole scheduler. *) +let fork_raw new_fiber f = + Effect.perform (Fork (new_fiber, f)) + +let fork ~sw f = + Switch.check_our_domain sw; + if Cancel.is_on sw.cancel then ( + let vars = Cancel.Fiber_context.get_vars () in + let new_fiber = Cancel.Fiber_context.make ~cc:sw.cancel ~vars in + fork_raw new_fiber @@ fun () -> + Switch.with_op sw @@ fun () -> + try + f () + with ex -> + let bt = Printexc.get_raw_backtrace () in + Switch.fail ~bt sw ex; (* The [with_op] ensures this will succeed *) + ) (* else the fiber should report the error to [sw], but [sw] is failed anyway *) + +let fork_daemon ~sw f = + Switch.check_our_domain sw; + if Cancel.is_on sw.cancel then ( + let vars = Cancel.Fiber_context.get_vars () in + let new_fiber = Cancel.Fiber_context.make ~cc:sw.cancel ~vars in + fork_raw new_fiber @@ fun () -> + Switch.with_daemon sw @@ fun () -> + match f () with + | `Stop_daemon -> + (* The daemon asked to stop. *) + () + | exception Cancel.Cancelled Exit when not (Cancel.is_on sw.cancel) -> + (* The daemon was cancelled because all non-daemon fibers are finished. *) + () + | exception ex -> + Switch.fail sw ex; (* The [with_daemon] ensures this will succeed *) + ) (* else the fiber should report the error to [sw], but [sw] is failed anyway *) + +let fork_promise ~sw f = + Switch.check_our_domain sw; + let vars = Cancel.Fiber_context.get_vars () in + let new_fiber = Cancel.Fiber_context.make ~cc:sw.Switch.cancel ~vars in + let p, r = Promise.create_with_id (Cancel.Fiber_context.tid new_fiber) in + fork_raw new_fiber (fun () -> + match Switch.with_op sw f with + | x -> Promise.resolve_ok r x + | exception ex -> Promise.resolve_error r ex (* Can't fail; only we have [r] *) + ); + p + +(* This is not exposed. On failure it fails [sw], but you need to make sure that + any fibers waiting on the promise will be cancelled. *) +let fork_promise_exn ~sw f = + Switch.check_our_domain sw; + let vars = Cancel.Fiber_context.get_vars () in + let new_fiber = Cancel.Fiber_context.make ~cc:sw.Switch.cancel ~vars in + let p, r = Promise.create_with_id (Cancel.Fiber_context.tid new_fiber) in + fork_raw new_fiber (fun () -> + match Switch.with_op sw f with + | x -> Promise.resolve r x + | exception ex -> + Switch.fail sw ex (* The [with_op] ensures this will succeed *) + ); + p + +(* Like [List.iter (fork ~sw)], but runs the last one in the current fiber + for efficiency and less cluttered traces. *) +let rec forks ~sw = function + | [] -> () + | [x] -> Switch.check sw; x () + | x :: xs -> + fork ~sw x; + forks ~sw xs + +let all xs = + Switch.run ~name:"all" @@ fun sw -> + forks ~sw xs + +let both f g = + Switch.run ~name:"both" @@ fun sw -> + forks ~sw [f; g] + +let pair f g = + Switch.run ~name:"pair" @@ fun sw -> + let x = fork_promise ~sw f in + let y = g () in + (Promise.await_exn x, y) + +exception Not_first + +let await_cancel () = + Suspend.enter "await_cancel" @@ fun fiber enqueue -> + Cancel.Fiber_context.set_cancel_fn fiber (fun ex -> enqueue (Error ex)) + +type 'a any_status = + | New + | Ex of (exn * Printexc.raw_backtrace) + | OK of 'a + +let any_gen ~return ~combine fs = + let r = ref New in + let parent_c = + Cancel.sub_unchecked Any (fun cc -> + let wrap h = + match h () with + | x -> + begin match !r with + | New -> r := OK (return x); Cancel.cancel cc Not_first + | OK prev -> r := OK (combine prev x) + | Ex _ -> () + end + | exception Cancel.Cancelled _ when not (Cancel.is_on cc) -> + (* If this is in response to us asking the fiber to cancel then we can just ignore it. + If it's in response to our parent context being cancelled (which also cancels [cc]) then + we'll check that context and raise it at the end anyway. *) + () + | exception ex -> + begin match !r with + | New -> r := Ex (ex, Printexc.get_raw_backtrace ()); Cancel.cancel cc ex + | OK _ -> r := Ex (ex, Printexc.get_raw_backtrace ()) + | Ex prev -> + let bt = Printexc.get_raw_backtrace () in + r := Ex (Exn.combine prev (ex, bt)) + end + in + let vars = Cancel.Fiber_context.get_vars () in + let rec aux = function + | [] -> await_cancel () + | [f] -> wrap f; [] + | f :: fs -> + let new_fiber = Cancel.Fiber_context.make ~cc ~vars in + let p, r = Promise.create_with_id (Cancel.Fiber_context.tid new_fiber) in + fork_raw new_fiber (fun () -> + match wrap f with + | () -> Promise.resolve_ok r () + | exception ex -> Promise.resolve_error r ex + ); + p :: aux fs + in + let ps = aux fs in + Cancel.protect (fun () -> List.iter Promise.await_exn ps) + ) + in + match !r, Cancel.get_error parent_c with + | OK r, None -> r + | (OK _ | New), Some ex -> raise ex + | Ex (ex, bt), None -> Printexc.raise_with_backtrace ex bt + | Ex ex1, Some ex2 -> + let bt2 = Printexc.get_raw_backtrace () in + let ex, bt = Exn.combine ex1 (ex2, bt2) in + Printexc.raise_with_backtrace ex bt + | New, None -> assert false + +let n_any fs = + List.rev (any_gen fs ~return:(fun x -> [x]) ~combine:(fun xs x -> x :: xs)) + +let any ?(combine=(fun x _ -> x)) fs = any_gen fs ~return:Fun.id ~combine + +let first ?combine f g = any ?combine [f; g] + +let is_cancelled () = + let ctx = Effect.perform Cancel.Get_context in + not (Cancel.is_on ctx.cancel_context) + +let check () = + let ctx = Effect.perform Cancel.Get_context in + Cancel.check ctx.cancel_context + +(* Some concurrent list operations *) +module List = struct + + let opt_cons x xs = + match x with + | None -> xs + | Some x -> x :: xs + + module Limiter : sig + (** This is a bit like using a semaphore, but it assumes that there is only a + single fiber using it. e.g. you must not call {!use}, {!fork}, etc from + two different fibers. *) + + type t + + val create : sw:Switch.t -> int -> t + (** [create ~sw n] is a limiter that allows running up to [n] jobs at once. *) + + val use : t -> ('a -> 'b) -> 'a -> 'b + (** [use t fn x] runs [fn x] in this fiber, counting it as one use of [t]. *) + + val fork : t -> ('a -> unit) -> 'a -> unit + (** [fork t fn x] runs [fn x] in a new fibre, once a fiber is free. *) + + val fork_promise_exn : t -> ('a -> 'b) -> 'a -> 'b Promise.t + (** [fork_promise_exn t fn x] runs [fn x] in a new fibre, once a fiber is free, + and returns a promise for the result. *) + end = struct + type t = { + mutable free_fibers : int; + cond : unit Single_waiter.t; + sw : Switch.t; + } + + let max_fibers_err n = + Fmt.failwith "max_fibers must be positive (got %d)" n + + let create ~sw max_fibers = + if max_fibers <= 0 then max_fibers_err max_fibers; + { + free_fibers = max_fibers; + cond = Single_waiter.create (); + sw; + } + + let await_free t = + if t.free_fibers = 0 then Single_waiter.await t.cond "Limiter.await_free" t.sw.cancel.id; + (* If we got woken up then there was a free fiber then. And since we're the + only fiber that uses [t], and we were sleeping, it must still be free. *) + assert (t.free_fibers > 0); + t.free_fibers <- t.free_fibers - 1 + + let release t = + t.free_fibers <- t.free_fibers + 1; + if t.free_fibers = 1 then Single_waiter.wake_if_sleeping t.cond + + let use t fn x = + await_free t; + let r = fn x in + release t; + r + + let fork_promise_exn t fn x = + await_free t; + fork_promise_exn ~sw:t.sw (fun () -> let r = fn x in release t; r) + + let fork t fn x = + await_free t; + fork ~sw:t.sw (fun () -> fn x; release t) + end + + let filter_map ?(max_fibers=max_int) fn items = + match items with + | [] -> [] (* Avoid creating a switch in the simple case *) + | items -> + Switch.run ~name:"filter_map" @@ fun sw -> + let limiter = Limiter.create ~sw max_fibers in + let rec aux = function + | [] -> [] + | [x] -> Option.to_list (Limiter.use limiter fn x) + | x :: xs -> + let x = Limiter.fork_promise_exn limiter fn x in + let xs = aux xs in + opt_cons (Promise.await x) xs + in + aux items + + let map ?max_fibers fn = filter_map ?max_fibers (fun x -> Some (fn x)) + let filter ?max_fibers fn = filter_map ?max_fibers (fun x -> if fn x then Some x else None) + + let iter ?(max_fibers=max_int) fn items = + match items with + | [] -> () (* Avoid creating a switch in the simple case *) + | items -> + Switch.run ~name:"iter" @@ fun sw -> + let limiter = Limiter.create ~sw max_fibers in + let rec aux = function + | [] -> () + | [x] -> Limiter.use limiter fn x + | x :: xs -> + Limiter.fork limiter fn x; + aux xs + in + aux items + +end + +type 'a key = 'a Hmap.key + +let create_key () = Hmap.Key.create () + +let get key = Hmap.find key (Cancel.Fiber_context.get_vars ()) + +let with_binding var value fn = + let ctx = Effect.perform Cancel.Get_context in + Cancel.Fiber_context.with_vars ctx (Hmap.add var value ctx.vars) fn + +let without_binding var fn = + let ctx = Effect.perform Cancel.Get_context in + Cancel.Fiber_context.with_vars ctx (Hmap.rem var ctx.vars) fn + +(* Coroutines. + + [fork_coroutine ~sw fn] creates a new fiber for [fn]. [fn] immediately suspends, setting its state to + [Ready enqueue]. A consumer can resume it by setting the state to [Running] and calling [enqueue], + while suspending itself. The consumer passes in its own [enqueue] function. They run alternatively + like this, switching between the [Ready] and [Running] states. + + To finish, the coroutine fiber can set the state to [Finished] or [Failed], + or the client can set the state to [Client_cancelled]. +*) + +(* Note: we could easily generalise this to [('in, 'out) coroutine] if that was useful. *) +type 'out coroutine = + [ `Init + | `Ready of [`Running of 'out Suspend.enqueue] Suspend.enqueue + | `Running of 'out Suspend.enqueue + | `Finished + | `Client_cancelled of exn + | `Failed of exn ] + +(* The only good reason for the state to change while the coroutine is running is if the client + cancels. Return the exception in that case. If the coroutine is buggy it might e.g. fork two + fibers and yield twice for a single request - return Invalid_argument in that case. *) +let unwrap_cancelled state = + match Atomic.get state with + | `Client_cancelled ex -> ex + | `Finished | `Failed _ -> Invalid_argument "Coroutine has already stopped!" + | `Ready _ -> Invalid_argument "Coroutine has already yielded!" + | `Init | `Running _ -> Invalid_argument "Coroutine in unexpected state!" + +let run_coroutine ~state fn = + let await_request ~prev ~on_suspend = + (* Suspend and wait for the consumer to resume us: *) + Suspend.enter "await-consumer" (fun ctx enqueue -> + let ready = `Ready enqueue in + if Atomic.compare_and_set state prev ready then ( + Cancel.Fiber_context.set_cancel_fn ctx (fun ex -> + if Atomic.compare_and_set state ready (`Failed ex) then + enqueue (Error ex); + (* else the client enqueued a resume for us; handle that instead *) + ); + on_suspend () + ) else ( + enqueue (Error (unwrap_cancelled state)) + ) + ) + in + let current_state = ref (await_request ~prev:`Init ~on_suspend:ignore) in + fn (fun v -> + (* The coroutine wants to yield the value [v] and suspend. *) + let `Running enqueue as prev = !current_state in + current_state := await_request ~prev ~on_suspend:(fun () -> enqueue (Ok (Some v))) + ); + (* [fn] has finished. End the stream. *) + if Atomic.compare_and_set state (!current_state :> _ coroutine) `Finished then ( + let `Running enqueue = !current_state in + enqueue (Ok None) + ) else ( + raise (unwrap_cancelled state) + ) + +let fork_coroutine ~sw fn = + let state = Atomic.make `Init in + fork_daemon ~sw (fun () -> + try + run_coroutine ~state fn; + `Stop_daemon + with ex -> + match ex, Atomic.exchange state (`Failed ex) with + | _, `Running enqueue -> + (* A client is waiting for us. Send the error there. Also do this if we were cancelled. *) + enqueue (Error ex); + `Stop_daemon + | Cancel.Cancelled _, _ -> + (* The client isn't waiting (probably it got cancelled, then we tried to yield to it and got cancelled too). + If it tries to resume us later it will see the error. *) + `Stop_daemon + | _ -> + (* Something unexpected happened. Re-raise. *) + raise ex + ); + fun () -> + Suspend.enter "await-producer" (fun ctx enqueue -> + let rec aux () = + match Atomic.get state with + | `Ready resume as prev -> + let running = `Running enqueue in + if Atomic.compare_and_set state prev running then ( + resume (Ok running); + Cancel.Fiber_context.set_cancel_fn ctx (fun ex -> + if Atomic.compare_and_set state running (`Client_cancelled ex) then + enqueue (Error ex) + ) + ) else aux () + | `Finished -> enqueue (Error (Invalid_argument "Coroutine has already finished!")) + | `Failed ex | `Client_cancelled ex -> enqueue (Error (Invalid_argument ("Coroutine has already failed: " ^ Printexc.to_string ex))) + | `Running _ -> enqueue (Error (Invalid_argument "Coroutine is still running!")) + | `Init -> assert false + in + aux () + ) + +let fork_seq ~sw fn = + Seq.of_dispenser (fork_coroutine ~sw fn) diff --git a/lib_eio/core/promise.ml b/lib_eio/core/promise.ml index 05f54b576..cdc5d8994 100644 --- a/lib_eio/core/promise.ml +++ b/lib_eio/core/promise.ml @@ -1,107 +1,107 @@ -type 'a state = - | Resolved of 'a - | Unresolved of Broadcast.t - -type !'a promise = { - id : Trace.id; - state : 'a state Atomic.t; (* Note: we always switch to Resolved before broadcasting *) -} - -type +!'a t -type -!'a u - -type 'a or_exn = ('a, exn) result t - -let to_public_promise : 'a promise -> 'a t = Obj.magic -let to_public_resolver : 'a promise -> 'a u = Obj.magic -let of_public_promise : 'a t -> 'a promise = Obj.magic -let of_public_resolver : 'a u -> 'a promise = Obj.magic - -let create_with_id id = - let t = { - id; - state = Atomic.make (Unresolved (Broadcast.create ())); - } in - to_public_promise t, to_public_resolver t - -let create ?label () = - let id = Trace.mint_id () in - Trace.create_obj ?label id Promise; - create_with_id id - -let create_resolved x = - let id = Trace.mint_id () in - Trace.create_obj id Promise; - to_public_promise { id; state = Atomic.make (Resolved x) } - -let await t = - let t = of_public_promise t in - match Atomic.get t.state with - | Resolved x -> - Trace.get t.id; - x - | Unresolved b -> - Suspend.enter "Promise.await" (fun ctx enqueue -> - match Broadcast.suspend b (fun () -> enqueue (Ok ())) with - | None -> () (* We got resumed immediately *) - | Some request -> - match Atomic.get t.state with - | Resolved _ -> - (* The promise was resolved as we were suspending. - Resume now if we haven't already done so. *) - if Broadcast.cancel request then enqueue (Ok ()) - | Unresolved _ -> - (* We observed the promise to be still unresolved after registering a waiter. - Therefore any resolution must happen after we were registered and we will be notified. *) - Trace.try_get t.id; - Cancel.Fiber_context.set_cancel_fn ctx (fun ex -> - if Broadcast.cancel request then enqueue (Error ex) - (* else already resumed *) - ) - ); - match Atomic.get t.state with - | Resolved x -> - Trace.get t.id; - x - | Unresolved _ -> assert false - -let await_exn t = - match await t with - | Ok x -> x - | Error ex -> raise ex - -let try_resolve t v = - let rec resolve' t v = - match Atomic.get t.state with - | Resolved _ -> false - | Unresolved b as prev -> - if Atomic.compare_and_set t.state prev (Resolved v) then ( - Trace.put t.id; - Broadcast.resume_all b; - true - ) else ( - (* Otherwise, the promise was already resolved. Retry (to get the error). *) - resolve' t v - ) - in - resolve' (of_public_resolver t) v - -let resolve u x = - if not (try_resolve u x) then - invalid_arg "Can't resolve already-resolved promise" - -let resolve_ok u x = resolve u (Ok x) -let resolve_error u x = resolve u (Error x) - -let peek t = - let t = of_public_promise t in - match Atomic.get t.state with - | Unresolved _ -> None - | Resolved x -> Some x - -let id t = - let t = of_public_promise t in - t.id - -let is_resolved t = - Option.is_some (peek t) +type 'a state = + | Resolved of 'a + | Unresolved of Broadcast.t + +type !'a promise = { + id : Trace.id; + state : 'a state Atomic.t; (* Note: we always switch to Resolved before broadcasting *) +} + +type +!'a t +type -!'a u + +type 'a or_exn = ('a, exn) result t + +let to_public_promise : 'a promise -> 'a t = Obj.magic +let to_public_resolver : 'a promise -> 'a u = Obj.magic +let of_public_promise : 'a t -> 'a promise = Obj.magic +let of_public_resolver : 'a u -> 'a promise = Obj.magic + +let create_with_id id = + let t = { + id; + state = Atomic.make (Unresolved (Broadcast.create ())); + } in + to_public_promise t, to_public_resolver t + +let create ?label () = + let id = Trace.mint_id () in + Trace.create_obj ?label id Promise; + create_with_id id + +let create_resolved x = + let id = Trace.mint_id () in + Trace.create_obj id Promise; + to_public_promise { id; state = Atomic.make (Resolved x) } + +let await t = + let t = of_public_promise t in + match Atomic.get t.state with + | Resolved x -> + Trace.get t.id; + x + | Unresolved b -> + Suspend.enter "Promise.await" (fun ctx enqueue -> + match Broadcast.suspend b (fun () -> enqueue (Ok ())) with + | None -> () (* We got resumed immediately *) + | Some request -> + match Atomic.get t.state with + | Resolved _ -> + (* The promise was resolved as we were suspending. + Resume now if we haven't already done so. *) + if Broadcast.cancel request then enqueue (Ok ()) + | Unresolved _ -> + (* We observed the promise to be still unresolved after registering a waiter. + Therefore any resolution must happen after we were registered and we will be notified. *) + Trace.try_get t.id; + Cancel.Fiber_context.set_cancel_fn ctx (fun ex -> + if Broadcast.cancel request then enqueue (Error ex) + (* else already resumed *) + ) + ); + match Atomic.get t.state with + | Resolved x -> + Trace.get t.id; + x + | Unresolved _ -> assert false + +let await_exn t = + match await t with + | Ok x -> x + | Error ex -> raise ex + +let try_resolve t v = + let rec resolve' t v = + match Atomic.get t.state with + | Resolved _ -> false + | Unresolved b as prev -> + if Atomic.compare_and_set t.state prev (Resolved v) then ( + Trace.put t.id; + Broadcast.resume_all b; + true + ) else ( + (* Otherwise, the promise was already resolved. Retry (to get the error). *) + resolve' t v + ) + in + resolve' (of_public_resolver t) v + +let resolve u x = + if not (try_resolve u x) then + invalid_arg "Can't resolve already-resolved promise" + +let resolve_ok u x = resolve u (Ok x) +let resolve_error u x = resolve u (Error x) + +let peek t = + let t = of_public_promise t in + match Atomic.get t.state with + | Unresolved _ -> None + | Resolved x -> Some x + +let id t = + let t = of_public_promise t in + t.id + +let is_resolved t = + Option.is_some (peek t) diff --git a/lib_eio/core/single_waiter.ml b/lib_eio/core/single_waiter.ml index dfd72d887..907b82b3c 100644 --- a/lib_eio/core/single_waiter.ml +++ b/lib_eio/core/single_waiter.ml @@ -1,42 +1,42 @@ -type 'a state = - | Running - | Sleeping of (('a, exn) result -> unit) - -type 'a t = 'a state ref - -let create () = ref Running - -let wake t v = - match !t with - | Running -> false - | Sleeping fn -> - t := Running; - fn v; - true - -let wake_if_sleeping t = - ignore (wake t (Ok ()) : bool) - -let await t op id = - let x = - Suspend.enter op @@ fun ctx enqueue -> - Cancel.Fiber_context.set_cancel_fn ctx (fun ex -> - t := Running; - enqueue (Error ex) - ); - t := Sleeping (fun x -> - Cancel.Fiber_context.clear_cancel_fn ctx; - t := Running; - enqueue x - ) - in - Trace.get id; - x - -let await_protect t op id = - let x = - Suspend.enter_unchecked op @@ fun _ctx enqueue -> - t := Sleeping (fun x -> t := Running; enqueue x) - in - Trace.get id; - x +type 'a state = + | Running + | Sleeping of (('a, exn) result -> unit) + +type 'a t = 'a state ref + +let create () = ref Running + +let wake t v = + match !t with + | Running -> false + | Sleeping fn -> + t := Running; + fn v; + true + +let wake_if_sleeping t = + ignore (wake t (Ok ()) : bool) + +let await t op id = + let x = + Suspend.enter op @@ fun ctx enqueue -> + Cancel.Fiber_context.set_cancel_fn ctx (fun ex -> + t := Running; + enqueue (Error ex) + ); + t := Sleeping (fun x -> + Cancel.Fiber_context.clear_cancel_fn ctx; + t := Running; + enqueue x + ) + in + Trace.get id; + x + +let await_protect t op id = + let x = + Suspend.enter_unchecked op @@ fun _ctx enqueue -> + t := Sleeping (fun x -> t := Running; enqueue x) + in + Trace.get id; + x diff --git a/lib_eio/core/single_waiter.mli b/lib_eio/core/single_waiter.mli index d058ea30c..c5ca93463 100644 --- a/lib_eio/core/single_waiter.mli +++ b/lib_eio/core/single_waiter.mli @@ -1,25 +1,25 @@ -(** Allows a single fiber to wait to be notified by another fiber in the same domain. - If multiple fibers need to wait at once, or the notification comes from another domain, - this can't be used. *) - -type 'a t -(** A handle representing a fiber that might be sleeping. - It is either in the Running or Sleeping state. *) - -val create : unit -> 'a t -(** [create ()] is a new waiter, initially in the Running state. *) - -val wake : 'a t -> ('a, exn) result -> bool -(** [wake t v] resumes [t]'s fiber with value [v] and returns [true] if it was sleeping. - If [t] is Running then this just returns [false]. *) - -val wake_if_sleeping : unit t -> unit -(** [wake_if_sleeping] is [ignore (wake t (Ok ()))]. *) - -val await : 'a t -> string -> Trace.id -> 'a -(** [await t op id] suspends the calling fiber, changing [t]'s state to Sleeping. - If the fiber is cancelled, a cancel exception is raised. - [op] and [id] are used for tracing. *) - -val await_protect : 'a t -> string -> Trace.id -> 'a -(** [await_protect] is like {!await}, but the sleep cannot be cancelled. *) +(** Allows a single fiber to wait to be notified by another fiber in the same domain. + If multiple fibers need to wait at once, or the notification comes from another domain, + this can't be used. *) + +type 'a t +(** A handle representing a fiber that might be sleeping. + It is either in the Running or Sleeping state. *) + +val create : unit -> 'a t +(** [create ()] is a new waiter, initially in the Running state. *) + +val wake : 'a t -> ('a, exn) result -> bool +(** [wake t v] resumes [t]'s fiber with value [v] and returns [true] if it was sleeping. + If [t] is Running then this just returns [false]. *) + +val wake_if_sleeping : unit t -> unit +(** [wake_if_sleeping] is [ignore (wake t (Ok ()))]. *) + +val await : 'a t -> string -> Trace.id -> 'a +(** [await t op id] suspends the calling fiber, changing [t]'s state to Sleeping. + If the fiber is cancelled, a cancel exception is raised. + [op] and [id] are used for tracing. *) + +val await_protect : 'a t -> string -> Trace.id -> 'a +(** [await_protect] is like {!await}, but the sleep cannot be cancelled. *) diff --git a/lib_eio/core/suspend.ml b/lib_eio/core/suspend.ml index 2fb940d56..775eab4e1 100644 --- a/lib_eio/core/suspend.ml +++ b/lib_eio/core/suspend.ml @@ -1,12 +1,12 @@ -type 'a enqueue = ('a, exn) result -> unit -type _ Effect.t += Suspend : (Cancel.fiber_context -> 'a enqueue -> unit) -> 'a Effect.t - -let enter_unchecked op fn = - Trace.suspend_fiber op; - Effect.perform (Suspend fn) - -let enter op fn = - enter_unchecked op @@ fun fiber enqueue -> - match Cancel.Fiber_context.get_error fiber with - | None -> fn fiber enqueue - | Some ex -> enqueue (Error ex) +type 'a enqueue = ('a, exn) result -> unit +type _ Effect.t += Suspend : (Cancel.fiber_context -> 'a enqueue -> unit) -> 'a Effect.t + +let enter_unchecked op fn = + Trace.suspend_fiber op; + Effect.perform (Suspend fn) + +let enter op fn = + enter_unchecked op @@ fun fiber enqueue -> + match Cancel.Fiber_context.get_error fiber with + | None -> fn fiber enqueue + | Some ex -> enqueue (Error ex) diff --git a/lib_eio/core/switch.ml b/lib_eio/core/switch.ml index f9bde2a15..8cc77a290 100644 --- a/lib_eio/core/switch.ml +++ b/lib_eio/core/switch.ml @@ -1,199 +1,199 @@ -type t = { - mutable fibers : int; (* Total, including daemon_fibers and the main function *) - mutable daemon_fibers : int; - mutable exs : (exn * Printexc.raw_backtrace) option; - on_release_lock : Mutex.t; - mutable on_release : (unit -> unit) Lwt_dllist.t option; (* [None] when closed. *) - waiter : unit Single_waiter.t; (* The main [top]/[sub] function may wait here for fibers to finish. *) - cancel : Cancel.t; -} - -type hook = - | Null - | Hook : Mutex.t * (unit -> unit) Lwt_dllist.node -> hook - -let null_hook = Null - -let cancelled () = assert false - -let try_remove_hook = function - | Null -> false - | Hook (on_release_lock, n) -> - Mutex.lock on_release_lock; - Lwt_dllist.remove n; - let fn = Lwt_dllist.get n in - Lwt_dllist.set n cancelled; - Mutex.unlock on_release_lock; - fn != cancelled - -let remove_hook x = ignore (try_remove_hook x : bool) - -let dump f t = - Fmt.pf f "@[Switch %d (%d extra fibers):@,%a@]" - (t.cancel.id :> int) - t.fibers - Cancel.dump t.cancel - -let is_finished t = Cancel.is_finished t.cancel - -(* Check switch belongs to this domain (and isn't finished). It's OK if it's cancelling. *) -let check_our_domain t = - if is_finished t then invalid_arg "Switch finished!"; - if Domain.self () <> t.cancel.domain then invalid_arg "Switch accessed from wrong domain!" - -(* Check isn't cancelled (or finished). *) -let check t = - if is_finished t then invalid_arg "Switch finished!"; - Cancel.check t.cancel - -let get_error t = - Cancel.get_error t.cancel - -let combine_exn ex = function - | None -> ex - | Some ex1 -> Exn.combine ex1 ex - -(* Note: raises if [t] is finished or called from wrong domain. *) -let fail ?(bt=Exn.empty_backtrace) t ex = - check_our_domain t; - t.exs <- Some (combine_exn (ex, bt) t.exs); - try - Cancel.cancel t.cancel ex - with ex -> - let bt = Printexc.get_raw_backtrace () in - t.exs <- Some (combine_exn (ex, bt) t.exs) - -let inc_fibers t = - check t; - t.fibers <- t.fibers + 1 - -let dec_fibers t = - t.fibers <- t.fibers - 1; - if t.daemon_fibers > 0 && t.fibers = t.daemon_fibers then - Cancel.cancel t.cancel Exit; - if t.fibers = 0 then - Single_waiter.wake_if_sleeping t.waiter - -let with_op t fn = - inc_fibers t; - Fun.protect fn - ~finally:(fun () -> dec_fibers t) - -let with_daemon t fn = - inc_fibers t; - t.daemon_fibers <- t.daemon_fibers + 1; - Fun.protect fn - ~finally:(fun () -> - t.daemon_fibers <- t.daemon_fibers - 1; - dec_fibers t - ) - -let or_raise = function - | Ok x -> x - | Error ex -> raise ex - -let rec await_idle t = - (* Wait for fibers to finish: *) - while t.fibers > 0 do - Trace.try_get t.cancel.id; - Single_waiter.await_protect t.waiter "Switch.await_idle" t.cancel.id - done; - (* Collect on_release handlers: *) - let queue = ref [] in - let enqueue n = - let fn = Lwt_dllist.get n in - Lwt_dllist.set n cancelled; - queue := fn :: !queue - in - Mutex.lock t.on_release_lock; - Option.iter (Lwt_dllist.iter_node_l enqueue) t.on_release; - t.on_release <- None; - Mutex.unlock t.on_release_lock; - (* Run on_release handlers *) - !queue |> List.iter (fun fn -> try Cancel.protect fn with ex -> fail t ex); - if t.fibers > 0 then await_idle t - -let maybe_raise_exs t = - match t.exs with - | None -> () - | Some (ex, bt) -> Printexc.raise_with_backtrace ex bt - -let create cancel = - { - fibers = 1; (* The main function counts as a fiber *) - daemon_fibers = 0; - exs = None; - waiter = Single_waiter.create (); - on_release_lock = Mutex.create (); - on_release = Some (Lwt_dllist.create ()); - cancel; - } - -let run_internal t fn = - match fn t with - | v -> - dec_fibers t; - await_idle t; - Trace.get t.cancel.id; - maybe_raise_exs t; (* Check for failure while finishing *) - (* Success. *) - v - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - (* Main function failed. - Turn the switch off to cancel any running fibers, if it's not off already. *) - dec_fibers t; - fail ~bt t ex; - await_idle t; - Trace.get t.cancel.id; - maybe_raise_exs t; - assert false - -let run ?name fn = Cancel.sub_checked ?name Switch (fun cc -> run_internal (create cc) fn) - -let run_protected ?name fn = - let ctx = Effect.perform Cancel.Get_context in - Cancel.with_cc ~ctx ~parent:ctx.cancel_context ~protected:true Switch @@ fun cancel -> - Option.iter (Trace.name cancel.id) name; - run_internal (create cancel) fn - -(* Run [fn ()] in [t]'s cancellation context. - This prevents [t] from finishing until [fn] is done, - and means that cancelling [t] will cancel [fn]. *) -let run_in t fn = - with_op t @@ fun () -> - let ctx = Effect.perform Cancel.Get_context in - let old_cc = ctx.cancel_context in - Cancel.move_fiber_to t.cancel ctx; - match fn () with - | () -> Cancel.move_fiber_to old_cc ctx; - | exception ex -> Cancel.move_fiber_to old_cc ctx; raise ex - -exception Release_error of string * exn - -let () = - Printexc.register_printer (function - | Release_error (msg, ex) -> Some (Fmt.str "@[%s@,while handling %a@]" msg Exn.pp ex) - | _ -> None - ) - -let on_release_full t fn = - Mutex.lock t.on_release_lock; - match t.on_release with - | Some handlers -> - let node = Lwt_dllist.add_r fn handlers in - Mutex.unlock t.on_release_lock; - node - | None -> - Mutex.unlock t.on_release_lock; - match Cancel.protect fn with - | () -> invalid_arg "Switch finished!" - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - Printexc.raise_with_backtrace (Release_error ("Switch finished!", ex)) bt - -let on_release t fn = - ignore (on_release_full t fn : _ Lwt_dllist.node) - -let on_release_cancellable t fn = - Hook (t.on_release_lock, on_release_full t fn) +type t = { + mutable fibers : int; (* Total, including daemon_fibers and the main function *) + mutable daemon_fibers : int; + mutable exs : (exn * Printexc.raw_backtrace) option; + on_release_lock : Mutex.t; + mutable on_release : (unit -> unit) Lwt_dllist.t option; (* [None] when closed. *) + waiter : unit Single_waiter.t; (* The main [top]/[sub] function may wait here for fibers to finish. *) + cancel : Cancel.t; +} + +type hook = + | Null + | Hook : Mutex.t * (unit -> unit) Lwt_dllist.node -> hook + +let null_hook = Null + +let cancelled () = assert false + +let try_remove_hook = function + | Null -> false + | Hook (on_release_lock, n) -> + Mutex.lock on_release_lock; + Lwt_dllist.remove n; + let fn = Lwt_dllist.get n in + Lwt_dllist.set n cancelled; + Mutex.unlock on_release_lock; + fn != cancelled + +let remove_hook x = ignore (try_remove_hook x : bool) + +let dump f t = + Fmt.pf f "@[Switch %d (%d extra fibers):@,%a@]" + (t.cancel.id :> int) + t.fibers + Cancel.dump t.cancel + +let is_finished t = Cancel.is_finished t.cancel + +(* Check switch belongs to this domain (and isn't finished). It's OK if it's cancelling. *) +let check_our_domain t = + if is_finished t then invalid_arg "Switch finished!"; + if Domain.self () <> t.cancel.domain then invalid_arg "Switch accessed from wrong domain!" + +(* Check isn't cancelled (or finished). *) +let check t = + if is_finished t then invalid_arg "Switch finished!"; + Cancel.check t.cancel + +let get_error t = + Cancel.get_error t.cancel + +let combine_exn ex = function + | None -> ex + | Some ex1 -> Exn.combine ex1 ex + +(* Note: raises if [t] is finished or called from wrong domain. *) +let fail ?(bt=Exn.empty_backtrace) t ex = + check_our_domain t; + t.exs <- Some (combine_exn (ex, bt) t.exs); + try + Cancel.cancel t.cancel ex + with ex -> + let bt = Printexc.get_raw_backtrace () in + t.exs <- Some (combine_exn (ex, bt) t.exs) + +let inc_fibers t = + check t; + t.fibers <- t.fibers + 1 + +let dec_fibers t = + t.fibers <- t.fibers - 1; + if t.daemon_fibers > 0 && t.fibers = t.daemon_fibers then + Cancel.cancel t.cancel Exit; + if t.fibers = 0 then + Single_waiter.wake_if_sleeping t.waiter + +let with_op t fn = + inc_fibers t; + Fun.protect fn + ~finally:(fun () -> dec_fibers t) + +let with_daemon t fn = + inc_fibers t; + t.daemon_fibers <- t.daemon_fibers + 1; + Fun.protect fn + ~finally:(fun () -> + t.daemon_fibers <- t.daemon_fibers - 1; + dec_fibers t + ) + +let or_raise = function + | Ok x -> x + | Error ex -> raise ex + +let rec await_idle t = + (* Wait for fibers to finish: *) + while t.fibers > 0 do + Trace.try_get t.cancel.id; + Single_waiter.await_protect t.waiter "Switch.await_idle" t.cancel.id + done; + (* Collect on_release handlers: *) + let queue = ref [] in + let enqueue n = + let fn = Lwt_dllist.get n in + Lwt_dllist.set n cancelled; + queue := fn :: !queue + in + Mutex.lock t.on_release_lock; + Option.iter (Lwt_dllist.iter_node_l enqueue) t.on_release; + t.on_release <- None; + Mutex.unlock t.on_release_lock; + (* Run on_release handlers *) + !queue |> List.iter (fun fn -> try Cancel.protect fn with ex -> fail t ex); + if t.fibers > 0 then await_idle t + +let maybe_raise_exs t = + match t.exs with + | None -> () + | Some (ex, bt) -> Printexc.raise_with_backtrace ex bt + +let create cancel = + { + fibers = 1; (* The main function counts as a fiber *) + daemon_fibers = 0; + exs = None; + waiter = Single_waiter.create (); + on_release_lock = Mutex.create (); + on_release = Some (Lwt_dllist.create ()); + cancel; + } + +let run_internal t fn = + match fn t with + | v -> + dec_fibers t; + await_idle t; + Trace.get t.cancel.id; + maybe_raise_exs t; (* Check for failure while finishing *) + (* Success. *) + v + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + (* Main function failed. + Turn the switch off to cancel any running fibers, if it's not off already. *) + dec_fibers t; + fail ~bt t ex; + await_idle t; + Trace.get t.cancel.id; + maybe_raise_exs t; + assert false + +let run ?name fn = Cancel.sub_checked ?name Switch (fun cc -> run_internal (create cc) fn) + +let run_protected ?name fn = + let ctx = Effect.perform Cancel.Get_context in + Cancel.with_cc ~ctx ~parent:ctx.cancel_context ~protected:true Switch @@ fun cancel -> + Option.iter (Trace.name cancel.id) name; + run_internal (create cancel) fn + +(* Run [fn ()] in [t]'s cancellation context. + This prevents [t] from finishing until [fn] is done, + and means that cancelling [t] will cancel [fn]. *) +let run_in t fn = + with_op t @@ fun () -> + let ctx = Effect.perform Cancel.Get_context in + let old_cc = ctx.cancel_context in + Cancel.move_fiber_to t.cancel ctx; + match fn () with + | () -> Cancel.move_fiber_to old_cc ctx; + | exception ex -> Cancel.move_fiber_to old_cc ctx; raise ex + +exception Release_error of string * exn + +let () = + Printexc.register_printer (function + | Release_error (msg, ex) -> Some (Fmt.str "@[%s@,while handling %a@]" msg Exn.pp ex) + | _ -> None + ) + +let on_release_full t fn = + Mutex.lock t.on_release_lock; + match t.on_release with + | Some handlers -> + let node = Lwt_dllist.add_r fn handlers in + Mutex.unlock t.on_release_lock; + node + | None -> + Mutex.unlock t.on_release_lock; + match Cancel.protect fn with + | () -> invalid_arg "Switch finished!" + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Release_error ("Switch finished!", ex)) bt + +let on_release t fn = + ignore (on_release_full t fn : _ Lwt_dllist.node) + +let on_release_cancellable t fn = + Hook (t.on_release_lock, on_release_full t fn) diff --git a/lib_eio/core/trace.ml b/lib_eio/core/trace.ml index d50314a36..5591fb7d8 100644 --- a/lib_eio/core/trace.ml +++ b/lib_eio/core/trace.ml @@ -1,60 +1,60 @@ -(* Copyright (C) 2014, Thomas Leonard *) - -type id = int - -let id_chunk_size = 1024 - -let next_id_chunk = Atomic.make 0 - -let next_id_key = - Domain.DLS.new_key (fun () -> Atomic.fetch_and_add next_id_chunk id_chunk_size) - -let mint_id () = - let next_id_local = Domain.DLS.get next_id_key in - let next_id_local_succ = - if ((next_id_local + 1) mod id_chunk_size) = 0 then - (* we're out of local IDs *) - Atomic.fetch_and_add next_id_chunk id_chunk_size - else - next_id_local + 1 - in - Domain.DLS.set next_id_key next_id_local_succ; - next_id_local - -module RE = Eio_runtime_events - -let add_event = Runtime_events.User.write - -let create_obj ?label id ty = - add_event RE.create_obj (id, ty); - Option.iter (fun l -> add_event RE.name (id, l)) label - -let create_cc id ty = - add_event RE.create_cc (id, ty) - -let create_fiber ~cc id = - add_event RE.create_fiber (id, cc) - -let log = add_event RE.log -let name id x = add_event RE.name (id, x) -let enter_span = add_event RE.enter_span -let exit_span = add_event RE.exit_span -let fiber = add_event RE.fiber -let suspend_domain = add_event RE.suspend_domain -let try_get = add_event RE.try_get -let get = add_event RE.get -let put = add_event RE.put -let exit_fiber = add_event RE.exit_fiber -let exit_cc = add_event RE.exit_cc -let error id ex = add_event RE.error (id, ex) -let suspend_fiber op = add_event RE.suspend_fiber op -let domain_spawn ~parent = add_event RE.domain_spawn parent - -let with_span op fn = - enter_span op; - match fn () with - | r -> exit_span (); r - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - exit_span (); - Printexc.raise_with_backtrace ex bt +(* Copyright (C) 2014, Thomas Leonard *) + +type id = int + +let id_chunk_size = 1024 + +let next_id_chunk = Atomic.make 0 + +let next_id_key = + Domain.DLS.new_key (fun () -> Atomic.fetch_and_add next_id_chunk id_chunk_size) + +let mint_id () = + let next_id_local = Domain.DLS.get next_id_key in + let next_id_local_succ = + if ((next_id_local + 1) mod id_chunk_size) = 0 then + (* we're out of local IDs *) + Atomic.fetch_and_add next_id_chunk id_chunk_size + else + next_id_local + 1 + in + Domain.DLS.set next_id_key next_id_local_succ; + next_id_local + +module RE = Eio_runtime_events + +let add_event = Runtime_events.User.write + +let create_obj ?label id ty = + add_event RE.create_obj (id, ty); + Option.iter (fun l -> add_event RE.name (id, l)) label + +let create_cc id ty = + add_event RE.create_cc (id, ty) + +let create_fiber ~cc id = + add_event RE.create_fiber (id, cc) + +let log = add_event RE.log +let name id x = add_event RE.name (id, x) +let enter_span = add_event RE.enter_span +let exit_span = add_event RE.exit_span +let fiber = add_event RE.fiber +let suspend_domain = add_event RE.suspend_domain +let try_get = add_event RE.try_get +let get = add_event RE.get +let put = add_event RE.put +let exit_fiber = add_event RE.exit_fiber +let exit_cc = add_event RE.exit_cc +let error id ex = add_event RE.error (id, ex) +let suspend_fiber op = add_event RE.suspend_fiber op +let domain_spawn ~parent = add_event RE.domain_spawn parent + +let with_span op fn = + enter_span op; + match fn () with + | r -> exit_span (); r + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + exit_span (); + Printexc.raise_with_backtrace ex bt diff --git a/lib_eio/core/trace.mli b/lib_eio/core/trace.mli index 0e1d8a727..75e3f37af 100644 --- a/lib_eio/core/trace.mli +++ b/lib_eio/core/trace.mli @@ -1,61 +1,61 @@ -(** Trace Eio events using OCaml's runtime events system. *) - -type id = private int -(** Each thread/fiber/promise is identified by a unique ID. *) - -val mint_id : unit -> id -(** [mint_id ()] is a fresh unique [id]. *) - -(** {2 Recording events} - Libraries and applications can use these functions to make the traces more useful. *) - -val log : string -> unit -(** [log msg] attaches text [msg] to the current fiber. *) - -val name : id -> string -> unit -(** [name id label] sets [label] as the name for [id]. *) - -val with_span : string -> (unit -> 'a) -> 'a -(** [with_span op fn] runs [fn ()], labelling the timespan during which it runs with [op]. *) - -val suspend_fiber : string -> unit -(** [suspend_fiber op] records that the current fiber is now suspended waiting for [op]. *) - -(** {2 Recording system events} - These are normally only called by the scheduler. *) - -val create_fiber : cc:id -> id -> unit -(** [create_fiber ~cc id] records the creation of fiber [id] in context [cc]. *) - -val create_cc : id -> Eio_runtime_events.cc_ty -> unit -(** [create_cc id ty] records the creation of cancellation context [id]. *) - -val create_obj : ?label:string -> id -> Eio_runtime_events.obj_ty -> unit -(** [create_obj id ty] records the creation of [id]. *) - -val get : id -> unit -(** [get src] records reading a promise, taking from a stream, taking a lock, etc. *) - -val try_get : id -> unit -(** [try_get src] records that the current fiber wants to get from [src] (which is not currently ready). *) - -val put : id -> unit -(** [put dst] records resolving a promise, adding to a stream, releasing a lock, etc. *) - -val fiber : id -> unit -(** [fiber id] records that [id] is now the current fiber for this domain. *) - -val suspend_domain : Runtime_events.Type.span -> unit -(** [suspend_domain] records when the event loop is stopped waiting for events from the OS. *) - -val domain_spawn : parent:id -> unit -(** [domain_spawn ~parent] records that the current domain was spawned by fiber [parent]. *) - -val exit_cc : unit -> unit -(** [exit_cc ()] records that the current CC has finished. *) - -val exit_fiber : id -> unit -(** [exit_fiber id] records that fiber [id] has finished. *) - -val error : id -> exn -> unit -(** [error id exn] records that [id] received an error. *) +(** Trace Eio events using OCaml's runtime events system. *) + +type id = private int +(** Each thread/fiber/promise is identified by a unique ID. *) + +val mint_id : unit -> id +(** [mint_id ()] is a fresh unique [id]. *) + +(** {2 Recording events} + Libraries and applications can use these functions to make the traces more useful. *) + +val log : string -> unit +(** [log msg] attaches text [msg] to the current fiber. *) + +val name : id -> string -> unit +(** [name id label] sets [label] as the name for [id]. *) + +val with_span : string -> (unit -> 'a) -> 'a +(** [with_span op fn] runs [fn ()], labelling the timespan during which it runs with [op]. *) + +val suspend_fiber : string -> unit +(** [suspend_fiber op] records that the current fiber is now suspended waiting for [op]. *) + +(** {2 Recording system events} + These are normally only called by the scheduler. *) + +val create_fiber : cc:id -> id -> unit +(** [create_fiber ~cc id] records the creation of fiber [id] in context [cc]. *) + +val create_cc : id -> Eio_runtime_events.cc_ty -> unit +(** [create_cc id ty] records the creation of cancellation context [id]. *) + +val create_obj : ?label:string -> id -> Eio_runtime_events.obj_ty -> unit +(** [create_obj id ty] records the creation of [id]. *) + +val get : id -> unit +(** [get src] records reading a promise, taking from a stream, taking a lock, etc. *) + +val try_get : id -> unit +(** [try_get src] records that the current fiber wants to get from [src] (which is not currently ready). *) + +val put : id -> unit +(** [put dst] records resolving a promise, adding to a stream, releasing a lock, etc. *) + +val fiber : id -> unit +(** [fiber id] records that [id] is now the current fiber for this domain. *) + +val suspend_domain : Runtime_events.Type.span -> unit +(** [suspend_domain] records when the event loop is stopped waiting for events from the OS. *) + +val domain_spawn : parent:id -> unit +(** [domain_spawn ~parent] records that the current domain was spawned by fiber [parent]. *) + +val exit_cc : unit -> unit +(** [exit_cc ()] records that the current CC has finished. *) + +val exit_fiber : id -> unit +(** [exit_fiber id] records that fiber [id] has finished. *) + +val error : id -> exn -> unit +(** [error id exn] records that [id] received an error. *) diff --git a/lib_eio/domain_manager.ml b/lib_eio/domain_manager.ml index f81e96e6a..4120dbb9e 100644 --- a/lib_eio/domain_manager.ml +++ b/lib_eio/domain_manager.ml @@ -1,43 +1,43 @@ -open Std - -type ty = [`Domain_mgr] -type 'a t = ([> ty] as 'a) r - -module Pi = struct - module type MGR = sig - type t - val run : t -> (cancelled:exn Promise.t -> 'a) -> 'a - val run_raw : t -> (unit -> 'a) -> 'a - end - - type (_, _, _) Resource.pi += - | Mgr : ('t, (module MGR with type t = 't), [> ty]) Resource.pi - - let mgr (type t) (module X : MGR with type t = t) = - Resource.handler [H (Mgr, (module X))] -end - -let run_raw (Resource.T (t, ops)) fn = - let module X = (val (Resource.get ops Pi.Mgr)) in - X.run_raw t fn - -let run (Resource.T (t, ops)) fn = - let module X = (val (Resource.get ops Pi.Mgr)) in - X.run t @@ fun ~cancelled -> - (* If the spawning fiber is cancelled, [cancelled] gets set to the exception. *) - try - Fiber.first - (fun () -> - match Promise.await cancelled with - | Cancel.Cancelled ex -> raise ex (* To avoid [Cancelled (Cancelled ex))] *) - | ex -> raise ex (* Shouldn't happen *) - ) - fn - with ex -> - match Promise.peek cancelled with - | Some (Cancel.Cancelled ex2 as cex) when ex == ex2 -> - (* We unwrapped the exception above to avoid [fn] seeing a double cancelled exception. - But this means that the top-level reported the original exception, - which isn't what we want. *) - raise cex - | _ -> raise ex +open Std + +type ty = [`Domain_mgr] +type 'a t = ([> ty] as 'a) r + +module Pi = struct + module type MGR = sig + type t + val run : t -> (cancelled:exn Promise.t -> 'a) -> 'a + val run_raw : t -> (unit -> 'a) -> 'a + end + + type (_, _, _) Resource.pi += + | Mgr : ('t, (module MGR with type t = 't), [> ty]) Resource.pi + + let mgr (type t) (module X : MGR with type t = t) = + Resource.handler [H (Mgr, (module X))] +end + +let run_raw (Resource.T (t, ops)) fn = + let module X = (val (Resource.get ops Pi.Mgr)) in + X.run_raw t fn + +let run (Resource.T (t, ops)) fn = + let module X = (val (Resource.get ops Pi.Mgr)) in + X.run t @@ fun ~cancelled -> + (* If the spawning fiber is cancelled, [cancelled] gets set to the exception. *) + try + Fiber.first + (fun () -> + match Promise.await cancelled with + | Cancel.Cancelled ex -> raise ex (* To avoid [Cancelled (Cancelled ex))] *) + | ex -> raise ex (* Shouldn't happen *) + ) + fn + with ex -> + match Promise.peek cancelled with + | Some (Cancel.Cancelled ex2 as cex) when ex == ex2 -> + (* We unwrapped the exception above to avoid [fn] seeing a double cancelled exception. + But this means that the top-level reported the original exception, + which isn't what we want. *) + raise cex + | _ -> raise ex diff --git a/lib_eio/domain_manager.mli b/lib_eio/domain_manager.mli index e97a2af8c..3a6bb0d85 100644 --- a/lib_eio/domain_manager.mli +++ b/lib_eio/domain_manager.mli @@ -1,37 +1,37 @@ -type ty = [`Domain_mgr] -type 'a t = ([> ty] as 'a) Resource.t - -val run : _ t -> (unit -> 'a) -> 'a -(** [run t f] runs [f ()] in a newly-created domain and returns the result. - - Other fibers in the calling domain can run in parallel with the new domain. - - Warning: [f] must only access thread-safe values from the calling domain, - but this is not enforced by the type system. - - If the calling fiber is cancelled, this is propagated to the spawned domain. *) - -val run_raw : _ t -> (unit -> 'a) -> 'a -(** [run_raw t f] is like {!run}, but does not run an event loop in the new domain, - and so cannot perform IO, fork fibers, etc. *) - -(** {2 Provider Interface} *) - -module Pi : sig - module type MGR = sig - type t - - val run : t -> (cancelled:exn Promise.t -> 'a) -> 'a - (** [run t fn] runs [fn ~cancelled] in a new domain. - - If the calling fiber is cancelled, [cancelled] becomes resolved to the {!Cancel.Cancelled} exception. - [fn] should cancel itself in this case. *) - - val run_raw : t -> (unit -> 'a) -> 'a - end - - type (_, _, _) Resource.pi += - | Mgr : ('t, (module MGR with type t = 't), [> ty]) Resource.pi - - val mgr : (module MGR with type t = 't) -> ('t, ty) Resource.handler -end +type ty = [`Domain_mgr] +type 'a t = ([> ty] as 'a) Resource.t + +val run : _ t -> (unit -> 'a) -> 'a +(** [run t f] runs [f ()] in a newly-created domain and returns the result. + + Other fibers in the calling domain can run in parallel with the new domain. + + Warning: [f] must only access thread-safe values from the calling domain, + but this is not enforced by the type system. + + If the calling fiber is cancelled, this is propagated to the spawned domain. *) + +val run_raw : _ t -> (unit -> 'a) -> 'a +(** [run_raw t f] is like {!run}, but does not run an event loop in the new domain, + and so cannot perform IO, fork fibers, etc. *) + +(** {2 Provider Interface} *) + +module Pi : sig + module type MGR = sig + type t + + val run : t -> (cancelled:exn Promise.t -> 'a) -> 'a + (** [run t fn] runs [fn ~cancelled] in a new domain. + + If the calling fiber is cancelled, [cancelled] becomes resolved to the {!Cancel.Cancelled} exception. + [fn] should cancel itself in this case. *) + + val run_raw : t -> (unit -> 'a) -> 'a + end + + type (_, _, _) Resource.pi += + | Mgr : ('t, (module MGR with type t = 't), [> ty]) Resource.pi + + val mgr : (module MGR with type t = 't) -> ('t, ty) Resource.handler +end diff --git a/lib_eio/dune b/lib_eio/dune index cadb88f8b..f3cc3661a 100644 --- a/lib_eio/dune +++ b/lib_eio/dune @@ -1,5 +1,5 @@ -(library - (name eio) - (public_name eio) - (flags (:standard -open Eio__core -open Eio__core.Private)) - (libraries eio__core cstruct lwt-dllist fmt bigstringaf optint mtime)) +(library + (name eio) + (public_name eio) + (flags (:standard -open Eio__core -open Eio__core.Private)) + (libraries eio__core cstruct lwt-dllist fmt bigstringaf optint mtime)) diff --git a/lib_eio/eio.ml b/lib_eio/eio.ml index 9f9ef328e..cf5a8b5fe 100644 --- a/lib_eio/eio.ml +++ b/lib_eio/eio.ml @@ -1,48 +1,48 @@ -include Eio__core - -module Debug = Private.Debug -let traceln = Debug.traceln - -module Std = Std -module Semaphore = Semaphore -module Mutex = Eio_mutex -module Condition = Condition -module Stream = Stream -module Lazy = Lazy -module Pool = Pool -module Executor_pool = Executor_pool -module Exn = Exn -module Resource = Resource -module Buf_read = Buf_read -module Flow = struct - include Flow - - let read_all flow = - Buf_read.(parse_exn take_all) flow ~max_size:max_int -end -module Buf_write = Buf_write -module Net = Net -module Process = Process -module Domain_manager = Domain_manager -module Time = Time -module File = File -module Fs = Fs -module Path = Path - -module Stdenv = struct - let stdin (t : ) = t#stdin - let stdout (t : ) = t#stdout - let stderr (t : ) = t#stderr - let net (t : ) = t#net - let process_mgr (t : ) = t#process_mgr - let domain_mgr (t : ) = t#domain_mgr - let clock (t : ) = t#clock - let mono_clock (t : ) = t#mono_clock - let secure_random (t: ) = t#secure_random - let fs (t : ) = t#fs - let cwd (t : ) = t#cwd - let debug (t : ) = t#debug - let backend_id (t: ) = t#backend_id -end - -exception Io = Exn.Io +include Eio__core + +module Debug = Private.Debug +let traceln = Debug.traceln + +module Std = Std +module Semaphore = Semaphore +module Mutex = Eio_mutex +module Condition = Condition +module Stream = Stream +module Lazy = Lazy +module Pool = Pool +module Executor_pool = Executor_pool +module Exn = Exn +module Resource = Resource +module Buf_read = Buf_read +module Flow = struct + include Flow + + let read_all flow = + Buf_read.(parse_exn take_all) flow ~max_size:max_int +end +module Buf_write = Buf_write +module Net = Net +module Process = Process +module Domain_manager = Domain_manager +module Time = Time +module File = File +module Fs = Fs +module Path = Path + +module Stdenv = struct + let stdin (t : ) = t#stdin + let stdout (t : ) = t#stdout + let stderr (t : ) = t#stderr + let net (t : ) = t#net + let process_mgr (t : ) = t#process_mgr + let domain_mgr (t : ) = t#domain_mgr + let clock (t : ) = t#clock + let mono_clock (t : ) = t#mono_clock + let secure_random (t: ) = t#secure_random + let fs (t : ) = t#fs + let cwd (t : ) = t#cwd + let debug (t : ) = t#debug + let backend_id (t: ) = t#backend_id +end + +exception Io = Exn.Io diff --git a/lib_eio/eio.mli b/lib_eio/eio.mli index 1d4995036..600c3b1af 100644 --- a/lib_eio/eio.mli +++ b/lib_eio/eio.mli @@ -1,286 +1,286 @@ -(** Effects based parallel IO for OCaml. - - Eio provides support for concurrency (juggling many tasks) and - parallelism (using multiple CPU cores for performance). - - It provides facilities for creating and coordinating fibers (light-weight - threads) and domains (for parallel processing), as well as interfaces for - interacting with resources provided by the operating system. - - These features must be used within an {e event loop}, - provided by an Eio {e backend}. - Applications can use {!Eio_main.run} to run a suitable loop. - - See {{:https://github.com/ocaml-multicore/eio}} for a tutorial. *) - -(** Commonly used standard features. This module is intended to be [open]ed. *) -module Std = Std - -(** {1 Fibers} *) - -(** Grouping fibers and other resources so they can be turned off together. *) -module Switch = Eio__core.Switch - -(** A fiber is a light-weight thread. *) -module Fiber = Eio__core.Fiber - -(** Cancelling fibers. *) -module Cancel = Eio__core.Cancel - -(** {1 Concurrency primitives} *) - -(** A promise is a placeholder for result that will arrive in the future. *) -module Promise = Eio__core.Promise - -(** A counting semaphore. *) -module Semaphore = Semaphore - -(** Mutual exclusion. *) -module Mutex = Eio_mutex - -(** Waiting for a condition to become true. *) -module Condition = Condition - -(** Delayed evaluation. *) -module Lazy = Lazy - -(** {1 Collections} *) - -(** A stream/queue. *) -module Stream = Stream - -(** A pool of resources. *) -module Pool = Pool - -(** {1 Multiple domains} *) - -(** Parallel computation across multiple CPU cores. *) -module Domain_manager = Domain_manager - -(** A pool of domains for executing jobs. *) -module Executor_pool = Executor_pool - -(** {1 Errors and debugging} *) - -val traceln : - ?__POS__:string * int * int * int -> - ('a, Format.formatter, unit, unit) format4 -> 'a -(** [traceln fmt] outputs a debug message (typically to stderr). - - Trace messages are printed by default and do not require logging to be configured first. - The message is printed with a newline, and is flushed automatically. - [traceln] is intended for quick debugging rather than for production code. - - Unlike most Eio operations, [traceln] will never switch to another fiber; - if the OS is not ready to accept the message then the whole domain waits. - - It is safe to call [traceln] from multiple domains at the same time. - Each line will be written atomically. - - Examples: - {[ - traceln "x = %d" x; - traceln "x = %d" x ~__POS__; (* With location information *) - ]} - @param __POS__ Display [__POS__] as the location of the [traceln] call. *) - -(** Eio exceptions. *) -module Exn = Eio__core.Exn - -exception Io of Exn.err * Exn.context - -(** Control over debugging. *) -module Debug : sig - (** Example: - {[ - open Eio.Std - - let my_traceln = { - Eio.Debug.traceln = fun ?__POS__:_ fmt -> Fmt.epr ("[custom-trace] " ^^ fmt ^^ "@.") - } - - let () = - Eio_main.run @@ fun env -> - let debug = Eio.Stdenv.debug env in - Fiber.with_binding debug#traceln my_traceln @@ fun () -> - traceln "Traced with custom function" - ]} - - This will output: - - {[ [custom-trace] Traced with custom function ]} - *) - - type traceln = Eio__core.Private.Debug.traceln = { - traceln : 'a. ?__POS__:string * int * int * int -> ('a, Format.formatter, unit, unit) format4 -> 'a; - } [@@unboxed] - (** A function that writes trace logging to some trace output. - - It must not switch fibers, as tracing must not affect scheduling. - If the system is not ready to receive the trace output, - the whole domain must block until it is. *) - - val with_trace_prefix : (Format.formatter -> unit) -> (unit -> 'a) -> 'a - (** [with_trace_prefix fmt fn] runs [fn ()] with a traceln that outputs [fmt] before each message. *) - - type t = < - traceln : traceln Fiber.key; - > - (** Fiber keys used to control debugging. Use {!Stdenv.debug} to get this. *) -end - -(** {1 Cross-platform OS API} - - The general pattern here is that each type of resource has a set of functions for using it, - plus a provider ([Pi]) module to allow defining your own implementations. - - The system resources are available from the environment argument provided by your event loop - (e.g. {!Eio_main.run}). *) - -(** Defines the base resource type. *) -module Resource = Resource - -(** {2 Byte streams} *) - -(** A flow can be used to read or write bytes. *) -module Flow : sig - include module type of Flow (** @inline *) - - (** {2 Convenience wrappers} *) - - val read_all : _ source -> string - (** [read_all src] is a convenience wrapper to read an entire flow. - - It is the same as [Buf_read.(parse_exn take_all) src ~max_size:max_int] *) -end - -(** Buffered input and parsing. *) -module Buf_read = Buf_read - -(** Buffered output and formatting. *) -module Buf_write = Buf_write - -(** {2 Networking} *) - -(** Network sockets and addresses. *) -module Net = Net - -(** {2 File-systems} *) - -(** Accessing paths on a file-system. *) -module Path = Path - -(** Operations on open files. *) -module File = File - -(** File-system types. *) -module Fs = Fs - -(** {2 Processes} *) - -(** Managing child processes. *) -module Process = Process - -(** {2 Time} *) - -(** Clocks, time, sleeping and timeouts. *) -module Time = Time - -(** {2 Main env} *) - -(** The standard environment of a process. *) -module Stdenv : sig - (** All access to the outside world comes from running the event loop, - which provides an environment (e.g. an {!Eio_unix.Stdenv.base}). - - Example: - {[ - let () = - Eio_main.run @@ fun env -> - Eio.Path.with_open_dir env#fs "/srv/www" @@ fun www -> - serve_files www - ~net:env#net - ]} - *) - - (** {1 Standard streams} - - To use these, see {!Flow}. *) - - val stdin : -> 'a - val stdout : -> 'a - val stderr : -> 'a - - (** {1 File-system access} - - To use these, see {!Path}. *) - - val cwd : -> 'a - (** [cwd t] is the current working directory of the process (this may change - over time if the process does a "chdir" operation, which is not recommended). *) - - val fs : -> 'a - (** [fs t] is the process's full access to the filesystem. - - Paths can be absolute or relative (to the current working directory). - Using relative paths with this is similar to using them with {!cwd}, - except that this will follow ".." and symlinks to other parts of the filesystem. - - [fs] is useful for handling paths passed in by the user. *) - - (** {1 Network} - - To use this, see {!Net}. - *) - - val net : -> 'a - (** [net t] gives access to the process's network namespace. *) - - (** {1 Processes } - - To use this, see {!Process}. - *) - - val process_mgr : -> 'a - (** [process_mgr t] allows you to manage child processes. *) - - (** {1 Domains (using multiple CPU cores)} - - To use this, see {!Domain_manager}. - *) - - val domain_mgr : -> 'a - (** [domain_mgr t] allows running code on other cores. *) - - (** {1 Time} - - To use this, see {!Time}. - *) - - val clock : -> 'a - (** [clock t] is the system clock (used to get the current time and date). *) - - val mono_clock : -> 'a - (** [mono_clock t] is a monotonic clock (used for measuring intervals). *) - - (** {1 Randomness} *) - - val secure_random : -> 'a - (** [secure_random t] is an infinite source of random bytes suitable for cryptographic purposes. *) - - (** {1 Debugging} *) - - val debug : as 'a; ..> -> 'a - (** [debug t] provides privileged controls for debugging. *) - - val backend_id : -> string - (** [backend_id t] provides the name of the backend being used. - - The possible values are the same as the possible values of the "EIO_BACKEND" - environment variable used by {!Eio_main.run}. *) -end - -(** {1 Provider API for OS schedulers} *) - -(** API for use by the scheduler implementation. *) -module Private = Eio__core.Private +(** Effects based parallel IO for OCaml. + + Eio provides support for concurrency (juggling many tasks) and + parallelism (using multiple CPU cores for performance). + + It provides facilities for creating and coordinating fibers (light-weight + threads) and domains (for parallel processing), as well as interfaces for + interacting with resources provided by the operating system. + + These features must be used within an {e event loop}, + provided by an Eio {e backend}. + Applications can use {!Eio_main.run} to run a suitable loop. + + See {{:https://github.com/ocaml-multicore/eio}} for a tutorial. *) + +(** Commonly used standard features. This module is intended to be [open]ed. *) +module Std = Std + +(** {1 Fibers} *) + +(** Grouping fibers and other resources so they can be turned off together. *) +module Switch = Eio__core.Switch + +(** A fiber is a light-weight thread. *) +module Fiber = Eio__core.Fiber + +(** Cancelling fibers. *) +module Cancel = Eio__core.Cancel + +(** {1 Concurrency primitives} *) + +(** A promise is a placeholder for result that will arrive in the future. *) +module Promise = Eio__core.Promise + +(** A counting semaphore. *) +module Semaphore = Semaphore + +(** Mutual exclusion. *) +module Mutex = Eio_mutex + +(** Waiting for a condition to become true. *) +module Condition = Condition + +(** Delayed evaluation. *) +module Lazy = Lazy + +(** {1 Collections} *) + +(** A stream/queue. *) +module Stream = Stream + +(** A pool of resources. *) +module Pool = Pool + +(** {1 Multiple domains} *) + +(** Parallel computation across multiple CPU cores. *) +module Domain_manager = Domain_manager + +(** A pool of domains for executing jobs. *) +module Executor_pool = Executor_pool + +(** {1 Errors and debugging} *) + +val traceln : + ?__POS__:string * int * int * int -> + ('a, Format.formatter, unit, unit) format4 -> 'a +(** [traceln fmt] outputs a debug message (typically to stderr). + + Trace messages are printed by default and do not require logging to be configured first. + The message is printed with a newline, and is flushed automatically. + [traceln] is intended for quick debugging rather than for production code. + + Unlike most Eio operations, [traceln] will never switch to another fiber; + if the OS is not ready to accept the message then the whole domain waits. + + It is safe to call [traceln] from multiple domains at the same time. + Each line will be written atomically. + + Examples: + {[ + traceln "x = %d" x; + traceln "x = %d" x ~__POS__; (* With location information *) + ]} + @param __POS__ Display [__POS__] as the location of the [traceln] call. *) + +(** Eio exceptions. *) +module Exn = Eio__core.Exn + +exception Io of Exn.err * Exn.context + +(** Control over debugging. *) +module Debug : sig + (** Example: + {[ + open Eio.Std + + let my_traceln = { + Eio.Debug.traceln = fun ?__POS__:_ fmt -> Fmt.epr ("[custom-trace] " ^^ fmt ^^ "@.") + } + + let () = + Eio_main.run @@ fun env -> + let debug = Eio.Stdenv.debug env in + Fiber.with_binding debug#traceln my_traceln @@ fun () -> + traceln "Traced with custom function" + ]} + + This will output: + + {[ [custom-trace] Traced with custom function ]} + *) + + type traceln = Eio__core.Private.Debug.traceln = { + traceln : 'a. ?__POS__:string * int * int * int -> ('a, Format.formatter, unit, unit) format4 -> 'a; + } [@@unboxed] + (** A function that writes trace logging to some trace output. + + It must not switch fibers, as tracing must not affect scheduling. + If the system is not ready to receive the trace output, + the whole domain must block until it is. *) + + val with_trace_prefix : (Format.formatter -> unit) -> (unit -> 'a) -> 'a + (** [with_trace_prefix fmt fn] runs [fn ()] with a traceln that outputs [fmt] before each message. *) + + type t = < + traceln : traceln Fiber.key; + > + (** Fiber keys used to control debugging. Use {!Stdenv.debug} to get this. *) +end + +(** {1 Cross-platform OS API} + + The general pattern here is that each type of resource has a set of functions for using it, + plus a provider ([Pi]) module to allow defining your own implementations. + + The system resources are available from the environment argument provided by your event loop + (e.g. {!Eio_main.run}). *) + +(** Defines the base resource type. *) +module Resource = Resource + +(** {2 Byte streams} *) + +(** A flow can be used to read or write bytes. *) +module Flow : sig + include module type of Flow (** @inline *) + + (** {2 Convenience wrappers} *) + + val read_all : _ source -> string + (** [read_all src] is a convenience wrapper to read an entire flow. + + It is the same as [Buf_read.(parse_exn take_all) src ~max_size:max_int] *) +end + +(** Buffered input and parsing. *) +module Buf_read = Buf_read + +(** Buffered output and formatting. *) +module Buf_write = Buf_write + +(** {2 Networking} *) + +(** Network sockets and addresses. *) +module Net = Net + +(** {2 File-systems} *) + +(** Accessing paths on a file-system. *) +module Path = Path + +(** Operations on open files. *) +module File = File + +(** File-system types. *) +module Fs = Fs + +(** {2 Processes} *) + +(** Managing child processes. *) +module Process = Process + +(** {2 Time} *) + +(** Clocks, time, sleeping and timeouts. *) +module Time = Time + +(** {2 Main env} *) + +(** The standard environment of a process. *) +module Stdenv : sig + (** All access to the outside world comes from running the event loop, + which provides an environment (e.g. an {!Eio_unix.Stdenv.base}). + + Example: + {[ + let () = + Eio_main.run @@ fun env -> + Eio.Path.with_open_dir env#fs "/srv/www" @@ fun www -> + serve_files www + ~net:env#net + ]} + *) + + (** {1 Standard streams} + + To use these, see {!Flow}. *) + + val stdin : -> 'a + val stdout : -> 'a + val stderr : -> 'a + + (** {1 File-system access} + + To use these, see {!Path}. *) + + val cwd : -> 'a + (** [cwd t] is the current working directory of the process (this may change + over time if the process does a "chdir" operation, which is not recommended). *) + + val fs : -> 'a + (** [fs t] is the process's full access to the filesystem. + + Paths can be absolute or relative (to the current working directory). + Using relative paths with this is similar to using them with {!cwd}, + except that this will follow ".." and symlinks to other parts of the filesystem. + + [fs] is useful for handling paths passed in by the user. *) + + (** {1 Network} + + To use this, see {!Net}. + *) + + val net : -> 'a + (** [net t] gives access to the process's network namespace. *) + + (** {1 Processes } + + To use this, see {!Process}. + *) + + val process_mgr : -> 'a + (** [process_mgr t] allows you to manage child processes. *) + + (** {1 Domains (using multiple CPU cores)} + + To use this, see {!Domain_manager}. + *) + + val domain_mgr : -> 'a + (** [domain_mgr t] allows running code on other cores. *) + + (** {1 Time} + + To use this, see {!Time}. + *) + + val clock : -> 'a + (** [clock t] is the system clock (used to get the current time and date). *) + + val mono_clock : -> 'a + (** [mono_clock t] is a monotonic clock (used for measuring intervals). *) + + (** {1 Randomness} *) + + val secure_random : -> 'a + (** [secure_random t] is an infinite source of random bytes suitable for cryptographic purposes. *) + + (** {1 Debugging} *) + + val debug : as 'a; ..> -> 'a + (** [debug t] provides privileged controls for debugging. *) + + val backend_id : -> string + (** [backend_id t] provides the name of the backend being used. + + The possible values are the same as the possible values of the "EIO_BACKEND" + environment variable used by {!Eio_main.run}. *) +end + +(** {1 Provider API for OS schedulers} *) + +(** API for use by the scheduler implementation. *) +module Private = Eio__core.Private diff --git a/lib_eio/eio_mutex.ml b/lib_eio/eio_mutex.ml index 42717e5a5..09f91592b 100644 --- a/lib_eio/eio_mutex.ml +++ b/lib_eio/eio_mutex.ml @@ -1,121 +1,121 @@ -type state = - | Unlocked (* can be locked *) - | Locked (* is locked; threads may be waiting *) - | Poisoned of exn (* disabled due to exception in critical section *) - -exception Poisoned of exn - -type t = { - id : Trace.id; - mutex : Mutex.t; - mutable state : state; (* Owned by [t.mutex] *) - waiters : [`Take | `Error of exn] Waiters.t; (* Owned by [t.mutex] *) -} -(* Invariant: t.state <> Locked -> is_empty t.waiters *) - -(* When [t.state = Unlocked], [t] owns the user resource that [t] protects. - [mutex t R] means [t] is a share of a reference to a mutex with an invariant R. - [locked t] means the holder has the ability to unlock [t]. *) - -(* {R} t = create () {mutex t R} *) -let create () = - let id = Trace.mint_id () in - Trace.create_obj id Mutex; - { - id; - mutex = Mutex.create (); - state = Unlocked; (* Takes ownership of R *) - waiters = Waiters.create (); - } - -(* {mutex t R * locked t * R} unlock t {mutex t R} - If [t] is in an invalid state, it raises an exception and nothing changes. *) -let unlock t = - Mutex.lock t.mutex; - (* We now have ownership of [t.state] and [t.waiters]. *) - Trace.put t.id; - match t.state with - | Unlocked -> - Mutex.unlock t.mutex; - let ex = Sys_error "Eio.Mutex.unlock: already unlocked!" in - t.state <- Poisoned ex; - raise ex - | Locked -> - begin match Waiters.wake_one t.waiters `Take with - | `Ok -> () (* We transferred [locked t * R] to a waiter; [t] remains [Locked]. *) - | `Queue_empty -> t.state <- Unlocked (* The state now owns R. *) - end; - Mutex.unlock t.mutex - | Poisoned ex -> - Mutex.unlock t.mutex; - raise (Poisoned ex) - -(* {mutex t R} lock t {mutex t R * locked t * R} *) -let lock t = - Mutex.lock t.mutex; - match t.state with - | Locked -> - Trace.try_get t.id; - begin match Waiters.await ~mutex:(Some t.mutex) "Mutex.lock" t.waiters with - | `Error ex -> - Trace.get t.id; - raise ex (* Poisoned; stop waiting *) - | `Take -> - (* The unlocker didn't change the state, so it's still Locked, as required. - {locked t * R} *) - Trace.get t.id - end - | Unlocked -> - Trace.get t.id; - t.state <- Locked; (* We transfer R from the state to our caller. *) - (* {locked t * R} *) - Mutex.unlock t.mutex - | Poisoned ex -> - Mutex.unlock t.mutex; - raise (Poisoned ex) - -(* {mutex t R} v = try_lock t { mutex t R * if v then locked t * R else [] } *) -let try_lock t = - Mutex.lock t.mutex; - match t.state with - | Locked -> - Trace.try_get t.id; - Mutex.unlock t.mutex; - false - | Unlocked -> - Trace.get t.id; - t.state <- Locked; (* We transfer R from the state to our caller. *) - Mutex.unlock t.mutex; - (* {locked t * R} *) - true - | Poisoned ex -> - Mutex.unlock t.mutex; - raise (Poisoned ex) - -(* {mutex t R * locked t} poison t ex {mutex t R} *) -let poison t ex = - Mutex.lock t.mutex; - t.state <- Poisoned ex; - Waiters.wake_all t.waiters (`Error (Poisoned ex)); - Mutex.unlock t.mutex - -(* {locked t * R} fn () {locked t * R} -> - {mutex t R} use_ro t fn {mutex t R} *) -let use_ro t fn = - lock t; - (* {mutex t R * locked t * R} *) - match fn () with - | x -> unlock t; x - | exception ex -> unlock t; raise ex - -(* {locked t * R} v = match fn () with _ -> true | exception _ -> false {locked t * if v then R else []} -> - {mutex t R} use_rw ~protect t fn {mutex t R} *) -let use_rw ~protect t fn = - lock t; - (* {mutex t R * locked t * R} *) - match if protect then Cancel.protect fn else fn () with - | x -> unlock t; x - | exception ex -> - (* {mutex t R * locked t} *) - poison t ex; - raise ex +type state = + | Unlocked (* can be locked *) + | Locked (* is locked; threads may be waiting *) + | Poisoned of exn (* disabled due to exception in critical section *) + +exception Poisoned of exn + +type t = { + id : Trace.id; + mutex : Mutex.t; + mutable state : state; (* Owned by [t.mutex] *) + waiters : [`Take | `Error of exn] Waiters.t; (* Owned by [t.mutex] *) +} +(* Invariant: t.state <> Locked -> is_empty t.waiters *) + +(* When [t.state = Unlocked], [t] owns the user resource that [t] protects. + [mutex t R] means [t] is a share of a reference to a mutex with an invariant R. + [locked t] means the holder has the ability to unlock [t]. *) + +(* {R} t = create () {mutex t R} *) +let create () = + let id = Trace.mint_id () in + Trace.create_obj id Mutex; + { + id; + mutex = Mutex.create (); + state = Unlocked; (* Takes ownership of R *) + waiters = Waiters.create (); + } + +(* {mutex t R * locked t * R} unlock t {mutex t R} + If [t] is in an invalid state, it raises an exception and nothing changes. *) +let unlock t = + Mutex.lock t.mutex; + (* We now have ownership of [t.state] and [t.waiters]. *) + Trace.put t.id; + match t.state with + | Unlocked -> + Mutex.unlock t.mutex; + let ex = Sys_error "Eio.Mutex.unlock: already unlocked!" in + t.state <- Poisoned ex; + raise ex + | Locked -> + begin match Waiters.wake_one t.waiters `Take with + | `Ok -> () (* We transferred [locked t * R] to a waiter; [t] remains [Locked]. *) + | `Queue_empty -> t.state <- Unlocked (* The state now owns R. *) + end; + Mutex.unlock t.mutex + | Poisoned ex -> + Mutex.unlock t.mutex; + raise (Poisoned ex) + +(* {mutex t R} lock t {mutex t R * locked t * R} *) +let lock t = + Mutex.lock t.mutex; + match t.state with + | Locked -> + Trace.try_get t.id; + begin match Waiters.await ~mutex:(Some t.mutex) "Mutex.lock" t.waiters with + | `Error ex -> + Trace.get t.id; + raise ex (* Poisoned; stop waiting *) + | `Take -> + (* The unlocker didn't change the state, so it's still Locked, as required. + {locked t * R} *) + Trace.get t.id + end + | Unlocked -> + Trace.get t.id; + t.state <- Locked; (* We transfer R from the state to our caller. *) + (* {locked t * R} *) + Mutex.unlock t.mutex + | Poisoned ex -> + Mutex.unlock t.mutex; + raise (Poisoned ex) + +(* {mutex t R} v = try_lock t { mutex t R * if v then locked t * R else [] } *) +let try_lock t = + Mutex.lock t.mutex; + match t.state with + | Locked -> + Trace.try_get t.id; + Mutex.unlock t.mutex; + false + | Unlocked -> + Trace.get t.id; + t.state <- Locked; (* We transfer R from the state to our caller. *) + Mutex.unlock t.mutex; + (* {locked t * R} *) + true + | Poisoned ex -> + Mutex.unlock t.mutex; + raise (Poisoned ex) + +(* {mutex t R * locked t} poison t ex {mutex t R} *) +let poison t ex = + Mutex.lock t.mutex; + t.state <- Poisoned ex; + Waiters.wake_all t.waiters (`Error (Poisoned ex)); + Mutex.unlock t.mutex + +(* {locked t * R} fn () {locked t * R} -> + {mutex t R} use_ro t fn {mutex t R} *) +let use_ro t fn = + lock t; + (* {mutex t R * locked t * R} *) + match fn () with + | x -> unlock t; x + | exception ex -> unlock t; raise ex + +(* {locked t * R} v = match fn () with _ -> true | exception _ -> false {locked t * if v then R else []} -> + {mutex t R} use_rw ~protect t fn {mutex t R} *) +let use_rw ~protect t fn = + lock t; + (* {mutex t R * locked t * R} *) + match if protect then Cancel.protect fn else fn () with + | x -> unlock t; x + | exception ex -> + (* {mutex t R * locked t} *) + poison t ex; + raise ex diff --git a/lib_eio/eio_mutex.mli b/lib_eio/eio_mutex.mli index 6ce232bcf..1616f314e 100644 --- a/lib_eio/eio_mutex.mli +++ b/lib_eio/eio_mutex.mli @@ -1,63 +1,63 @@ -(** A mutex can be used to ensure that only one piece of code can access a shared resource at one time. - - Unlike {!Stdlib.Mutex}, which blocks the whole domain while waiting to take the mutex, - this module allows other Eio fibers to run while waiting. - You should use this module if your critical section may perform blocking operations, - while [Stdlib.Mutex] may be more efficient if the lock is held only briefly and - the critial section does not switch fibers. - - Note that mutexes are often unnecessary for code running in a single domain, as - the scheduler will only switch to another fiber if you perform an operation that - can block. - - @canonical Eio.Mutex *) - -type t -(** The type for a concurrency-friendly mutex. *) - -exception Poisoned of exn -(** Raised if you attempt to use a mutex that has been disabled. *) - -val create : unit -> t -(** [create ()] creates an initially unlocked mutex. *) - -val use_rw : protect:bool -> t -> (unit -> 'a) -> 'a -(** [use_rw ~protect t fn] waits for the mutex to be free and then executes [fn ()] while holding the mutex locked. - [fn] may mutate the resource protected by the mutex, - but must ensure the resource is in a consistent state before returning. - If [fn] raises an exception, the mutex is disabled and cannot be used again. - @param protect If [true], uses {!Cancel.protect} to prevent the critical section from being cancelled. - Cancellation is not prevented while waiting to take the lock. *) - -val use_ro : t -> (unit -> 'a) -> 'a -(** [use_ro t fn] is like [use_rw ~protect:false], - but if [fn] raises an exception it unlocks the mutex instead of disabling it. - Use this if you only need read-only access to the mutex's resource and so - know that it will be in a consistent state even if an exception is raised. - - Note: a mutex still only allows one fiber to have the mutex locked at a time, - even if all operations are "read-only". *) - -(** {2 Low-level API} - - Care must be taken when locking a mutex manually. It is easy to forget to unlock it in some cases, - which will result in deadlock the next time a fiber tries to use it. - In particular, you need to consider: - - - What happens if your critical section raises an exception. - - What happens if your fiber is cancelled while in its critical section. - *) - -val lock : t -> unit -(** Lock the given mutex. Only one fiber can have the mutex locked at any time. - A fiber that attempts to lock a mutex already locked by another fiber - will suspend until the other fiber unlocks the mutex. - If no other fiber has the lock, this returns immediately without switching fibers. *) - -val unlock : t -> unit -(** [unlock t] unlocks the mutex. - @raises Sys_error if the mutex is unlocked. *) - -val try_lock : t -> bool -(** Same as {!lock}, but does not suspend the calling thread if the mutex is already locked: - just return [false] immediately in that case. If the mutex is unlocked, lock it and return [true]. *) +(** A mutex can be used to ensure that only one piece of code can access a shared resource at one time. + + Unlike {!Stdlib.Mutex}, which blocks the whole domain while waiting to take the mutex, + this module allows other Eio fibers to run while waiting. + You should use this module if your critical section may perform blocking operations, + while [Stdlib.Mutex] may be more efficient if the lock is held only briefly and + the critial section does not switch fibers. + + Note that mutexes are often unnecessary for code running in a single domain, as + the scheduler will only switch to another fiber if you perform an operation that + can block. + + @canonical Eio.Mutex *) + +type t +(** The type for a concurrency-friendly mutex. *) + +exception Poisoned of exn +(** Raised if you attempt to use a mutex that has been disabled. *) + +val create : unit -> t +(** [create ()] creates an initially unlocked mutex. *) + +val use_rw : protect:bool -> t -> (unit -> 'a) -> 'a +(** [use_rw ~protect t fn] waits for the mutex to be free and then executes [fn ()] while holding the mutex locked. + [fn] may mutate the resource protected by the mutex, + but must ensure the resource is in a consistent state before returning. + If [fn] raises an exception, the mutex is disabled and cannot be used again. + @param protect If [true], uses {!Cancel.protect} to prevent the critical section from being cancelled. + Cancellation is not prevented while waiting to take the lock. *) + +val use_ro : t -> (unit -> 'a) -> 'a +(** [use_ro t fn] is like [use_rw ~protect:false], + but if [fn] raises an exception it unlocks the mutex instead of disabling it. + Use this if you only need read-only access to the mutex's resource and so + know that it will be in a consistent state even if an exception is raised. + + Note: a mutex still only allows one fiber to have the mutex locked at a time, + even if all operations are "read-only". *) + +(** {2 Low-level API} + + Care must be taken when locking a mutex manually. It is easy to forget to unlock it in some cases, + which will result in deadlock the next time a fiber tries to use it. + In particular, you need to consider: + + - What happens if your critical section raises an exception. + - What happens if your fiber is cancelled while in its critical section. + *) + +val lock : t -> unit +(** Lock the given mutex. Only one fiber can have the mutex locked at any time. + A fiber that attempts to lock a mutex already locked by another fiber + will suspend until the other fiber unlocks the mutex. + If no other fiber has the lock, this returns immediately without switching fibers. *) + +val unlock : t -> unit +(** [unlock t] unlocks the mutex. + @raises Sys_error if the mutex is unlocked. *) + +val try_lock : t -> bool +(** Same as {!lock}, but does not suspend the calling thread if the mutex is already locked: + just return [false] immediately in that case. If the mutex is unlocked, lock it and return [true]. *) diff --git a/lib_eio/executor_pool.ml b/lib_eio/executor_pool.ml index 5ae853178..11606e781 100644 --- a/lib_eio/executor_pool.ml +++ b/lib_eio/executor_pool.ml @@ -1,74 +1,74 @@ -type job = Pack : { - fn : unit -> 'a; - w : ('a, exn) Result.t Promise.u; - weight : int; - } -> job - -type t = { - queue : job Sync.t; -} - -let max_capacity = 1_000_000 - -let max_capacity_f = float max_capacity - -(* This function is the core of executor_pool.ml. - Each worker runs in its own domain, - taking jobs from [queue] whenever it has spare capacity. *) -let run_worker { queue } = - Switch.run ~name:"run_worker" @@ fun sw -> - let capacity = ref 0 in - let condition = Condition.create () in - (* The main worker loop. *) - let rec loop () = - while !capacity >= max_capacity do Condition.await_no_mutex condition done; - match Sync.take queue with - | Error `Closed -> `Stop_daemon - | Ok (Pack { fn; w; weight }) -> - capacity := !capacity + weight; - Option.iter (Promise.resolve_error w) (Switch.get_error sw); - Fiber.fork ~sw (fun () -> - Promise.resolve w (try Ok (fn ()) with ex -> Error ex); - capacity := !capacity - weight; - Condition.broadcast condition - ); - (* Give a chance to other domains to start waiting on [queue] - before the current thread blocks on [Sync.take] again. *) - Fiber.yield (); - (loop [@tailcall]) () - in - loop () - -let create ~sw ~domain_count domain_mgr = - let queue = Sync.create () in - let t = { queue } in - Switch.on_release sw (fun () -> Sync.close queue); - for _ = 1 to domain_count do - (* Workers run as daemons to not hold the user's switch from completing. - It's up to the user to hold the switch open (and thus, the executor pool) - by blocking on the jobs issued to the pool. *) - Fiber.fork_daemon ~sw (fun () -> - Domain_manager.run domain_mgr (fun () -> - run_worker t)) - done; - t - -let enqueue { queue } ~weight fn = - if not (weight >= 0. && weight <= 1.) (* Handles NaN *) - then Fmt.invalid_arg "Executor_pool: weight %g not >= 0.0 && <= 1.0" weight - else ( - let weight = Float.to_int (weight *. max_capacity_f) in - let p, w = Promise.create () in - Sync.put queue (Pack { fn; w; weight }); - p - ) - -let submit t ~weight fn = - enqueue t ~weight fn |> Promise.await - -let submit_exn t ~weight fn = - enqueue t ~weight fn |> Promise.await_exn - -let submit_fork ~sw t ~weight fn = - (* [enqueue] blocks until the job is accepted, so we have to fork here. *) - Fiber.fork_promise ~sw (fun () -> submit_exn t ~weight fn) +type job = Pack : { + fn : unit -> 'a; + w : ('a, exn) Result.t Promise.u; + weight : int; + } -> job + +type t = { + queue : job Sync.t; +} + +let max_capacity = 1_000_000 + +let max_capacity_f = float max_capacity + +(* This function is the core of executor_pool.ml. + Each worker runs in its own domain, + taking jobs from [queue] whenever it has spare capacity. *) +let run_worker { queue } = + Switch.run ~name:"run_worker" @@ fun sw -> + let capacity = ref 0 in + let condition = Condition.create () in + (* The main worker loop. *) + let rec loop () = + while !capacity >= max_capacity do Condition.await_no_mutex condition done; + match Sync.take queue with + | Error `Closed -> `Stop_daemon + | Ok (Pack { fn; w; weight }) -> + capacity := !capacity + weight; + Option.iter (Promise.resolve_error w) (Switch.get_error sw); + Fiber.fork ~sw (fun () -> + Promise.resolve w (try Ok (fn ()) with ex -> Error ex); + capacity := !capacity - weight; + Condition.broadcast condition + ); + (* Give a chance to other domains to start waiting on [queue] + before the current thread blocks on [Sync.take] again. *) + Fiber.yield (); + (loop [@tailcall]) () + in + loop () + +let create ~sw ~domain_count domain_mgr = + let queue = Sync.create () in + let t = { queue } in + Switch.on_release sw (fun () -> Sync.close queue); + for _ = 1 to domain_count do + (* Workers run as daemons to not hold the user's switch from completing. + It's up to the user to hold the switch open (and thus, the executor pool) + by blocking on the jobs issued to the pool. *) + Fiber.fork_daemon ~sw (fun () -> + Domain_manager.run domain_mgr (fun () -> + run_worker t)) + done; + t + +let enqueue { queue } ~weight fn = + if not (weight >= 0. && weight <= 1.) (* Handles NaN *) + then Fmt.invalid_arg "Executor_pool: weight %g not >= 0.0 && <= 1.0" weight + else ( + let weight = Float.to_int (weight *. max_capacity_f) in + let p, w = Promise.create () in + Sync.put queue (Pack { fn; w; weight }); + p + ) + +let submit t ~weight fn = + enqueue t ~weight fn |> Promise.await + +let submit_exn t ~weight fn = + enqueue t ~weight fn |> Promise.await_exn + +let submit_fork ~sw t ~weight fn = + (* [enqueue] blocks until the job is accepted, so we have to fork here. *) + Fiber.fork_promise ~sw (fun () -> submit_exn t ~weight fn) diff --git a/lib_eio/executor_pool.mli b/lib_eio/executor_pool.mli index 8141e5941..46179c82f 100644 --- a/lib_eio/executor_pool.mli +++ b/lib_eio/executor_pool.mli @@ -1,59 +1,59 @@ -(** An executor pool distributes jobs (functions to execute) among a pool of domain workers (threads). - - Domains are reused and can execute multiple jobs concurrently. - Jobs are queued up if they cannot be started immediately due to all workers being busy. - - [Eio.Executor_pool] is the recommended way of leveraging OCaml 5's multicore capabilities. - It is built on top of the low level [Eio.Domain_manager]. - - Usually you will only want one pool for an entire application, - so the pool is typically created when the application starts: - - {[ - let () = - Eio_main.run @@ fun env -> - Switch.run @@ fun sw -> - let pool = - Eio.Executor_pool.create - ~sw (Eio.Stdenv.domain_mgr env) - ~domain_count:4 - in - main ~pool - ]} - - The pool starts its domain workers (threads) immediately upon creation. -*) - -type t -(** An executor pool. *) - -val create : - sw:Switch.t -> - domain_count:int -> - _ Domain_manager.t -> - t -(** [create ~sw ~domain_count dm] creates a new executor pool. - - The executor pool will not block switch [sw] from completing; - when the switch finishes, all domain workers and running jobs are cancelled. - - @param domain_count The number of domain workers to create. - The total number of domains should not exceed {!Domain.recommended_domain_count} or the number of cores on your system. - 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. -*) - -val submit : t -> weight:float -> (unit -> 'a) -> ('a, exn) result -(** [submit t ~weight fn] runs [fn ()] using this executor pool. - - The job is added to the back of the queue. - - @param weight This value represents the anticipated proportion of a CPU core used by the job. - 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]. - Each domain worker starts new jobs until the total [~weight] of its running jobs reaches 1.0 - *) - -val submit_exn : t -> weight:float -> (unit -> 'a) -> 'a -(** Same as {!submit} but raises if the job fails. *) - -val submit_fork : sw:Switch.t -> t -> weight:float -> (unit -> 'a) -> 'a Promise.or_exn -(** Same as {!submit} but returns immediately, without blocking. *) +(** An executor pool distributes jobs (functions to execute) among a pool of domain workers (threads). + + Domains are reused and can execute multiple jobs concurrently. + Jobs are queued up if they cannot be started immediately due to all workers being busy. + + [Eio.Executor_pool] is the recommended way of leveraging OCaml 5's multicore capabilities. + It is built on top of the low level [Eio.Domain_manager]. + + Usually you will only want one pool for an entire application, + so the pool is typically created when the application starts: + + {[ + let () = + Eio_main.run @@ fun env -> + Switch.run @@ fun sw -> + let pool = + Eio.Executor_pool.create + ~sw (Eio.Stdenv.domain_mgr env) + ~domain_count:4 + in + main ~pool + ]} + + The pool starts its domain workers (threads) immediately upon creation. +*) + +type t +(** An executor pool. *) + +val create : + sw:Switch.t -> + domain_count:int -> + _ Domain_manager.t -> + t +(** [create ~sw ~domain_count dm] creates a new executor pool. + + The executor pool will not block switch [sw] from completing; + when the switch finishes, all domain workers and running jobs are cancelled. + + @param domain_count The number of domain workers to create. + The total number of domains should not exceed {!Domain.recommended_domain_count} or the number of cores on your system. + 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. +*) + +val submit : t -> weight:float -> (unit -> 'a) -> ('a, exn) result +(** [submit t ~weight fn] runs [fn ()] using this executor pool. + + The job is added to the back of the queue. + + @param weight This value represents the anticipated proportion of a CPU core used by the job. + 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]. + Each domain worker starts new jobs until the total [~weight] of its running jobs reaches 1.0 + *) + +val submit_exn : t -> weight:float -> (unit -> 'a) -> 'a +(** Same as {!submit} but raises if the job fails. *) + +val submit_fork : sw:Switch.t -> t -> weight:float -> (unit -> 'a) -> 'a Promise.or_exn +(** Same as {!submit} but returns immediately, without blocking. *) diff --git a/lib_eio/file.ml b/lib_eio/file.ml index 1b8e34179..03a4e3e6e 100644 --- a/lib_eio/file.ml +++ b/lib_eio/file.ml @@ -1,157 +1,157 @@ -open Std - -module Unix_perm = struct - type t = int -end - -module Stat = struct - type kind = [ - | `Unknown - | `Fifo - | `Character_special - | `Directory - | `Block_device - | `Regular_file - | `Symbolic_link - | `Socket - ] - - let pp_kind ppf = function - | `Unknown -> Fmt.string ppf "unknown" - | `Fifo -> Fmt.string ppf "fifo" - | `Character_special -> Fmt.string ppf "character special file" - | `Directory -> Fmt.string ppf "directory" - | `Block_device -> Fmt.string ppf "block device" - | `Regular_file -> Fmt.string ppf "regular file" - | `Symbolic_link -> Fmt.string ppf "symbolic link" - | `Socket -> Fmt.string ppf "socket" - - type t = { - dev : Int64.t; - ino : Int64.t; - kind : kind; - perm : Unix_perm.t; - nlink : Int64.t; - uid : Int64.t; - gid : Int64.t; - rdev : Int64.t; - size : Optint.Int63.t; - atime : float; - mtime : float; - ctime : float; - } - - let pp ppf t = - Fmt.record [ - Fmt.field "dev" (fun t -> t.dev) Fmt.int64; - Fmt.field "ino" (fun t -> t.ino) Fmt.int64; - Fmt.field "kind" (fun t -> t.kind) pp_kind; - Fmt.field "perm" (fun t -> t.perm) (fun ppf i -> Fmt.pf ppf "0o%o" i); - Fmt.field "nlink" (fun t -> t.nlink) Fmt.int64; - Fmt.field "uid" (fun t -> t.uid) Fmt.int64; - Fmt.field "gid" (fun t -> t.gid) Fmt.int64; - Fmt.field "rdev" (fun t -> t.rdev) Fmt.int64; - Fmt.field "size" (fun t -> t.size) Optint.Int63.pp; - Fmt.field "atime" (fun t -> t.atime) Fmt.float; - Fmt.field "mtime" (fun t -> t.mtime) Fmt.float; - Fmt.field "ctime" (fun t -> t.ctime) Fmt.float; - ] ppf t -end - -type ro_ty = [`File | Flow.source_ty | Resource.close_ty] - -type 'a ro = ([> ro_ty] as 'a) r - -type rw_ty = [ro_ty | Flow.sink_ty] - -type 'a rw = ([> rw_ty] as 'a) r - -module Pi = struct - module type READ = sig - include Flow.Pi.SOURCE - - val pread : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int - val stat : t -> Stat.t - val seek : t -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t - val close : t -> unit - end - - module type WRITE = sig - include Flow.Pi.SINK - include READ with type t := t - - val pwrite : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int - val sync : t -> unit - val truncate : t -> Optint.Int63.t -> unit - end - - type (_, _, _) Resource.pi += - | Read : ('t, (module READ with type t = 't), [> ro_ty]) Resource.pi - | Write : ('t, (module WRITE with type t = 't), [> rw_ty]) Resource.pi - - let ro (type t) (module X : READ with type t = t) = - Resource.handler [ - H (Flow.Pi.Source, (module X)); - H (Read, (module X)); - H (Resource.Close, X.close); - ] - - let rw (type t) (module X : WRITE with type t = t) = - Resource.handler ( - H (Flow.Pi.Sink, (module X)) :: - H (Write, (module X)) :: - Resource.bindings (ro (module X)) - ) -end - -let stat (Resource.T (t, ops)) = - let module X = (val (Resource.get ops Pi.Read)) in - X.stat t - -let size t = (stat t).size - -let pread (Resource.T (t, ops)) ~file_offset bufs = - let module X = (val (Resource.get ops Pi.Read)) in - let got = X.pread t ~file_offset bufs in - assert (got > 0 && got <= Cstruct.lenv bufs); - got - -let pread_exact (Resource.T (t, ops)) ~file_offset bufs = - let module X = (val (Resource.get ops Pi.Read)) in - let rec aux ~file_offset bufs = - if Cstruct.lenv bufs > 0 then ( - let got = X.pread t ~file_offset bufs in - let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in - aux ~file_offset (Cstruct.shiftv bufs got) - ) - in - aux ~file_offset bufs - -let pwrite_single (Resource.T (t, ops)) ~file_offset bufs = - let module X = (val (Resource.get ops Pi.Write)) in - let got = X.pwrite t ~file_offset bufs in - assert (got > 0 && got <= Cstruct.lenv bufs); - got - -let pwrite_all (Resource.T (t, ops)) ~file_offset bufs = - let module X = (val (Resource.get ops Pi.Write)) in - let rec aux ~file_offset bufs = - if Cstruct.lenv bufs > 0 then ( - let got = X.pwrite t ~file_offset bufs in - let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in - aux ~file_offset (Cstruct.shiftv bufs got) - ) - in - aux ~file_offset bufs - -let seek (Resource.T (t, ops)) off cmd = - let module X = (val (Resource.get ops Pi.Read)) in - X.seek t off cmd - -let sync (Resource.T (t, ops)) = - let module X = (val (Resource.get ops Pi.Write)) in - X.sync t - -let truncate (Resource.T (t, ops)) len = - let module X = (val (Resource.get ops Pi.Write)) in - X.truncate t len +open Std + +module Unix_perm = struct + type t = int +end + +module Stat = struct + type kind = [ + | `Unknown + | `Fifo + | `Character_special + | `Directory + | `Block_device + | `Regular_file + | `Symbolic_link + | `Socket + ] + + let pp_kind ppf = function + | `Unknown -> Fmt.string ppf "unknown" + | `Fifo -> Fmt.string ppf "fifo" + | `Character_special -> Fmt.string ppf "character special file" + | `Directory -> Fmt.string ppf "directory" + | `Block_device -> Fmt.string ppf "block device" + | `Regular_file -> Fmt.string ppf "regular file" + | `Symbolic_link -> Fmt.string ppf "symbolic link" + | `Socket -> Fmt.string ppf "socket" + + type t = { + dev : Int64.t; + ino : Int64.t; + kind : kind; + perm : Unix_perm.t; + nlink : Int64.t; + uid : Int64.t; + gid : Int64.t; + rdev : Int64.t; + size : Optint.Int63.t; + atime : float; + mtime : float; + ctime : float; + } + + let pp ppf t = + Fmt.record [ + Fmt.field "dev" (fun t -> t.dev) Fmt.int64; + Fmt.field "ino" (fun t -> t.ino) Fmt.int64; + Fmt.field "kind" (fun t -> t.kind) pp_kind; + Fmt.field "perm" (fun t -> t.perm) (fun ppf i -> Fmt.pf ppf "0o%o" i); + Fmt.field "nlink" (fun t -> t.nlink) Fmt.int64; + Fmt.field "uid" (fun t -> t.uid) Fmt.int64; + Fmt.field "gid" (fun t -> t.gid) Fmt.int64; + Fmt.field "rdev" (fun t -> t.rdev) Fmt.int64; + Fmt.field "size" (fun t -> t.size) Optint.Int63.pp; + Fmt.field "atime" (fun t -> t.atime) Fmt.float; + Fmt.field "mtime" (fun t -> t.mtime) Fmt.float; + Fmt.field "ctime" (fun t -> t.ctime) Fmt.float; + ] ppf t +end + +type ro_ty = [`File | Flow.source_ty | Resource.close_ty] + +type 'a ro = ([> ro_ty] as 'a) r + +type rw_ty = [ro_ty | Flow.sink_ty] + +type 'a rw = ([> rw_ty] as 'a) r + +module Pi = struct + module type READ = sig + include Flow.Pi.SOURCE + + val pread : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int + val stat : t -> Stat.t + val seek : t -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t + val close : t -> unit + end + + module type WRITE = sig + include Flow.Pi.SINK + include READ with type t := t + + val pwrite : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int + val sync : t -> unit + val truncate : t -> Optint.Int63.t -> unit + end + + type (_, _, _) Resource.pi += + | Read : ('t, (module READ with type t = 't), [> ro_ty]) Resource.pi + | Write : ('t, (module WRITE with type t = 't), [> rw_ty]) Resource.pi + + let ro (type t) (module X : READ with type t = t) = + Resource.handler [ + H (Flow.Pi.Source, (module X)); + H (Read, (module X)); + H (Resource.Close, X.close); + ] + + let rw (type t) (module X : WRITE with type t = t) = + Resource.handler ( + H (Flow.Pi.Sink, (module X)) :: + H (Write, (module X)) :: + Resource.bindings (ro (module X)) + ) +end + +let stat (Resource.T (t, ops)) = + let module X = (val (Resource.get ops Pi.Read)) in + X.stat t + +let size t = (stat t).size + +let pread (Resource.T (t, ops)) ~file_offset bufs = + let module X = (val (Resource.get ops Pi.Read)) in + let got = X.pread t ~file_offset bufs in + assert (got > 0 && got <= Cstruct.lenv bufs); + got + +let pread_exact (Resource.T (t, ops)) ~file_offset bufs = + let module X = (val (Resource.get ops Pi.Read)) in + let rec aux ~file_offset bufs = + if Cstruct.lenv bufs > 0 then ( + let got = X.pread t ~file_offset bufs in + let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in + aux ~file_offset (Cstruct.shiftv bufs got) + ) + in + aux ~file_offset bufs + +let pwrite_single (Resource.T (t, ops)) ~file_offset bufs = + let module X = (val (Resource.get ops Pi.Write)) in + let got = X.pwrite t ~file_offset bufs in + assert (got > 0 && got <= Cstruct.lenv bufs); + got + +let pwrite_all (Resource.T (t, ops)) ~file_offset bufs = + let module X = (val (Resource.get ops Pi.Write)) in + let rec aux ~file_offset bufs = + if Cstruct.lenv bufs > 0 then ( + let got = X.pwrite t ~file_offset bufs in + let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in + aux ~file_offset (Cstruct.shiftv bufs got) + ) + in + aux ~file_offset bufs + +let seek (Resource.T (t, ops)) off cmd = + let module X = (val (Resource.get ops Pi.Read)) in + X.seek t off cmd + +let sync (Resource.T (t, ops)) = + let module X = (val (Resource.get ops Pi.Write)) in + X.sync t + +let truncate (Resource.T (t, ops)) len = + let module X = (val (Resource.get ops Pi.Write)) in + X.truncate t len diff --git a/lib_eio/file.mli b/lib_eio/file.mli index c15c00e88..4b265f2c6 100644 --- a/lib_eio/file.mli +++ b/lib_eio/file.mli @@ -1,141 +1,141 @@ -(** Files implement the {!Flow} APIs, which can be used for reading and writing data. - This module provides additonal file-specific operations, such as seeking within a file. - - To get an open file, use the functions in the {!Path} module. *) - -open Std - -(** {2 Types} *) - -(** Traditional Unix permissions. *) -module Unix_perm : sig - type t = int - (** This is the same as {!Unix.file_perm}, but avoids a dependency on [Unix]. *) -end - -(** Portable file stats. *) -module Stat : sig - - type kind = [ - | `Unknown - | `Fifo - | `Character_special - | `Directory - | `Block_device - | `Regular_file - | `Symbolic_link - | `Socket - ] - (** Kind of file from st_mode. **) - - val pp_kind : kind Fmt.t - (** Pretty printer for {! kind}. *) - - type t = { - dev : Int64.t; (** Device containing the filesystem where the file resides. *) - ino : Int64.t; (** Inode number. *) - kind : kind; (** File type. *) - perm : Unix_perm.t; (** Permissions (mode). *) - nlink : Int64.t; (** Number of hard links. *) - uid : Int64.t; (** User ID of owner. *) - gid : Int64.t; (** Group ID of owner. *) - rdev : Int64.t; (** Device's ID (if this is a device). *) - size : Optint.Int63.t; (** Total size in bytes. *) - atime : float; (** Last access time. *) - mtime : float; (** Last modification time. *) - ctime : float; (** Creation time. *) - } - (** Like stat(2). *) - - val pp : t Fmt.t - (** Pretty printer for {! t}. *) -end - -type ro_ty = [`File | Flow.source_ty | Resource.close_ty] - -type 'a ro = ([> ro_ty] as 'a) r -(** A file opened for reading. *) - -type rw_ty = [ro_ty | Flow.sink_ty] - -type 'a rw = ([> rw_ty] as 'a) r -(** A file opened for reading and writing. *) - -(** {2 Metadata} *) - -val stat : _ ro -> Stat.t -(** [stat t] returns the {!Stat.t} record associated with [t]. *) - -val size : _ ro -> Optint.Int63.t -(** [size t] returns the size of [t]. *) - -(** {2 Reading and writing} *) - -val pread : _ ro -> file_offset:Optint.Int63.t -> Cstruct.t list -> int -(** [pread t ~file_offset bufs] performs a single read of [t] at [file_offset] into [bufs]. - - It returns the number of bytes read, which may be less than the space in [bufs], - even if more bytes are available. Use {!pread_exact} instead if you require - the buffer to be filled. - - To read at the current offset, use {!Flow.single_read} instead. *) - -val pread_exact : _ ro -> file_offset:Optint.Int63.t -> Cstruct.t list -> unit -(** [pread_exact t ~file_offset bufs] reads from [t] into [bufs] until [bufs] is full. - - @raise End_of_file if the buffer could not be filled. *) - -val pwrite_single : _ rw -> file_offset:Optint.Int63.t -> Cstruct.t list -> int -(** [pwrite_single t ~file_offset bufs] performs a single write operation, writing - data from [bufs] to location [file_offset] in [t]. - - It returns the number of bytes written, which may be less than the length of [bufs]. - In most cases, you will want to use {!pwrite_all} instead. *) - -val pwrite_all : _ rw -> file_offset:Optint.Int63.t -> Cstruct.t list -> unit -(** [pwrite_all t ~file_offset bufs] writes all the data in [bufs] to location [file_offset] in [t]. *) - -val seek : _ ro -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t -(** Set and/or get the current file position. - - Like {!Unix.lseek}. *) - -val sync : _ rw -> unit -(** Flush file buffers to disk. - - Like {!Unix.fsync}. *) - -val truncate : _ rw -> Optint.Int63.t -> unit -(** Set the length of a file. - - Like {!Unix.ftruncate}. *) - -(** {2 Provider Interface} *) - -module Pi : sig - module type READ = sig - include Flow.Pi.SOURCE - - val pread : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int - val stat : t -> Stat.t - val seek : t -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t - val close : t -> unit - end - - module type WRITE = sig - include Flow.Pi.SINK - include READ with type t := t - - val pwrite : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int - val sync : t -> unit - val truncate : t -> Optint.Int63.t -> unit - end - - type (_, _, _) Resource.pi += - | Read : ('t, (module READ with type t = 't), [> ro_ty]) Resource.pi - | Write : ('t, (module WRITE with type t = 't), [> rw_ty]) Resource.pi - - val ro : (module READ with type t = 't) -> ('t, ro_ty) Resource.handler - - val rw : (module WRITE with type t = 't) -> ('t, rw_ty) Resource.handler -end +(** Files implement the {!Flow} APIs, which can be used for reading and writing data. + This module provides additonal file-specific operations, such as seeking within a file. + + To get an open file, use the functions in the {!Path} module. *) + +open Std + +(** {2 Types} *) + +(** Traditional Unix permissions. *) +module Unix_perm : sig + type t = int + (** This is the same as {!Unix.file_perm}, but avoids a dependency on [Unix]. *) +end + +(** Portable file stats. *) +module Stat : sig + + type kind = [ + | `Unknown + | `Fifo + | `Character_special + | `Directory + | `Block_device + | `Regular_file + | `Symbolic_link + | `Socket + ] + (** Kind of file from st_mode. **) + + val pp_kind : kind Fmt.t + (** Pretty printer for {! kind}. *) + + type t = { + dev : Int64.t; (** Device containing the filesystem where the file resides. *) + ino : Int64.t; (** Inode number. *) + kind : kind; (** File type. *) + perm : Unix_perm.t; (** Permissions (mode). *) + nlink : Int64.t; (** Number of hard links. *) + uid : Int64.t; (** User ID of owner. *) + gid : Int64.t; (** Group ID of owner. *) + rdev : Int64.t; (** Device's ID (if this is a device). *) + size : Optint.Int63.t; (** Total size in bytes. *) + atime : float; (** Last access time. *) + mtime : float; (** Last modification time. *) + ctime : float; (** Creation time. *) + } + (** Like stat(2). *) + + val pp : t Fmt.t + (** Pretty printer for {! t}. *) +end + +type ro_ty = [`File | Flow.source_ty | Resource.close_ty] + +type 'a ro = ([> ro_ty] as 'a) r +(** A file opened for reading. *) + +type rw_ty = [ro_ty | Flow.sink_ty] + +type 'a rw = ([> rw_ty] as 'a) r +(** A file opened for reading and writing. *) + +(** {2 Metadata} *) + +val stat : _ ro -> Stat.t +(** [stat t] returns the {!Stat.t} record associated with [t]. *) + +val size : _ ro -> Optint.Int63.t +(** [size t] returns the size of [t]. *) + +(** {2 Reading and writing} *) + +val pread : _ ro -> file_offset:Optint.Int63.t -> Cstruct.t list -> int +(** [pread t ~file_offset bufs] performs a single read of [t] at [file_offset] into [bufs]. + + It returns the number of bytes read, which may be less than the space in [bufs], + even if more bytes are available. Use {!pread_exact} instead if you require + the buffer to be filled. + + To read at the current offset, use {!Flow.single_read} instead. *) + +val pread_exact : _ ro -> file_offset:Optint.Int63.t -> Cstruct.t list -> unit +(** [pread_exact t ~file_offset bufs] reads from [t] into [bufs] until [bufs] is full. + + @raise End_of_file if the buffer could not be filled. *) + +val pwrite_single : _ rw -> file_offset:Optint.Int63.t -> Cstruct.t list -> int +(** [pwrite_single t ~file_offset bufs] performs a single write operation, writing + data from [bufs] to location [file_offset] in [t]. + + It returns the number of bytes written, which may be less than the length of [bufs]. + In most cases, you will want to use {!pwrite_all} instead. *) + +val pwrite_all : _ rw -> file_offset:Optint.Int63.t -> Cstruct.t list -> unit +(** [pwrite_all t ~file_offset bufs] writes all the data in [bufs] to location [file_offset] in [t]. *) + +val seek : _ ro -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t +(** Set and/or get the current file position. + + Like {!Unix.lseek}. *) + +val sync : _ rw -> unit +(** Flush file buffers to disk. + + Like {!Unix.fsync}. *) + +val truncate : _ rw -> Optint.Int63.t -> unit +(** Set the length of a file. + + Like {!Unix.ftruncate}. *) + +(** {2 Provider Interface} *) + +module Pi : sig + module type READ = sig + include Flow.Pi.SOURCE + + val pread : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int + val stat : t -> Stat.t + val seek : t -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t + val close : t -> unit + end + + module type WRITE = sig + include Flow.Pi.SINK + include READ with type t := t + + val pwrite : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int + val sync : t -> unit + val truncate : t -> Optint.Int63.t -> unit + end + + type (_, _, _) Resource.pi += + | Read : ('t, (module READ with type t = 't), [> ro_ty]) Resource.pi + | Write : ('t, (module WRITE with type t = 't), [> rw_ty]) Resource.pi + + val ro : (module READ with type t = 't) -> ('t, ro_ty) Resource.handler + + val rw : (module WRITE with type t = 't) -> ('t, rw_ty) Resource.handler +end diff --git a/lib_eio/flow.ml b/lib_eio/flow.ml index d265ad7f0..faf557a9f 100644 --- a/lib_eio/flow.ml +++ b/lib_eio/flow.ml @@ -1,188 +1,188 @@ -open Std - -type shutdown_command = [ `Receive | `Send | `All ] - -type 't read_method = .. -type 't read_method += Read_source_buffer of ('t -> (Cstruct.t list -> int) -> unit) - -type source_ty = [`R | `Flow] -type 'a source = ([> source_ty] as 'a) r - -type sink_ty = [`W | `Flow] -type 'a sink = ([> sink_ty] as 'a) r - -type shutdown_ty = [`Shutdown] -type 'a shutdown = ([> shutdown_ty] as 'a) r - -module Pi = struct - module type SOURCE = sig - type t - val read_methods : t read_method list - val single_read : t -> Cstruct.t -> int - end - - module type SINK = sig - type t - val single_write : t -> Cstruct.t list -> int - val copy : t -> src:_ source -> unit - end - - module type SHUTDOWN = sig - type t - val shutdown : t -> shutdown_command -> unit - end - - type (_, _, _) Resource.pi += - | Source : ('t, (module SOURCE with type t = 't), [> source_ty]) Resource.pi - | Sink : ('t, (module SINK with type t = 't), [> sink_ty]) Resource.pi - | Shutdown : ('t, (module SHUTDOWN with type t = 't), [> shutdown_ty]) Resource.pi - - let source (type t) (module X : SOURCE with type t = t) = - Resource.handler [H (Source, (module X))] - - let sink (type t) (module X : SINK with type t = t) = - Resource.handler [H (Sink, (module X))] - - let shutdown (type t) (module X : SHUTDOWN with type t = t) = - Resource.handler [ H (Shutdown, (module X))] - - module type TWO_WAY = sig - include SHUTDOWN - include SOURCE with type t := t - include SINK with type t := t - end - - let two_way (type t) (module X : TWO_WAY with type t = t) = - Resource.handler [ - H (Shutdown, (module X)); - H (Source, (module X)); - H (Sink, (module X)); - ] - - let simple_copy ~single_write t ~src:(Resource.T (src, src_ops)) = - let rec write_all buf = - if not (Cstruct.is_empty buf) then ( - let sent = single_write t [buf] in - write_all (Cstruct.shift buf sent) - ) - in - let module Src = (val (Resource.get src_ops Source)) in - try - let buf = Cstruct.create 4096 in - while true do - let got = Src.single_read src buf in - write_all (Cstruct.sub buf 0 got) - done - with End_of_file -> () -end - -open Pi - -let close = Resource.close - -let single_read (Resource.T (t, ops)) buf = - let module X = (val (Resource.get ops Source)) in - let got = X.single_read t buf in - assert (got > 0 && got <= Cstruct.length buf); - got - -let rec read_exact t buf = - if Cstruct.length buf > 0 then ( - let got = single_read t buf in - read_exact t (Cstruct.shift buf got) - ) - -module Cstruct_source = struct - type t = Cstruct.t list ref - - let create data = ref data - - let read_source_buffer t fn = - let rec aux () = - match !t with - | [] -> raise End_of_file - | x :: xs when Cstruct.length x = 0 -> t := xs; aux () - | xs -> - let n = fn xs in - t := Cstruct.shiftv xs n - in - aux () - - let read_methods = - [ Read_source_buffer read_source_buffer ] - - let single_read t dst = - let avail, src = Cstruct.fillv ~dst ~src:!t in - if avail = 0 then raise End_of_file; - t := src; - avail - -end - -let cstruct_source = - let ops = Pi.source (module Cstruct_source) in - fun data -> Resource.T (Cstruct_source.create data, ops) - -module String_source = struct - type t = { - s : string; - mutable offset : int; - } - - let single_read t dst = - if t.offset = String.length t.s then raise End_of_file; - let len = min (Cstruct.length dst) (String.length t.s - t.offset) in - Cstruct.blit_from_string t.s t.offset dst 0 len; - t.offset <- t.offset + len; - len - - let read_methods = [] - - let create s = { s; offset = 0 } -end - -let string_source = - let ops = Pi.source (module String_source) in - fun s -> Resource.T (String_source.create s, ops) - -let single_write (Resource.T (t, ops)) bufs = - let module X = (val (Resource.get ops Sink)) in - X.single_write t bufs - -let write (Resource.T (t, ops)) bufs = - let module X = (val (Resource.get ops Sink)) in - let rec aux = function - | [] -> () - | bufs -> - let wrote = X.single_write t bufs in - aux (Cstruct.shiftv bufs wrote) - in - aux bufs - -let copy src (Resource.T (t, ops)) = - let module X = (val (Resource.get ops Sink)) in - X.copy t ~src - -let copy_string s = copy (string_source s) - -module Buffer_sink = struct - type t = Buffer.t - - let single_write t bufs = - let old_length = Buffer.length t in - List.iter (fun buf -> Buffer.add_bytes t (Cstruct.to_bytes buf)) bufs; - Buffer.length t - old_length - - let copy t ~src = Pi.simple_copy ~single_write t ~src -end - -let buffer_sink = - let ops = Pi.sink (module Buffer_sink) in - fun b -> Resource.T (b, ops) - -type two_way_ty = [source_ty | sink_ty | shutdown_ty] -type 'a two_way = ([> two_way_ty] as 'a) r - -let shutdown (Resource.T (t, ops)) cmd = - let module X = (val (Resource.get ops Shutdown)) in - X.shutdown t cmd +open Std + +type shutdown_command = [ `Receive | `Send | `All ] + +type 't read_method = .. +type 't read_method += Read_source_buffer of ('t -> (Cstruct.t list -> int) -> unit) + +type source_ty = [`R | `Flow] +type 'a source = ([> source_ty] as 'a) r + +type sink_ty = [`W | `Flow] +type 'a sink = ([> sink_ty] as 'a) r + +type shutdown_ty = [`Shutdown] +type 'a shutdown = ([> shutdown_ty] as 'a) r + +module Pi = struct + module type SOURCE = sig + type t + val read_methods : t read_method list + val single_read : t -> Cstruct.t -> int + end + + module type SINK = sig + type t + val single_write : t -> Cstruct.t list -> int + val copy : t -> src:_ source -> unit + end + + module type SHUTDOWN = sig + type t + val shutdown : t -> shutdown_command -> unit + end + + type (_, _, _) Resource.pi += + | Source : ('t, (module SOURCE with type t = 't), [> source_ty]) Resource.pi + | Sink : ('t, (module SINK with type t = 't), [> sink_ty]) Resource.pi + | Shutdown : ('t, (module SHUTDOWN with type t = 't), [> shutdown_ty]) Resource.pi + + let source (type t) (module X : SOURCE with type t = t) = + Resource.handler [H (Source, (module X))] + + let sink (type t) (module X : SINK with type t = t) = + Resource.handler [H (Sink, (module X))] + + let shutdown (type t) (module X : SHUTDOWN with type t = t) = + Resource.handler [ H (Shutdown, (module X))] + + module type TWO_WAY = sig + include SHUTDOWN + include SOURCE with type t := t + include SINK with type t := t + end + + let two_way (type t) (module X : TWO_WAY with type t = t) = + Resource.handler [ + H (Shutdown, (module X)); + H (Source, (module X)); + H (Sink, (module X)); + ] + + let simple_copy ~single_write t ~src:(Resource.T (src, src_ops)) = + let rec write_all buf = + if not (Cstruct.is_empty buf) then ( + let sent = single_write t [buf] in + write_all (Cstruct.shift buf sent) + ) + in + let module Src = (val (Resource.get src_ops Source)) in + try + let buf = Cstruct.create 4096 in + while true do + let got = Src.single_read src buf in + write_all (Cstruct.sub buf 0 got) + done + with End_of_file -> () +end + +open Pi + +let close = Resource.close + +let single_read (Resource.T (t, ops)) buf = + let module X = (val (Resource.get ops Source)) in + let got = X.single_read t buf in + assert (got > 0 && got <= Cstruct.length buf); + got + +let rec read_exact t buf = + if Cstruct.length buf > 0 then ( + let got = single_read t buf in + read_exact t (Cstruct.shift buf got) + ) + +module Cstruct_source = struct + type t = Cstruct.t list ref + + let create data = ref data + + let read_source_buffer t fn = + let rec aux () = + match !t with + | [] -> raise End_of_file + | x :: xs when Cstruct.length x = 0 -> t := xs; aux () + | xs -> + let n = fn xs in + t := Cstruct.shiftv xs n + in + aux () + + let read_methods = + [ Read_source_buffer read_source_buffer ] + + let single_read t dst = + let avail, src = Cstruct.fillv ~dst ~src:!t in + if avail = 0 then raise End_of_file; + t := src; + avail + +end + +let cstruct_source = + let ops = Pi.source (module Cstruct_source) in + fun data -> Resource.T (Cstruct_source.create data, ops) + +module String_source = struct + type t = { + s : string; + mutable offset : int; + } + + let single_read t dst = + if t.offset = String.length t.s then raise End_of_file; + let len = min (Cstruct.length dst) (String.length t.s - t.offset) in + Cstruct.blit_from_string t.s t.offset dst 0 len; + t.offset <- t.offset + len; + len + + let read_methods = [] + + let create s = { s; offset = 0 } +end + +let string_source = + let ops = Pi.source (module String_source) in + fun s -> Resource.T (String_source.create s, ops) + +let single_write (Resource.T (t, ops)) bufs = + let module X = (val (Resource.get ops Sink)) in + X.single_write t bufs + +let write (Resource.T (t, ops)) bufs = + let module X = (val (Resource.get ops Sink)) in + let rec aux = function + | [] -> () + | bufs -> + let wrote = X.single_write t bufs in + aux (Cstruct.shiftv bufs wrote) + in + aux bufs + +let copy src (Resource.T (t, ops)) = + let module X = (val (Resource.get ops Sink)) in + X.copy t ~src + +let copy_string s = copy (string_source s) + +module Buffer_sink = struct + type t = Buffer.t + + let single_write t bufs = + let old_length = Buffer.length t in + List.iter (fun buf -> Buffer.add_bytes t (Cstruct.to_bytes buf)) bufs; + Buffer.length t - old_length + + let copy t ~src = Pi.simple_copy ~single_write t ~src +end + +let buffer_sink = + let ops = Pi.sink (module Buffer_sink) in + fun b -> Resource.T (b, ops) + +type two_way_ty = [source_ty | sink_ty | shutdown_ty] +type 'a two_way = ([> two_way_ty] as 'a) r + +let shutdown (Resource.T (t, ops)) cmd = + let module X = (val (Resource.get ops Shutdown)) in + X.shutdown t cmd diff --git a/lib_eio/flow.mli b/lib_eio/flow.mli index 46580da8b..419775b23 100644 --- a/lib_eio/flow.mli +++ b/lib_eio/flow.mli @@ -1,158 +1,158 @@ -(** Flows are used to represent byte streams, such as open files and network sockets. - A {!source} provides a stream of bytes. A {!sink} consumes a stream. - A {!two_way} can do both. - - To read structured data (e.g. a line at a time), wrap a source using {!Buf_read}. *) - -open Std - -(** {2 Types} *) - -type source_ty = [`R | `Flow] -type 'a source = ([> source_ty] as 'a) r -(** A readable flow provides a stream of bytes. *) - -type sink_ty = [`W | `Flow] -type 'a sink = ([> sink_ty] as 'a) r -(** A writeable flow accepts a stream of bytes. *) - -type shutdown_ty = [`Shutdown] -type 'a shutdown = ([> shutdown_ty] as 'a) r - -type 'a read_method = .. -(** Sources can offer a list of ways to read them, in order of preference. *) - -type shutdown_command = [ - | `Receive (** Indicate that no more reads will be done *) - | `Send (** Indicate that no more writes will be done *) - | `All (** Indicate that no more reads or writes will be done *) -] - -(** {2 Reading} *) - -val single_read : _ source -> Cstruct.t -> int -(** [single_read src buf] reads one or more bytes into [buf]. - - It returns the number of bytes read (which may be less than the - buffer size even if there is more data to be read). - - - Use {!read_exact} instead if you want to fill [buf] completely. - - Use {!Buf_read.line} to read complete lines. - - Use {!copy} to stream data directly from a source to a sink. - - [buf] must not be zero-length. - - @raise End_of_file if there is no more data to read *) - -val read_exact : _ source -> Cstruct.t -> unit -(** [read_exact src dst] keeps reading into [dst] until it is full. - @raise End_of_file if the buffer could not be filled. *) - -val string_source : string -> source_ty r -(** [string_source s] is a source that gives the bytes of [s]. *) - -val cstruct_source : Cstruct.t list -> source_ty r -(** [cstruct_source cs] is a source that gives the bytes of [cs]. *) - -type 't read_method += Read_source_buffer of ('t -> (Cstruct.t list -> int) -> unit) -(** If a source offers [Read_source_buffer rsb] then the user can call [rsb t fn] - to borrow a view of the source's buffers. [fn] returns the number of bytes it consumed. - - [rsb] will raise [End_of_file] if no more data will be produced. - If no data is currently available, [rsb] will wait for some to become available before calling [fn]. - - [fn] must not continue to use the buffers after it returns. *) - -(** {2 Writing} *) - -val write : _ sink -> Cstruct.t list -> unit -(** [write dst bufs] writes all bytes from [bufs]. - - You should not perform multiple concurrent writes on the same flow - (the output may get interleaved). - - This is a low level API. Consider using: - - - {!Buf_write} to combine multiple small writes. - - {!copy} for bulk transfers, as it allows some extra optimizations. *) - -val single_write : _ sink -> Cstruct.t list -> int -(** [single_write dst bufs] writes at least one byte from [bufs] and returns the number of bytes written. *) - -val copy : _ source -> _ sink -> unit -(** [copy src dst] copies data from [src] to [dst] until end-of-file. *) - -val copy_string : string -> _ sink -> unit -(** [copy_string s = copy (string_source s)] *) - -val buffer_sink : Buffer.t -> sink_ty r -(** [buffer_sink b] is a sink that adds anything sent to it to [b]. - - To collect data as a cstruct, use {!Buf_read} instead. *) - -(** {2 Bidirectional streams} *) - -type two_way_ty = [source_ty | sink_ty | shutdown_ty] -type 'a two_way = ([> two_way_ty] as 'a) r - -val shutdown : _ two_way -> shutdown_command -> unit -(** [shutdown t cmd] indicates that the caller has finished reading or writing [t] - (depending on [cmd]). - - This is useful in some protocols to indicate that you have finished sending the request, - and that the remote peer should now send the response. *) - -(** {2 Closing} - - Flows are usually attached to switches and closed automatically when the switch - finishes. However, it can be useful to close them sooner manually in some cases. *) - -val close : [> `Close] r -> unit -(** Alias of {!Resource.close}. *) - -(** {2 Provider Interface} *) - -module Pi : sig - module type SOURCE = sig - type t - val read_methods : t read_method list - val single_read : t -> Cstruct.t -> int - end - - module type SINK = sig - type t - - val single_write : t -> Cstruct.t list -> int - - val copy : t -> src:_ source -> unit - (** [copy t ~src] allows for optimising copy operations. - - If you have no optimisations, you can use {!simple_copy} to implement this using {!single_write}. *) - end - - module type SHUTDOWN = sig - type t - val shutdown : t -> shutdown_command -> unit - end - - val source : (module SOURCE with type t = 't) -> ('t, source_ty) Resource.handler - val sink : (module SINK with type t = 't) -> ('t, sink_ty) Resource.handler - val shutdown : (module SHUTDOWN with type t = 't) -> ('t, shutdown_ty) Resource.handler - - module type TWO_WAY = sig - include SHUTDOWN - include SOURCE with type t := t - include SINK with type t := t - end - - val two_way : (module TWO_WAY with type t = 't) -> ('t, two_way_ty) Resource.handler - - type (_, _, _) Resource.pi += - | Source : ('t, (module SOURCE with type t = 't), [> source_ty]) Resource.pi - | Sink : ('t, (module SINK with type t = 't), [> sink_ty]) Resource.pi - | Shutdown : ('t, (module SHUTDOWN with type t = 't), [> shutdown_ty]) Resource.pi - - val simple_copy : single_write:('t -> Cstruct.t list -> int) -> 't -> src:_ source -> unit - (** [simple_copy ~single_write] implements {!SINK}'s [copy] API using [single_write]. *) -end - +(** Flows are used to represent byte streams, such as open files and network sockets. + A {!source} provides a stream of bytes. A {!sink} consumes a stream. + A {!two_way} can do both. + + To read structured data (e.g. a line at a time), wrap a source using {!Buf_read}. *) + +open Std + +(** {2 Types} *) + +type source_ty = [`R | `Flow] +type 'a source = ([> source_ty] as 'a) r +(** A readable flow provides a stream of bytes. *) + +type sink_ty = [`W | `Flow] +type 'a sink = ([> sink_ty] as 'a) r +(** A writeable flow accepts a stream of bytes. *) + +type shutdown_ty = [`Shutdown] +type 'a shutdown = ([> shutdown_ty] as 'a) r + +type 'a read_method = .. +(** Sources can offer a list of ways to read them, in order of preference. *) + +type shutdown_command = [ + | `Receive (** Indicate that no more reads will be done *) + | `Send (** Indicate that no more writes will be done *) + | `All (** Indicate that no more reads or writes will be done *) +] + +(** {2 Reading} *) + +val single_read : _ source -> Cstruct.t -> int +(** [single_read src buf] reads one or more bytes into [buf]. + + It returns the number of bytes read (which may be less than the + buffer size even if there is more data to be read). + + - Use {!read_exact} instead if you want to fill [buf] completely. + - Use {!Buf_read.line} to read complete lines. + - Use {!copy} to stream data directly from a source to a sink. + + [buf] must not be zero-length. + + @raise End_of_file if there is no more data to read *) + +val read_exact : _ source -> Cstruct.t -> unit +(** [read_exact src dst] keeps reading into [dst] until it is full. + @raise End_of_file if the buffer could not be filled. *) + +val string_source : string -> source_ty r +(** [string_source s] is a source that gives the bytes of [s]. *) + +val cstruct_source : Cstruct.t list -> source_ty r +(** [cstruct_source cs] is a source that gives the bytes of [cs]. *) + +type 't read_method += Read_source_buffer of ('t -> (Cstruct.t list -> int) -> unit) +(** If a source offers [Read_source_buffer rsb] then the user can call [rsb t fn] + to borrow a view of the source's buffers. [fn] returns the number of bytes it consumed. + + [rsb] will raise [End_of_file] if no more data will be produced. + If no data is currently available, [rsb] will wait for some to become available before calling [fn]. + + [fn] must not continue to use the buffers after it returns. *) + +(** {2 Writing} *) + +val write : _ sink -> Cstruct.t list -> unit +(** [write dst bufs] writes all bytes from [bufs]. + + You should not perform multiple concurrent writes on the same flow + (the output may get interleaved). + + This is a low level API. Consider using: + + - {!Buf_write} to combine multiple small writes. + - {!copy} for bulk transfers, as it allows some extra optimizations. *) + +val single_write : _ sink -> Cstruct.t list -> int +(** [single_write dst bufs] writes at least one byte from [bufs] and returns the number of bytes written. *) + +val copy : _ source -> _ sink -> unit +(** [copy src dst] copies data from [src] to [dst] until end-of-file. *) + +val copy_string : string -> _ sink -> unit +(** [copy_string s = copy (string_source s)] *) + +val buffer_sink : Buffer.t -> sink_ty r +(** [buffer_sink b] is a sink that adds anything sent to it to [b]. + + To collect data as a cstruct, use {!Buf_read} instead. *) + +(** {2 Bidirectional streams} *) + +type two_way_ty = [source_ty | sink_ty | shutdown_ty] +type 'a two_way = ([> two_way_ty] as 'a) r + +val shutdown : _ two_way -> shutdown_command -> unit +(** [shutdown t cmd] indicates that the caller has finished reading or writing [t] + (depending on [cmd]). + + This is useful in some protocols to indicate that you have finished sending the request, + and that the remote peer should now send the response. *) + +(** {2 Closing} + + Flows are usually attached to switches and closed automatically when the switch + finishes. However, it can be useful to close them sooner manually in some cases. *) + +val close : [> `Close] r -> unit +(** Alias of {!Resource.close}. *) + +(** {2 Provider Interface} *) + +module Pi : sig + module type SOURCE = sig + type t + val read_methods : t read_method list + val single_read : t -> Cstruct.t -> int + end + + module type SINK = sig + type t + + val single_write : t -> Cstruct.t list -> int + + val copy : t -> src:_ source -> unit + (** [copy t ~src] allows for optimising copy operations. + + If you have no optimisations, you can use {!simple_copy} to implement this using {!single_write}. *) + end + + module type SHUTDOWN = sig + type t + val shutdown : t -> shutdown_command -> unit + end + + val source : (module SOURCE with type t = 't) -> ('t, source_ty) Resource.handler + val sink : (module SINK with type t = 't) -> ('t, sink_ty) Resource.handler + val shutdown : (module SHUTDOWN with type t = 't) -> ('t, shutdown_ty) Resource.handler + + module type TWO_WAY = sig + include SHUTDOWN + include SOURCE with type t := t + include SINK with type t := t + end + + val two_way : (module TWO_WAY with type t = 't) -> ('t, two_way_ty) Resource.handler + + type (_, _, _) Resource.pi += + | Source : ('t, (module SOURCE with type t = 't), [> source_ty]) Resource.pi + | Sink : ('t, (module SINK with type t = 't), [> sink_ty]) Resource.pi + | Shutdown : ('t, (module SHUTDOWN with type t = 't), [> shutdown_ty]) Resource.pi + + val simple_copy : single_write:('t -> Cstruct.t list -> int) -> 't -> src:_ source -> unit + (** [simple_copy ~single_write] implements {!SINK}'s [copy] API using [single_write]. *) +end + diff --git a/lib_eio/fs.ml b/lib_eio/fs.ml index 34505c9f1..074528908 100644 --- a/lib_eio/fs.ml +++ b/lib_eio/fs.ml @@ -1,80 +1,80 @@ -(** Note: file-system operations, such as opening or deleting files, - can be found in the {!Path} module. *) - -open Std - -(** {2 Types} *) - -type path = string - -type error = - | Already_exists of Exn.Backend.t - | Not_found of Exn.Backend.t - | Permission_denied of Exn.Backend.t - | File_too_large - | Not_native of string (** Raised by {!Path.native_exn}. *) - -type Exn.err += E of error - -let err e = - Exn.create (E e) - -let () = - Exn.register_pp (fun f -> function - | E e -> - Fmt.string f "Fs "; - begin match e with - | Already_exists e -> Fmt.pf f "Already_exists %a" Exn.Backend.pp e - | Not_found e -> Fmt.pf f "Not_found %a" Exn.Backend.pp e - | Permission_denied e -> Fmt.pf f "Permission_denied %a" Exn.Backend.pp e - | File_too_large -> Fmt.pf f "File_too_large" - | Not_native m -> Fmt.pf f "Not_native %S" m - end; - true - | _ -> false - ) - -(** When to create a new file. *) -type create = [ - | `Never (** fail if the named file doesn't exist *) - | `If_missing of File.Unix_perm.t (** create if file doesn't already exist *) - | `Or_truncate of File.Unix_perm.t (** any existing file is truncated to zero length *) - | `Exclusive of File.Unix_perm.t (** always create; fail if the file already exists *) -] -(** If a new file is created, the given permissions are used for it. *) - -type dir_ty = [`Dir] -type 'a dir = ([> dir_ty] as 'a) r -(** Note: use the functions in {!Path} to access directories. *) - -(** {2 Provider Interface} *) - -module Pi = struct - module type DIR = sig - type t - - val open_in : t -> sw:Switch.t -> path -> File.ro_ty r - - val open_out : - t -> - sw:Switch.t -> - append:bool -> - create:create -> - path -> File.rw_ty r - - val mkdir : t -> perm:File.Unix_perm.t -> path -> unit - val open_dir : t -> sw:Switch.t -> path -> [`Close | dir_ty] r - val read_dir : t -> path -> string list - val stat : t -> follow:bool -> string -> File.Stat.t - val unlink : t -> path -> unit - val rmdir : t -> path -> unit - val rename : t -> path -> _ dir -> path -> unit - val read_link : t -> path -> string - val symlink : link_to:path -> t -> path -> unit - val pp : t Fmt.t - val native : t -> string -> string option - end - - type (_, _, _) Resource.pi += - | Dir : ('t, (module DIR with type t = 't), [> dir_ty]) Resource.pi -end +(** Note: file-system operations, such as opening or deleting files, + can be found in the {!Path} module. *) + +open Std + +(** {2 Types} *) + +type path = string + +type error = + | Already_exists of Exn.Backend.t + | Not_found of Exn.Backend.t + | Permission_denied of Exn.Backend.t + | File_too_large + | Not_native of string (** Raised by {!Path.native_exn}. *) + +type Exn.err += E of error + +let err e = + Exn.create (E e) + +let () = + Exn.register_pp (fun f -> function + | E e -> + Fmt.string f "Fs "; + begin match e with + | Already_exists e -> Fmt.pf f "Already_exists %a" Exn.Backend.pp e + | Not_found e -> Fmt.pf f "Not_found %a" Exn.Backend.pp e + | Permission_denied e -> Fmt.pf f "Permission_denied %a" Exn.Backend.pp e + | File_too_large -> Fmt.pf f "File_too_large" + | Not_native m -> Fmt.pf f "Not_native %S" m + end; + true + | _ -> false + ) + +(** When to create a new file. *) +type create = [ + | `Never (** fail if the named file doesn't exist *) + | `If_missing of File.Unix_perm.t (** create if file doesn't already exist *) + | `Or_truncate of File.Unix_perm.t (** any existing file is truncated to zero length *) + | `Exclusive of File.Unix_perm.t (** always create; fail if the file already exists *) +] +(** If a new file is created, the given permissions are used for it. *) + +type dir_ty = [`Dir] +type 'a dir = ([> dir_ty] as 'a) r +(** Note: use the functions in {!Path} to access directories. *) + +(** {2 Provider Interface} *) + +module Pi = struct + module type DIR = sig + type t + + val open_in : t -> sw:Switch.t -> path -> File.ro_ty r + + val open_out : + t -> + sw:Switch.t -> + append:bool -> + create:create -> + path -> File.rw_ty r + + val mkdir : t -> perm:File.Unix_perm.t -> path -> unit + val open_dir : t -> sw:Switch.t -> path -> [`Close | dir_ty] r + val read_dir : t -> path -> string list + val stat : t -> follow:bool -> string -> File.Stat.t + val unlink : t -> path -> unit + val rmdir : t -> path -> unit + val rename : t -> path -> _ dir -> path -> unit + val read_link : t -> path -> string + val symlink : link_to:path -> t -> path -> unit + val pp : t Fmt.t + val native : t -> string -> string option + end + + type (_, _, _) Resource.pi += + | Dir : ('t, (module DIR with type t = 't), [> dir_ty]) Resource.pi +end diff --git a/lib_eio/hook.ml b/lib_eio/hook.ml index 6123ca0f9..be8601698 100644 --- a/lib_eio/hook.ml +++ b/lib_eio/hook.ml @@ -1,14 +1,14 @@ -type t = - | Null - | Node : 'a Lwt_dllist.node -> t - | Node_with_mutex : 'a Lwt_dllist.node * Mutex.t -> t - -let null = Null - -let remove = function - | Null -> () - | Node n -> Lwt_dllist.remove n - | Node_with_mutex (n, m) -> - Mutex.lock m; - Fun.protect ~finally:(fun () -> Mutex.unlock m) - (fun () -> Lwt_dllist.remove n) +type t = + | Null + | Node : 'a Lwt_dllist.node -> t + | Node_with_mutex : 'a Lwt_dllist.node * Mutex.t -> t + +let null = Null + +let remove = function + | Null -> () + | Node n -> Lwt_dllist.remove n + | Node_with_mutex (n, m) -> + Mutex.lock m; + Fun.protect ~finally:(fun () -> Mutex.unlock m) + (fun () -> Lwt_dllist.remove n) diff --git a/lib_eio/lazy.ml b/lib_eio/lazy.ml index 0917ed1f2..3a1c39c89 100644 --- a/lib_eio/lazy.ml +++ b/lib_eio/lazy.ml @@ -1,47 +1,47 @@ -open Std - -type 'a state = - | Value of 'a - | Waiting of (unit Promise.u -> unit) - | Running of unit Promise.t (* Wait until resolved and check again *) - | Failed of Exn.with_bt - -type 'a t = 'a state Atomic.t - -let init = Waiting (fun _ -> assert false) - -let from_fun ~cancel fn = - let state = Atomic.make init in - let rec force r = - match - if cancel = `Protect then Cancel.protect fn else fn () - with - | x -> - Atomic.set state (Value x); - Promise.resolve r () - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - match ex with - | Cancel.Cancelled _ when cancel = `Restart && Fiber.is_cancelled () -> - Atomic.set state (Waiting force); - Promise.resolve r (); - Fiber.check () - | _ -> - Atomic.set state (Failed (ex, bt)); - Promise.resolve r (); - Printexc.raise_with_backtrace ex bt - in - Atomic.set state @@ Waiting force; - state - -let from_val v = Atomic.make (Value v) - -let rec force t = - match Atomic.get t with - | Value v -> v - | Failed (ex, bt) -> Printexc.raise_with_backtrace ex bt - | Running p -> Promise.await p; force t - | Waiting fn as prev -> - let p, r = Promise.create () in - if Atomic.compare_and_set t prev (Running p) then fn r; - force t +open Std + +type 'a state = + | Value of 'a + | Waiting of (unit Promise.u -> unit) + | Running of unit Promise.t (* Wait until resolved and check again *) + | Failed of Exn.with_bt + +type 'a t = 'a state Atomic.t + +let init = Waiting (fun _ -> assert false) + +let from_fun ~cancel fn = + let state = Atomic.make init in + let rec force r = + match + if cancel = `Protect then Cancel.protect fn else fn () + with + | x -> + Atomic.set state (Value x); + Promise.resolve r () + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + match ex with + | Cancel.Cancelled _ when cancel = `Restart && Fiber.is_cancelled () -> + Atomic.set state (Waiting force); + Promise.resolve r (); + Fiber.check () + | _ -> + Atomic.set state (Failed (ex, bt)); + Promise.resolve r (); + Printexc.raise_with_backtrace ex bt + in + Atomic.set state @@ Waiting force; + state + +let from_val v = Atomic.make (Value v) + +let rec force t = + match Atomic.get t with + | Value v -> v + | Failed (ex, bt) -> Printexc.raise_with_backtrace ex bt + | Running p -> Promise.await p; force t + | Waiting fn as prev -> + let p, r = Promise.create () in + if Atomic.compare_and_set t prev (Running p) then fn r; + force t diff --git a/lib_eio/lazy.mli b/lib_eio/lazy.mli index 46eaaf996..dae513cb4 100644 --- a/lib_eio/lazy.mli +++ b/lib_eio/lazy.mli @@ -1,27 +1,27 @@ -(** This is like [Stdlib.Lazy], but multiple fibers or domains can force at once. *) - -type 'a t -(** A lazy value that produces a value of type ['a]. *) - -val from_fun : - cancel:[`Restart | `Record | `Protect] -> - (unit -> 'a) -> 'a t -(** [from_fun ~cancel fn] is a lazy value that runs [fn ()] the first time it is forced. - - [cancel] determines how cancellation is handled while forcing: - - - [`Restart] : if the forcing fiber is cancelled, the next waiting fiber runs [fn] again. - - [`Record] : the failure is recorded and the lazy value will always report cancelled if used. - - [`Protect] : the forcing fiber is protected from cancellation while running. *) - -val from_val : 'a -> 'a t -(** [from_val v] is a lazy value that is already forced. - - It is equivalent to [from_fun (fun () -> v)]. *) - -val force : 'a t -> 'a -(** [force t] returns the result of running the function passed to {!from_fun}. - - If the function is currently running, this waits for it to finish and then retries. - If the function has already completed then it returns the saved result. - If the function returned an exception then [force] re-raises it. *) +(** This is like [Stdlib.Lazy], but multiple fibers or domains can force at once. *) + +type 'a t +(** A lazy value that produces a value of type ['a]. *) + +val from_fun : + cancel:[`Restart | `Record | `Protect] -> + (unit -> 'a) -> 'a t +(** [from_fun ~cancel fn] is a lazy value that runs [fn ()] the first time it is forced. + + [cancel] determines how cancellation is handled while forcing: + + - [`Restart] : if the forcing fiber is cancelled, the next waiting fiber runs [fn] again. + - [`Record] : the failure is recorded and the lazy value will always report cancelled if used. + - [`Protect] : the forcing fiber is protected from cancellation while running. *) + +val from_val : 'a -> 'a t +(** [from_val v] is a lazy value that is already forced. + + It is equivalent to [from_fun (fun () -> v)]. *) + +val force : 'a t -> 'a +(** [force t] returns the result of running the function passed to {!from_fun}. + + If the function is currently running, this waits for it to finish and then retries. + If the function has already completed then it returns the saved result. + If the function returned an exception then [force] re-raises it. *) diff --git a/lib_eio/mock/action.ml b/lib_eio/mock/action.ml index cb1ef9226..29a272903 100644 --- a/lib_eio/mock/action.ml +++ b/lib_eio/mock/action.ml @@ -1,23 +1,23 @@ -open Eio.Std - -type 'a t = [ - | `Return of 'a - | `Raise of exn - | `Await of 'a Eio.Promise.or_exn - | `Yield_then of 'a t - | `Run of unit -> 'a -] - -let rec run = function - | `Return x -> x - | `Raise ex -> raise ex - | `Await p -> Promise.await_exn p - | `Yield_then t -> Fiber.yield (); run t - | `Run fn -> fn () - -let rec map f = function - | `Return x -> `Return (f x) - | `Raise ex -> `Raise ex - | `Await p -> `Run (fun () -> f (Promise.await_exn p)) - | `Yield_then t -> `Yield_then (map f t) - | `Run fn -> `Run (fun () -> f (fn ())) +open Eio.Std + +type 'a t = [ + | `Return of 'a + | `Raise of exn + | `Await of 'a Eio.Promise.or_exn + | `Yield_then of 'a t + | `Run of unit -> 'a +] + +let rec run = function + | `Return x -> x + | `Raise ex -> raise ex + | `Await p -> Promise.await_exn p + | `Yield_then t -> Fiber.yield (); run t + | `Run fn -> fn () + +let rec map f = function + | `Return x -> `Return (f x) + | `Raise ex -> `Raise ex + | `Await p -> `Run (fun () -> f (Promise.await_exn p)) + | `Yield_then t -> `Yield_then (map f t) + | `Run fn -> `Run (fun () -> f (fn ())) diff --git a/lib_eio/mock/backend.ml b/lib_eio/mock/backend.ml index 847cc92aa..41ad21b87 100644 --- a/lib_eio/mock/backend.ml +++ b/lib_eio/mock/backend.ml @@ -1,116 +1,116 @@ -module Fiber_context = Eio.Private.Fiber_context -module Trace = Eio.Private.Trace -module Lf_queue = Eio_utils.Lf_queue -module Suspended = Eio_utils.Suspended (* Adds tracing to continuations *) - -exception Deadlock_detected - -(* The scheduler could just return [unit], but this is clearer. *) -type exit = [`Exit_scheduler] - -type stdenv = < - clock : Clock.t; - mono_clock : Clock.Mono.t; - debug : Eio.Debug.t; - backend_id: string; -> - -type t = { - (* Suspended fibers waiting to run again. - [Lf_queue] is like [Stdlib.Queue], but is thread-safe (lock-free) and - allows pushing items to the head too, which we need. *) - run_q : (unit -> exit) Lf_queue.t; - - mono_clock : Clock.Mono.t; -} - -module Wall_clock = struct - type t = Clock.Mono.t - type time = float - - let wall_of_mtime m = Int64.to_float (Mtime.to_uint64_ns m) /. 1e9 - let wall_to_mtime w = Mtime.of_uint64_ns (Int64.of_float (w *. 1e9)) - - let now t = wall_of_mtime (Eio.Time.Mono.now t) - let sleep_until t time = Eio.Time.Mono.sleep_until t (wall_to_mtime time) -end - -let wall_clock = - let handler = Eio.Time.Pi.clock (module Wall_clock) in - fun mono_clock -> Eio.Resource.T (mono_clock, handler) - -(* Resume the next runnable fiber, if any. *) -let rec schedule t : exit = - match Lf_queue.pop t.run_q with - | Some f -> f () - | None -> - (* Nothing is runnable. Try advancing the clock. *) - if Clock.Mono.try_advance t.mono_clock then schedule t - else `Exit_scheduler (* Finished (or deadlocked) *) - -(* Run [main] in an Eio main loop. *) -let run_full main = - let mono_clock = Clock.Mono.make () in - let clock = wall_clock mono_clock in - let stdenv = object (_ : stdenv) - method clock = clock - method mono_clock = mono_clock - method debug = Eio.Private.Debug.v - method backend_id = "mock" - end in - let t = { run_q = Lf_queue.create (); mono_clock } in - let rec fork ~new_fiber:fiber fn = - Trace.fiber (Fiber_context.tid fiber); - (* Create a new fiber and run [fn] in it. *) - Effect.Deep.match_with fn () - { retc = (fun () -> Fiber_context.destroy fiber; schedule t); - exnc = (fun ex -> - let bt = Printexc.get_raw_backtrace () in - Fiber_context.destroy fiber; - Printexc.raise_with_backtrace ex bt - ); - effc = fun (type a) (e : a Effect.t) : ((a, exit) Effect.Deep.continuation -> exit) option -> - match e with - | Eio.Private.Effects.Suspend f -> Some (fun k -> - let k = { Suspended.k; fiber } in - (* Ask [f] to register whatever callbacks are needed to resume the fiber. - e.g. it might register a callback with a promise, for when that's resolved. *) - f fiber (fun result -> - (* The fiber is ready to run again. Add it to the queue. *) - Lf_queue.push t.run_q (fun () -> - (* Resume the fiber. *) - Fiber_context.clear_cancel_fn fiber; - match result with - | Ok v -> Suspended.continue k v - | Error ex -> Suspended.discontinue k ex - ) - ); - (* Switch to the next runnable fiber while this one's blocked. *) - schedule t - ) - | Eio.Private.Effects.Fork (new_fiber, f) -> Some (fun k -> - let k = { Suspended.k; fiber } in - (* Arrange for the forking fiber to run immediately after the new one. *) - Lf_queue.push_head t.run_q (Suspended.continue k); - (* Create and run the new fiber (using fiber context [new_fiber]). *) - fork ~new_fiber f - ) - | Eio.Private.Effects.Get_context -> Some (fun k -> - Effect.Deep.continue k fiber - ) - | _ -> None - } - in - let new_fiber = Fiber_context.make_root () in - let result = ref None in - let `Exit_scheduler = - Domain_local_await.using - ~prepare_for_await:Eio_utils.Dla.prepare_for_await - ~while_running:(fun () -> - fork ~new_fiber (fun () -> result := Some (main stdenv))) in - match !result with - | None -> raise Deadlock_detected - | Some x -> x - -let run fn = - run_full (fun _ -> fn ()) +module Fiber_context = Eio.Private.Fiber_context +module Trace = Eio.Private.Trace +module Lf_queue = Eio_utils.Lf_queue +module Suspended = Eio_utils.Suspended (* Adds tracing to continuations *) + +exception Deadlock_detected + +(* The scheduler could just return [unit], but this is clearer. *) +type exit = [`Exit_scheduler] + +type stdenv = < + clock : Clock.t; + mono_clock : Clock.Mono.t; + debug : Eio.Debug.t; + backend_id: string; +> + +type t = { + (* Suspended fibers waiting to run again. + [Lf_queue] is like [Stdlib.Queue], but is thread-safe (lock-free) and + allows pushing items to the head too, which we need. *) + run_q : (unit -> exit) Lf_queue.t; + + mono_clock : Clock.Mono.t; +} + +module Wall_clock = struct + type t = Clock.Mono.t + type time = float + + let wall_of_mtime m = Int64.to_float (Mtime.to_uint64_ns m) /. 1e9 + let wall_to_mtime w = Mtime.of_uint64_ns (Int64.of_float (w *. 1e9)) + + let now t = wall_of_mtime (Eio.Time.Mono.now t) + let sleep_until t time = Eio.Time.Mono.sleep_until t (wall_to_mtime time) +end + +let wall_clock = + let handler = Eio.Time.Pi.clock (module Wall_clock) in + fun mono_clock -> Eio.Resource.T (mono_clock, handler) + +(* Resume the next runnable fiber, if any. *) +let rec schedule t : exit = + match Lf_queue.pop t.run_q with + | Some f -> f () + | None -> + (* Nothing is runnable. Try advancing the clock. *) + if Clock.Mono.try_advance t.mono_clock then schedule t + else `Exit_scheduler (* Finished (or deadlocked) *) + +(* Run [main] in an Eio main loop. *) +let run_full main = + let mono_clock = Clock.Mono.make () in + let clock = wall_clock mono_clock in + let stdenv = object (_ : stdenv) + method clock = clock + method mono_clock = mono_clock + method debug = Eio.Private.Debug.v + method backend_id = "mock" + end in + let t = { run_q = Lf_queue.create (); mono_clock } in + let rec fork ~new_fiber:fiber fn = + Trace.fiber (Fiber_context.tid fiber); + (* Create a new fiber and run [fn] in it. *) + Effect.Deep.match_with fn () + { retc = (fun () -> Fiber_context.destroy fiber; schedule t); + exnc = (fun ex -> + let bt = Printexc.get_raw_backtrace () in + Fiber_context.destroy fiber; + Printexc.raise_with_backtrace ex bt + ); + effc = fun (type a) (e : a Effect.t) : ((a, exit) Effect.Deep.continuation -> exit) option -> + match e with + | Eio.Private.Effects.Suspend f -> Some (fun k -> + let k = { Suspended.k; fiber } in + (* Ask [f] to register whatever callbacks are needed to resume the fiber. + e.g. it might register a callback with a promise, for when that's resolved. *) + f fiber (fun result -> + (* The fiber is ready to run again. Add it to the queue. *) + Lf_queue.push t.run_q (fun () -> + (* Resume the fiber. *) + Fiber_context.clear_cancel_fn fiber; + match result with + | Ok v -> Suspended.continue k v + | Error ex -> Suspended.discontinue k ex + ) + ); + (* Switch to the next runnable fiber while this one's blocked. *) + schedule t + ) + | Eio.Private.Effects.Fork (new_fiber, f) -> Some (fun k -> + let k = { Suspended.k; fiber } in + (* Arrange for the forking fiber to run immediately after the new one. *) + Lf_queue.push_head t.run_q (Suspended.continue k); + (* Create and run the new fiber (using fiber context [new_fiber]). *) + fork ~new_fiber f + ) + | Eio.Private.Effects.Get_context -> Some (fun k -> + Effect.Deep.continue k fiber + ) + | _ -> None + } + in + let new_fiber = Fiber_context.make_root () in + let result = ref None in + let `Exit_scheduler = + Domain_local_await.using + ~prepare_for_await:Eio_utils.Dla.prepare_for_await + ~while_running:(fun () -> + fork ~new_fiber (fun () -> result := Some (main stdenv))) in + match !result with + | None -> raise Deadlock_detected + | Some x -> x + +let run fn = + run_full (fun _ -> fn ()) diff --git a/lib_eio/mock/backend.mli b/lib_eio/mock/backend.mli index 7e29111cd..5fc4aadb3 100644 --- a/lib_eio/mock/backend.mli +++ b/lib_eio/mock/backend.mli @@ -1,25 +1,25 @@ -(** A dummy Eio backend with no actual IO. - - This backend does not support the use of multiple domains or systhreads, - but the tradeoff is that it can reliably detect deadlock, because if the - run queue is empty then it knows that no wake up event can be coming from - elsewhere. *) - -exception Deadlock_detected - -val run : (unit -> 'a) -> 'a -(** [run fn] runs an event loop and then calls [fn env] within it. - @raise Deadlock_detected if the run queue becomes empty but [fn] hasn't returned. *) - -type stdenv = < - clock : Clock.t; - mono_clock : Clock.Mono.t; - debug : Eio.Debug.t; - backend_id: string; -> - -val run_full : (stdenv -> 'a) -> 'a -(** [run_full] is like {!run} but also provides a mock environment. - - The mock monotonic clock it provides advances automatically when there is nothing left to do. - The mock wall clock is linked directly to the monotonic time. *) +(** A dummy Eio backend with no actual IO. + + This backend does not support the use of multiple domains or systhreads, + but the tradeoff is that it can reliably detect deadlock, because if the + run queue is empty then it knows that no wake up event can be coming from + elsewhere. *) + +exception Deadlock_detected + +val run : (unit -> 'a) -> 'a +(** [run fn] runs an event loop and then calls [fn env] within it. + @raise Deadlock_detected if the run queue becomes empty but [fn] hasn't returned. *) + +type stdenv = < + clock : Clock.t; + mono_clock : Clock.Mono.t; + debug : Eio.Debug.t; + backend_id: string; +> + +val run_full : (stdenv -> 'a) -> 'a +(** [run_full] is like {!run} but also provides a mock environment. + + The mock monotonic clock it provides advances automatically when there is nothing left to do. + The mock wall clock is linked directly to the monotonic time. *) diff --git a/lib_eio/mock/clock.ml b/lib_eio/mock/clock.ml index effefd606..fc10d84b6 100644 --- a/lib_eio/mock/clock.ml +++ b/lib_eio/mock/clock.ml @@ -1,130 +1,130 @@ -open Eio.Std - -type 'time ty = [`Mock | 'time Eio.Time.clock_ty] - -module type S = sig - type time - - type t = time ty r - - val make : unit -> t - val advance : t -> unit - val try_advance : t -> bool - val set_time : t -> time -> unit -end - -module type TIME = sig - type t - val zero : t - val compare : t -> t -> int - val pp : t Fmt.t -end - -module Make(T : TIME) : S with type time := T.t = struct - type t = T.t ty r - - module Key = struct - type t = < > - let compare = compare - end - - module Job = struct - type t = { - time : T.t; - resolver : unit Promise.u; - } - - let compare a b = T.compare a.time b.time - end - - module Q = Psq.Make(Key)(Job) - - module Impl = struct - type time = T.t - - type t = { - mutable now : T.t; - mutable q : Q.t; - } - - let make () = - { - now = T.zero; - q = Q.empty; - } - - let now t = t.now - - let sleep_until t time = - if T.compare time t.now <= 0 then Fiber.yield () - else ( - let p, r = Promise.create () in - let k = object end in - t.q <- Q.add k { time; resolver = r } t.q; - try - Promise.await p - with Eio.Cancel.Cancelled _ as ex -> - t.q <- Q.remove k t.q; - raise ex - ) - - let set_time t time = - let rec drain () = - match Q.min t.q with - | Some (_, v) when T.compare v.time time <= 0 -> - Promise.resolve v.resolver (); - t.q <- Option.get (Q.rest t.q); - drain () - | _ -> () - in - drain (); - t.now <- time; - traceln "mock time is now %a" T.pp t.now - - let try_advance t = - match Q.min t.q with - | None -> false - | Some (_, v) -> set_time t v.time; true - - type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, T.t ty) Eio.Resource.pi - let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t - end - - let handler = - Eio.Resource.handler ( - H (Impl.Raw, Fun.id) :: - Eio.Resource.bindings (Eio.Time.Pi.clock (module Impl)); - ) - - let make () = - Eio.Resource.T (Impl.make (), handler) - - let set_time t v = Impl.set_time (Impl.raw t) v - - let try_advance t = Impl.try_advance (Impl.raw t) - - let advance t = - if not (try_advance t) then - invalid_arg "No further events scheduled on mock clock" -end - -module Old_time = struct - type t = float - let compare = Float.compare - let pp f x = Fmt.pf f "%g" x - let zero = 0.0 -end - -module Mono_time = struct - type t = Mtime.t - let compare = Mtime.compare - let zero = Mtime.of_uint64_ns 0L - - let pp f t = - let s = Int64.to_float (Mtime.to_uint64_ns t) /. 1e9 in - Fmt.pf f "%g" s -end - -module Mono = Make(Mono_time) - -include Make(Old_time) +open Eio.Std + +type 'time ty = [`Mock | 'time Eio.Time.clock_ty] + +module type S = sig + type time + + type t = time ty r + + val make : unit -> t + val advance : t -> unit + val try_advance : t -> bool + val set_time : t -> time -> unit +end + +module type TIME = sig + type t + val zero : t + val compare : t -> t -> int + val pp : t Fmt.t +end + +module Make(T : TIME) : S with type time := T.t = struct + type t = T.t ty r + + module Key = struct + type t = < > + let compare = compare + end + + module Job = struct + type t = { + time : T.t; + resolver : unit Promise.u; + } + + let compare a b = T.compare a.time b.time + end + + module Q = Psq.Make(Key)(Job) + + module Impl = struct + type time = T.t + + type t = { + mutable now : T.t; + mutable q : Q.t; + } + + let make () = + { + now = T.zero; + q = Q.empty; + } + + let now t = t.now + + let sleep_until t time = + if T.compare time t.now <= 0 then Fiber.yield () + else ( + let p, r = Promise.create () in + let k = object end in + t.q <- Q.add k { time; resolver = r } t.q; + try + Promise.await p + with Eio.Cancel.Cancelled _ as ex -> + t.q <- Q.remove k t.q; + raise ex + ) + + let set_time t time = + let rec drain () = + match Q.min t.q with + | Some (_, v) when T.compare v.time time <= 0 -> + Promise.resolve v.resolver (); + t.q <- Option.get (Q.rest t.q); + drain () + | _ -> () + in + drain (); + t.now <- time; + traceln "mock time is now %a" T.pp t.now + + let try_advance t = + match Q.min t.q with + | None -> false + | Some (_, v) -> set_time t v.time; true + + type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, T.t ty) Eio.Resource.pi + let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t + end + + let handler = + Eio.Resource.handler ( + H (Impl.Raw, Fun.id) :: + Eio.Resource.bindings (Eio.Time.Pi.clock (module Impl)); + ) + + let make () = + Eio.Resource.T (Impl.make (), handler) + + let set_time t v = Impl.set_time (Impl.raw t) v + + let try_advance t = Impl.try_advance (Impl.raw t) + + let advance t = + if not (try_advance t) then + invalid_arg "No further events scheduled on mock clock" +end + +module Old_time = struct + type t = float + let compare = Float.compare + let pp f x = Fmt.pf f "%g" x + let zero = 0.0 +end + +module Mono_time = struct + type t = Mtime.t + let compare = Mtime.compare + let zero = Mtime.of_uint64_ns 0L + + let pp f t = + let s = Int64.to_float (Mtime.to_uint64_ns t) /. 1e9 in + Fmt.pf f "%g" s +end + +module Mono = Make(Mono_time) + +include Make(Old_time) diff --git a/lib_eio/mock/clock.mli b/lib_eio/mock/clock.mli index 67fc96b2b..d3dee9952 100644 --- a/lib_eio/mock/clock.mli +++ b/lib_eio/mock/clock.mli @@ -1,31 +1,31 @@ -(** Note that {!Backend.run_full} provides mock clocks - that advance automatically when there is nothing left to do. *) - -open Eio.Std - -type 'time ty = [`Mock | 'time Eio.Time.clock_ty] - -module type S = sig - type time - - type t = time ty r - - val make : unit -> t - (** [make ()] is a new clock. - - The time is initially set to 0.0 and doesn't change except when you call {!advance} or {!set_time}. *) - - val advance : t -> unit - (** [advance t] sets the time to the next scheduled event (adding any due fibers to the run queue). - @raise Invalid_argument if nothing is scheduled. *) - - val try_advance : t -> bool - (** Like {!advance}, but returns [false] instead of raising an exception. *) - - val set_time : t -> time -> unit - (** [set_time t time] sets the time to [time] (adding any due fibers to the run queue). *) -end - -include S with type time := float - -module Mono : S with type time := Mtime.t +(** Note that {!Backend.run_full} provides mock clocks + that advance automatically when there is nothing left to do. *) + +open Eio.Std + +type 'time ty = [`Mock | 'time Eio.Time.clock_ty] + +module type S = sig + type time + + type t = time ty r + + val make : unit -> t + (** [make ()] is a new clock. + + The time is initially set to 0.0 and doesn't change except when you call {!advance} or {!set_time}. *) + + val advance : t -> unit + (** [advance t] sets the time to the next scheduled event (adding any due fibers to the run queue). + @raise Invalid_argument if nothing is scheduled. *) + + val try_advance : t -> bool + (** Like {!advance}, but returns [false] instead of raising an exception. *) + + val set_time : t -> time -> unit + (** [set_time t time] sets the time to [time] (adding any due fibers to the run queue). *) +end + +include S with type time := float + +module Mono : S with type time := Mtime.t diff --git a/lib_eio/mock/domain_manager.ml b/lib_eio/mock/domain_manager.ml index 043bc7388..b64b6ce2a 100644 --- a/lib_eio/mock/domain_manager.ml +++ b/lib_eio/mock/domain_manager.ml @@ -1,38 +1,38 @@ -open Eio.Std - -let id = Fiber.create_key () - -let with_domain_tracing fn = - Eio.Debug.with_trace_prefix (fun f -> - Fiber.get id |> Option.iter (fun id -> Fmt.pf f "[%s] " id) - ) fn - -module Fake_domain_mgr = struct - type t = { - mutable next_domain_id : int; - } - - let create () = { next_domain_id = 1 } - - let run t fn = - let self = t.next_domain_id in - t.next_domain_id <- t.next_domain_id + 1; - let cancelled, _ = Promise.create () in - Fiber.with_binding id (string_of_int self) - (fun () -> fn ~cancelled) - - let run_raw t fn = - let self = t.next_domain_id in - t.next_domain_id <- t.next_domain_id + 1; - Fiber.with_binding id (string_of_int self) fn -end - -let create = - let handler = Eio.Domain_manager.Pi.mgr (module Fake_domain_mgr) in - fun () -> Eio.Resource.T (Fake_domain_mgr.create (), handler) - -let run fn = - let dm = create () in - with_domain_tracing @@ fun () -> - Fiber.with_binding id "0" @@ fun () -> - fn dm +open Eio.Std + +let id = Fiber.create_key () + +let with_domain_tracing fn = + Eio.Debug.with_trace_prefix (fun f -> + Fiber.get id |> Option.iter (fun id -> Fmt.pf f "[%s] " id) + ) fn + +module Fake_domain_mgr = struct + type t = { + mutable next_domain_id : int; + } + + let create () = { next_domain_id = 1 } + + let run t fn = + let self = t.next_domain_id in + t.next_domain_id <- t.next_domain_id + 1; + let cancelled, _ = Promise.create () in + Fiber.with_binding id (string_of_int self) + (fun () -> fn ~cancelled) + + let run_raw t fn = + let self = t.next_domain_id in + t.next_domain_id <- t.next_domain_id + 1; + Fiber.with_binding id (string_of_int self) fn +end + +let create = + let handler = Eio.Domain_manager.Pi.mgr (module Fake_domain_mgr) in + fun () -> Eio.Resource.T (Fake_domain_mgr.create (), handler) + +let run fn = + let dm = create () in + with_domain_tracing @@ fun () -> + Fiber.with_binding id "0" @@ fun () -> + fn dm diff --git a/lib_eio/mock/domain_manager.mli b/lib_eio/mock/domain_manager.mli index b6f90f403..b43f55908 100644 --- a/lib_eio/mock/domain_manager.mli +++ b/lib_eio/mock/domain_manager.mli @@ -1,23 +1,23 @@ -open Eio.Std - -val create : unit -> Eio.Domain_manager.ty r -(** [create ()] is a mock domain manager. - - When asked to run a new Eio domain, it just runs it in the parent domain. - It runs the function in a context where {!id} is a fresh domain ID - (assigned sequentially starting from 1). *) - -val run : (Eio.Domain_manager.ty r -> 'a) -> 'a -(** [run fn] runs [fn dm], where [dm] is a new fake domain manager. - It also runs {!with_domain_tracing} to display domain IDs in trace output. - - [fn] itself runs with {!id} set to "0". *) - -val id : string Fiber.key -(** [id] is used to get or set the current fake domain's ID. - - This is used in traceln output. *) - -val with_domain_tracing : (unit -> 'a) -> 'a -(** [with_domain_tracing fn] runs [fn ()] with a modified [traceln] function that - prefixes the current {!id} (if any) to each trace message. *) +open Eio.Std + +val create : unit -> Eio.Domain_manager.ty r +(** [create ()] is a mock domain manager. + + When asked to run a new Eio domain, it just runs it in the parent domain. + It runs the function in a context where {!id} is a fresh domain ID + (assigned sequentially starting from 1). *) + +val run : (Eio.Domain_manager.ty r -> 'a) -> 'a +(** [run fn] runs [fn dm], where [dm] is a new fake domain manager. + It also runs {!with_domain_tracing} to display domain IDs in trace output. + + [fn] itself runs with {!id} set to "0". *) + +val id : string Fiber.key +(** [id] is used to get or set the current fake domain's ID. + + This is used in traceln output. *) + +val with_domain_tracing : (unit -> 'a) -> 'a +(** [with_domain_tracing fn] runs [fn ()] with a modified [traceln] function that + prefixes the current {!id} (if any) to each trace message. *) diff --git a/lib_eio/mock/dune b/lib_eio/mock/dune index a8bc406de..5b0b44155 100644 --- a/lib_eio/mock/dune +++ b/lib_eio/mock/dune @@ -1,4 +1,4 @@ -(library - (name eio_mock) - (public_name eio.mock) - (libraries eio eio.utils)) +(library + (name eio_mock) + (public_name eio.mock) + (libraries eio eio.utils)) diff --git a/lib_eio/mock/eio_mock.ml b/lib_eio/mock/eio_mock.ml index aa07c6fa0..32c24a618 100644 --- a/lib_eio/mock/eio_mock.ml +++ b/lib_eio/mock/eio_mock.ml @@ -1,13 +1,13 @@ -module Action = Action -module Handler = Handler -module Flow = Flow -module Net = Net -module Clock = Clock -module Domain_manager = Domain_manager -module Backend = Backend - -type Eio.Exn.Backend.t += Simulated_failure -let () = Eio.Exn.Backend.register_pp (fun f -> function - | Simulated_failure -> Fmt.string f "Simulated_failure"; true - | _ -> false - ) +module Action = Action +module Handler = Handler +module Flow = Flow +module Net = Net +module Clock = Clock +module Domain_manager = Domain_manager +module Backend = Backend + +type Eio.Exn.Backend.t += Simulated_failure +let () = Eio.Exn.Backend.register_pp (fun f -> function + | Simulated_failure -> Fmt.string f "Simulated_failure"; true + | _ -> false + ) diff --git a/lib_eio/mock/eio_mock.mli b/lib_eio/mock/eio_mock.mli index 29e5e535d..5afc818e2 100644 --- a/lib_eio/mock/eio_mock.mli +++ b/lib_eio/mock/eio_mock.mli @@ -1,164 +1,164 @@ -(** Mocks for testing. - - When testing an Eio program it is often convenient to use mock resources rather than real OS-provided ones. - This allows precise control over the test, such as adding delays or simulated faults. - You can always just implement the various Eio types directly, - but this module provides some convenient pre-built mocks, and some helpers for creating your own mocks. - - Mocks typically use {!Eio.traceln} to record how they were used. - This output can be recorded and compared against a known-good copy using e.g. - {{:https://github.com/realworldocaml/mdx}ocaml-mdx}. - - Mocks may require configuration. - For example, a source flow needs to know what data to return when the application reads from it. - This can be done using the various [on_*] functions. For example: - - {[ - let stdin = Eio_mock.Flow.make "stdin" in - let stdout = Eio_mock.Flow.make "stdout" in - Eio_mock.Flow.on_read stdin [ - `Return "chunk1"; - `Return "chunk2"; - `Raise End_of_file - ]; - Eio.Flow.copy stdin stdout - ]} - - This will produce: - - {[ - +stdin: read "chunk1" - +stdout: wrote "chunk1" - +stdin: read "chunk2" - +stdout: wrote "chunk2" - ]} -*) - -open Eio.Std - -(** {2 Configuration} *) - -(** Actions that can be performed by mock handlers. *) -module Action : sig - type 'a t = [ - | `Return of 'a (** Immediately return a value *) - | `Raise of exn (** Raise an exception *) - | `Await of 'a Eio.Promise.or_exn (** Wait for a promise to resolve *) - | `Yield_then of 'a t (** Call {!Eio.Fiber.yield}, then perform an action *) - | `Run of unit -> 'a (** Run any code you like. *) - ] - - val run : 'a t -> 'a - (** [run t] performs action [t] and returns the result. *) - - val map : ('a -> 'b) -> 'a t -> 'b t - (** [run (map f t) = f (run t)]. *) -end - -(** Control how a mock responds. - - This module is mostly useful when writing custom mocks. - Individual mocks usually provide convenience wrappers around this. *) -module Handler : sig - type 'a t - (** A handler that provides values of type ['a]. *) - - type 'a actions = 'a Action.t list - - val make : 'a Action.t -> 'a t - (** [make default_action] is a new handler that initially always runs [default_action]. *) - - val set_handler : 'a t -> (unit -> 'a) -> unit - (** [set_handler t fn] sets (replaces) the function to be called whenever the handler is run. *) - - val seq : 'a t -> 'a actions -> unit - (** [seq t actions] sets a handler function that performs the next action in [actions] on each call. - When there are no more actions, it runs the default handler. *) - - val run : 'a t -> 'a - (** [run t] is used by mocks to run their handlers. *) - - val run_default_action : 'a t -> 'a - (** [run_default_action t] runs the default handler passed to {!make}. *) -end - -(** {2 Pre-defined mocks} *) - -(** Mock {!Eio.Flow} sources and sinks. *) -module Flow : sig - type copy_method = [ - | `Read_into (** Use the source's [read_into] method (the default). *) - | `Read_source_buffer (** Use the {!Eio.Flow.Read_source_buffer} optimisation. *) - ] - - type ty = [`Generic | `Mock] Eio.Net.stream_socket_ty - type t = ty r - - val make : ?pp:string Fmt.t -> string -> t - (** [make label] is a mock Eio flow. - It can be used as a source, sink, or two-way flow. - @param pp Printer to use to display the data. *) - - val on_read : t -> string Handler.actions -> unit - (** [on_read t actions] configures the values to return from the mock's [read] function. *) - - val on_copy_bytes : t -> int Handler.actions -> unit - (** [on_copy_bytes t actions] configures the number of bytes to copy in each iteration. *) - - val set_copy_method : t -> copy_method -> unit - (** [set_copy_method t m] configures [t] to use the given method to read from - a source during a copy operation. *) -end - -(** Mock {!Eio.Net} networks and sockets. *) -module Net : sig - type t = [`Generic | `Mock] Eio.Net.ty r - - type listening_socket = [`Generic | `Mock] Eio.Net.listening_socket_ty r - - val make : string -> t - (** [make label] is a new mock network. *) - - val on_connect : t -> _ Eio.Net.stream_socket Handler.actions -> unit - (** [on_connect t actions] configures what to do when a client tries to connect somewhere. *) - - val on_listen : t -> _ Eio.Net.listening_socket Handler.actions -> unit - (** [on_listen t actions] configures what to do when a server starts listening for incoming connections. *) - - val on_datagram_socket : t -> _ Eio.Net.datagram_socket Handler.actions -> unit - (** [on_datagram_socket t actions] configures how to create datagram sockets. *) - - val on_getaddrinfo : t -> Eio.Net.Sockaddr.t list Handler.actions -> unit - - val on_getnameinfo : t -> (string * string) Handler.actions -> unit - - val listening_socket : - ?listening_addr:Eio.Net.Sockaddr.stream -> string -> listening_socket - (** [listening_socket label] can be configured to provide mock connections. - - If [listening_addr] is not provided, a dummy value will be reported. *) - - val on_accept : - listening_socket -> - (Flow.t * Eio.Net.Sockaddr.stream) Handler.actions -> - unit - (** [on_accept socket actions] configures how to respond when the server calls "accept". *) -end - -(** A mock {!Eio.Time} clock for testing timeouts. *) -module Clock = Clock - -(** A mock {!Eio.Domain_manager} that runs everything in a single domain. *) -module Domain_manager = Domain_manager - -(** {2 Backend for mocks} - - The mocks can be used with any backend, but if you don't need any IO then you can use this one - to avoid a dependency on eio_main. *) - -module Backend = Backend - -(** {2 Mock errors} *) - -type Eio.Exn.Backend.t += Simulated_failure -(** A fake error code you can use for simulated faults. *) +(** Mocks for testing. + + When testing an Eio program it is often convenient to use mock resources rather than real OS-provided ones. + This allows precise control over the test, such as adding delays or simulated faults. + You can always just implement the various Eio types directly, + but this module provides some convenient pre-built mocks, and some helpers for creating your own mocks. + + Mocks typically use {!Eio.traceln} to record how they were used. + This output can be recorded and compared against a known-good copy using e.g. + {{:https://github.com/realworldocaml/mdx}ocaml-mdx}. + + Mocks may require configuration. + For example, a source flow needs to know what data to return when the application reads from it. + This can be done using the various [on_*] functions. For example: + + {[ + let stdin = Eio_mock.Flow.make "stdin" in + let stdout = Eio_mock.Flow.make "stdout" in + Eio_mock.Flow.on_read stdin [ + `Return "chunk1"; + `Return "chunk2"; + `Raise End_of_file + ]; + Eio.Flow.copy stdin stdout + ]} + + This will produce: + + {[ + +stdin: read "chunk1" + +stdout: wrote "chunk1" + +stdin: read "chunk2" + +stdout: wrote "chunk2" + ]} +*) + +open Eio.Std + +(** {2 Configuration} *) + +(** Actions that can be performed by mock handlers. *) +module Action : sig + type 'a t = [ + | `Return of 'a (** Immediately return a value *) + | `Raise of exn (** Raise an exception *) + | `Await of 'a Eio.Promise.or_exn (** Wait for a promise to resolve *) + | `Yield_then of 'a t (** Call {!Eio.Fiber.yield}, then perform an action *) + | `Run of unit -> 'a (** Run any code you like. *) + ] + + val run : 'a t -> 'a + (** [run t] performs action [t] and returns the result. *) + + val map : ('a -> 'b) -> 'a t -> 'b t + (** [run (map f t) = f (run t)]. *) +end + +(** Control how a mock responds. + + This module is mostly useful when writing custom mocks. + Individual mocks usually provide convenience wrappers around this. *) +module Handler : sig + type 'a t + (** A handler that provides values of type ['a]. *) + + type 'a actions = 'a Action.t list + + val make : 'a Action.t -> 'a t + (** [make default_action] is a new handler that initially always runs [default_action]. *) + + val set_handler : 'a t -> (unit -> 'a) -> unit + (** [set_handler t fn] sets (replaces) the function to be called whenever the handler is run. *) + + val seq : 'a t -> 'a actions -> unit + (** [seq t actions] sets a handler function that performs the next action in [actions] on each call. + When there are no more actions, it runs the default handler. *) + + val run : 'a t -> 'a + (** [run t] is used by mocks to run their handlers. *) + + val run_default_action : 'a t -> 'a + (** [run_default_action t] runs the default handler passed to {!make}. *) +end + +(** {2 Pre-defined mocks} *) + +(** Mock {!Eio.Flow} sources and sinks. *) +module Flow : sig + type copy_method = [ + | `Read_into (** Use the source's [read_into] method (the default). *) + | `Read_source_buffer (** Use the {!Eio.Flow.Read_source_buffer} optimisation. *) + ] + + type ty = [`Generic | `Mock] Eio.Net.stream_socket_ty + type t = ty r + + val make : ?pp:string Fmt.t -> string -> t + (** [make label] is a mock Eio flow. + It can be used as a source, sink, or two-way flow. + @param pp Printer to use to display the data. *) + + val on_read : t -> string Handler.actions -> unit + (** [on_read t actions] configures the values to return from the mock's [read] function. *) + + val on_copy_bytes : t -> int Handler.actions -> unit + (** [on_copy_bytes t actions] configures the number of bytes to copy in each iteration. *) + + val set_copy_method : t -> copy_method -> unit + (** [set_copy_method t m] configures [t] to use the given method to read from + a source during a copy operation. *) +end + +(** Mock {!Eio.Net} networks and sockets. *) +module Net : sig + type t = [`Generic | `Mock] Eio.Net.ty r + + type listening_socket = [`Generic | `Mock] Eio.Net.listening_socket_ty r + + val make : string -> t + (** [make label] is a new mock network. *) + + val on_connect : t -> _ Eio.Net.stream_socket Handler.actions -> unit + (** [on_connect t actions] configures what to do when a client tries to connect somewhere. *) + + val on_listen : t -> _ Eio.Net.listening_socket Handler.actions -> unit + (** [on_listen t actions] configures what to do when a server starts listening for incoming connections. *) + + val on_datagram_socket : t -> _ Eio.Net.datagram_socket Handler.actions -> unit + (** [on_datagram_socket t actions] configures how to create datagram sockets. *) + + val on_getaddrinfo : t -> Eio.Net.Sockaddr.t list Handler.actions -> unit + + val on_getnameinfo : t -> (string * string) Handler.actions -> unit + + val listening_socket : + ?listening_addr:Eio.Net.Sockaddr.stream -> string -> listening_socket + (** [listening_socket label] can be configured to provide mock connections. + + If [listening_addr] is not provided, a dummy value will be reported. *) + + val on_accept : + listening_socket -> + (Flow.t * Eio.Net.Sockaddr.stream) Handler.actions -> + unit + (** [on_accept socket actions] configures how to respond when the server calls "accept". *) +end + +(** A mock {!Eio.Time} clock for testing timeouts. *) +module Clock = Clock + +(** A mock {!Eio.Domain_manager} that runs everything in a single domain. *) +module Domain_manager = Domain_manager + +(** {2 Backend for mocks} + + The mocks can be used with any backend, but if you don't need any IO then you can use this one + to avoid a dependency on eio_main. *) + +module Backend = Backend + +(** {2 Mock errors} *) + +type Eio.Exn.Backend.t += Simulated_failure +(** A fake error code you can use for simulated faults. *) diff --git a/lib_eio/mock/flow.ml b/lib_eio/mock/flow.ml index 7ca0bd89f..18952d1dc 100644 --- a/lib_eio/mock/flow.ml +++ b/lib_eio/mock/flow.ml @@ -1,144 +1,144 @@ -open Eio.Std - -type copy_method = [ - | `Read_into - | `Read_source_buffer -] - -module Mock_flow = struct - type tag = [`Generic | `Mock] - - type t = { - label : string; - pp : string Fmt.t; - on_close : (unit -> unit) Queue.t; - on_read : string Handler.t; - on_copy_bytes : int Handler.t; - mutable copy_method : copy_method; - } - - let pp_default f s = - let rec aux i = - let nl = - match String.index_from_opt s i '\n' with - | None -> String.length s - | Some x -> x + 1 - in - Fmt.Dump.string f (String.sub s i (nl - i)); - if nl < String.length s then ( - Fmt.cut f (); - aux nl - ) - in - aux 0 - - let rec takev len = function - | [] -> [] - | x :: _ when Cstruct.length x >= len -> [Cstruct.sub x 0 len] - | x :: xs -> x :: takev (len - Cstruct.length x) xs - - let write ~pp t bufs = - let size = Handler.run t.on_copy_bytes in - let len = min (Cstruct.lenv bufs) size in - let bufs = takev len bufs in - traceln "%s: wrote %a" t.label pp bufs; - len - - let single_write t bufs = - let pp f = function - | [buf] -> Fmt.pf f "@[%a@]" t.pp (Cstruct.to_string buf) - | bufs -> Fmt.pf f "@[%a@]" (Fmt.Dump.list (Fmt.using Cstruct.to_string t.pp)) bufs - in - write ~pp t bufs - - let copy_rsb_iovec t bufs = - let pp f bufs = Fmt.pf f "(rsb) @[%a@]" (Fmt.Dump.list (Fmt.using Cstruct.to_string t.pp)) bufs in - write ~pp t bufs - - (* Test optimised copying using Read_source_buffer *) - let copy_rsb t rsb = - try while true do rsb (copy_rsb_iovec t) done - with End_of_file -> () - - (* Test fallback copy using buffer. *) - let copy_via_buffer t src = - try - while true do - let size = Handler.run t.on_copy_bytes in - let buf = Cstruct.create size in - let n = Eio.Flow.single_read src buf in - traceln "%s: wrote @[%a@]" t.label t.pp (Cstruct.to_string (Cstruct.sub buf 0 n)) - done - with End_of_file -> () - - let read_methods = [] - - let single_read t buf = - let data = Handler.run t.on_read in - let len = String.length data in - if Cstruct.length buf < len then - Fmt.failwith "%s: read buffer too short for %a!" t.label t.pp data; - Cstruct.blit_from_string data 0 buf 0 len; - traceln "%s: read @[%a@]" t.label t.pp data; - len - - let copy t ~src = - match t.copy_method with - | `Read_into -> copy_via_buffer t src - | `Read_source_buffer -> - let Eio.Resource.T (src, ops) = src in - let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in - let try_rsb = function - | Eio.Flow.Read_source_buffer rsb -> copy_rsb t (rsb src); true - | _ -> false - in - if not (List.exists try_rsb Src.read_methods) then - Fmt.failwith "Source does not offer Read_source_buffer optimisation" - - let shutdown t cmd = - traceln "%s: shutdown %s" t.label @@ - match cmd with - | `Receive -> "receive" - | `Send -> "send" - | `All -> "all" - - let close t = - while not (Queue.is_empty t.on_close) do - Queue.take t.on_close () - done; - traceln "%s: closed" t.label - - let make ?(pp=pp_default) label = - { - pp; - label; - on_close = Queue.create (); - on_read = Handler.make (`Raise End_of_file); - on_copy_bytes = Handler.make (`Return 4096); - copy_method = `Read_into; - } -end - -type ty = [`Generic | `Mock] Eio.Net.stream_socket_ty - -type t = ty r - -type (_, _, _) Eio.Resource.pi += Type : ('t, 't -> Mock_flow.t, ty) Eio.Resource.pi -let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Type t - -let attach_to_switch t sw = - let t = raw t in - let hook = Switch.on_release_cancellable sw (fun () -> Mock_flow.close t) in - Queue.add (fun () -> Eio.Switch.remove_hook hook) t.on_close - -let on_read t = Handler.seq (raw t).on_read -let on_copy_bytes t = Handler.seq (raw t).on_copy_bytes -let set_copy_method t v = (raw t).copy_method <- v - -let handler = Eio.Resource.handler ( - H (Type, Fun.id) :: - Eio.Resource.bindings (Eio.Net.Pi.stream_socket (module Mock_flow)) - ) - -let make ?pp label : t = - Eio.Resource.T (Mock_flow.make ?pp label, handler) +open Eio.Std + +type copy_method = [ + | `Read_into + | `Read_source_buffer +] + +module Mock_flow = struct + type tag = [`Generic | `Mock] + + type t = { + label : string; + pp : string Fmt.t; + on_close : (unit -> unit) Queue.t; + on_read : string Handler.t; + on_copy_bytes : int Handler.t; + mutable copy_method : copy_method; + } + + let pp_default f s = + let rec aux i = + let nl = + match String.index_from_opt s i '\n' with + | None -> String.length s + | Some x -> x + 1 + in + Fmt.Dump.string f (String.sub s i (nl - i)); + if nl < String.length s then ( + Fmt.cut f (); + aux nl + ) + in + aux 0 + + let rec takev len = function + | [] -> [] + | x :: _ when Cstruct.length x >= len -> [Cstruct.sub x 0 len] + | x :: xs -> x :: takev (len - Cstruct.length x) xs + + let write ~pp t bufs = + let size = Handler.run t.on_copy_bytes in + let len = min (Cstruct.lenv bufs) size in + let bufs = takev len bufs in + traceln "%s: wrote %a" t.label pp bufs; + len + + let single_write t bufs = + let pp f = function + | [buf] -> Fmt.pf f "@[%a@]" t.pp (Cstruct.to_string buf) + | bufs -> Fmt.pf f "@[%a@]" (Fmt.Dump.list (Fmt.using Cstruct.to_string t.pp)) bufs + in + write ~pp t bufs + + let copy_rsb_iovec t bufs = + let pp f bufs = Fmt.pf f "(rsb) @[%a@]" (Fmt.Dump.list (Fmt.using Cstruct.to_string t.pp)) bufs in + write ~pp t bufs + + (* Test optimised copying using Read_source_buffer *) + let copy_rsb t rsb = + try while true do rsb (copy_rsb_iovec t) done + with End_of_file -> () + + (* Test fallback copy using buffer. *) + let copy_via_buffer t src = + try + while true do + let size = Handler.run t.on_copy_bytes in + let buf = Cstruct.create size in + let n = Eio.Flow.single_read src buf in + traceln "%s: wrote @[%a@]" t.label t.pp (Cstruct.to_string (Cstruct.sub buf 0 n)) + done + with End_of_file -> () + + let read_methods = [] + + let single_read t buf = + let data = Handler.run t.on_read in + let len = String.length data in + if Cstruct.length buf < len then + Fmt.failwith "%s: read buffer too short for %a!" t.label t.pp data; + Cstruct.blit_from_string data 0 buf 0 len; + traceln "%s: read @[%a@]" t.label t.pp data; + len + + let copy t ~src = + match t.copy_method with + | `Read_into -> copy_via_buffer t src + | `Read_source_buffer -> + let Eio.Resource.T (src, ops) = src in + let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in + let try_rsb = function + | Eio.Flow.Read_source_buffer rsb -> copy_rsb t (rsb src); true + | _ -> false + in + if not (List.exists try_rsb Src.read_methods) then + Fmt.failwith "Source does not offer Read_source_buffer optimisation" + + let shutdown t cmd = + traceln "%s: shutdown %s" t.label @@ + match cmd with + | `Receive -> "receive" + | `Send -> "send" + | `All -> "all" + + let close t = + while not (Queue.is_empty t.on_close) do + Queue.take t.on_close () + done; + traceln "%s: closed" t.label + + let make ?(pp=pp_default) label = + { + pp; + label; + on_close = Queue.create (); + on_read = Handler.make (`Raise End_of_file); + on_copy_bytes = Handler.make (`Return 4096); + copy_method = `Read_into; + } +end + +type ty = [`Generic | `Mock] Eio.Net.stream_socket_ty + +type t = ty r + +type (_, _, _) Eio.Resource.pi += Type : ('t, 't -> Mock_flow.t, ty) Eio.Resource.pi +let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Type t + +let attach_to_switch t sw = + let t = raw t in + let hook = Switch.on_release_cancellable sw (fun () -> Mock_flow.close t) in + Queue.add (fun () -> Eio.Switch.remove_hook hook) t.on_close + +let on_read t = Handler.seq (raw t).on_read +let on_copy_bytes t = Handler.seq (raw t).on_copy_bytes +let set_copy_method t v = (raw t).copy_method <- v + +let handler = Eio.Resource.handler ( + H (Type, Fun.id) :: + Eio.Resource.bindings (Eio.Net.Pi.stream_socket (module Mock_flow)) + ) + +let make ?pp label : t = + Eio.Resource.T (Mock_flow.make ?pp label, handler) diff --git a/lib_eio/mock/handler.ml b/lib_eio/mock/handler.ml index d0ac129be..05e3e7c57 100644 --- a/lib_eio/mock/handler.ml +++ b/lib_eio/mock/handler.ml @@ -1,27 +1,27 @@ -type 'a actions = 'a Action.t list - -type 'a t = { - default_action : 'a Action.t; - mutable handler : (unit -> 'a); -} - -let run t = t.handler () - -let set_handler t f = t.handler <- f - -let seq t actions = - let actions = ref actions in - let next () = - match !actions with - | [] -> Action.run t.default_action - | x :: xs -> - actions := xs; - Action.run x - in - set_handler t next - -let run_default_action t = - Action.run t.default_action - -let make default_action = - { default_action; handler = (fun () -> Action.run default_action) } +type 'a actions = 'a Action.t list + +type 'a t = { + default_action : 'a Action.t; + mutable handler : (unit -> 'a); +} + +let run t = t.handler () + +let set_handler t f = t.handler <- f + +let seq t actions = + let actions = ref actions in + let next () = + match !actions with + | [] -> Action.run t.default_action + | x :: xs -> + actions := xs; + Action.run x + in + set_handler t next + +let run_default_action t = + Action.run t.default_action + +let make default_action = + { default_action; handler = (fun () -> Action.run default_action) } diff --git a/lib_eio/mock/net.ml b/lib_eio/mock/net.ml index 933791ef2..9784deba4 100644 --- a/lib_eio/mock/net.ml +++ b/lib_eio/mock/net.ml @@ -1,142 +1,142 @@ -open Eio.Std - -type ty = [`Generic | `Mock] Eio.Net.ty -type t = ty r - -module Impl = struct - type tag = [`Generic] - - type t = { - label : string; - on_listen : tag Eio.Net.listening_socket_ty r Handler.t; - on_connect : tag Eio.Net.stream_socket_ty r Handler.t; - on_datagram_socket : tag Eio.Net.datagram_socket_ty r Handler.t; - on_getaddrinfo : Eio.Net.Sockaddr.t list Handler.t; - on_getnameinfo : (string * string) Handler.t; - } - - let make label = { - label; - on_listen = Handler.make (`Raise (Failure "Mock listen handler not configured")); - on_connect = Handler.make (`Raise (Failure "Mock connect handler not configured")); - on_datagram_socket = Handler.make (`Raise (Failure "Mock datagram_socket handler not configured")); - on_getaddrinfo = Handler.make (`Raise (Failure "Mock getaddrinfo handler not configured")); - on_getnameinfo = Handler.make (`Raise (Failure "Mock getnameinfo handler not configured")); - } - - let on_listen t = t.on_listen - let on_connect t = t.on_connect - let on_datagram_socket t = t.on_datagram_socket - let on_getaddrinfo t = t.on_getaddrinfo - let on_getnameinfo t = t.on_getnameinfo - - let listen t ~reuse_addr:_ ~reuse_port:_ ~backlog:_ ~sw addr = - traceln "%s: listen on %a" t.label Eio.Net.Sockaddr.pp addr; - let socket = Handler.run t.on_listen in - Switch.on_release sw (fun () -> Eio.Resource.close socket); - socket - - let connect t ~sw addr = - traceln "%s: connect to %a" t.label Eio.Net.Sockaddr.pp addr; - let socket = Handler.run t.on_connect in - Switch.on_release sw (fun () -> Eio.Flow.close socket); - socket - - let datagram_socket t ~reuse_addr:_ ~reuse_port:_ ~sw addr = - (match addr with - | #Eio.Net.Sockaddr.datagram as saddr -> traceln "%s: datagram_socket %a" t.label Eio.Net.Sockaddr.pp saddr - | `UdpV4 -> traceln "%s: datagram_socket UDPv4" t.label - | `UdpV6 -> traceln "%s: datagram_socket UDPv6" t.label - ); - let socket = Handler.run t.on_datagram_socket in - Switch.on_release sw (fun () -> Eio.Flow.close socket); - socket - - let getaddrinfo t ~service node = - traceln "%s: getaddrinfo ~service:%s %s" t.label service node; - Handler.run t.on_getaddrinfo - - let getnameinfo t sockaddr = - traceln "%s: getnameinfo %a" t.label Eio.Net.Sockaddr.pp sockaddr; - Handler.run t.on_getnameinfo - - type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, ty) Eio.Resource.pi - let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t -end - -let make : string -> t = - let super = Eio.Net.Pi.network (module Impl) in - let handler = Eio.Resource.handler ( - H (Impl.Raw, Fun.id) :: - Eio.Resource.bindings super - ) in - fun label -> Eio.Resource.T (Impl.make label, handler) - -let on_connect (t:t) actions = - let t = Impl.raw t in - let as_socket x = (x :> [`Generic] Eio.Net.stream_socket_ty r) in - Handler.seq t.on_connect (List.map (Action.map as_socket) actions) - -let on_listen (t:t) actions = - let t = Impl.raw t in - let as_socket x = (x :> [`Generic] Eio.Net.listening_socket_ty r) in - Handler.seq t.on_listen (List.map (Action.map as_socket) actions) - -let on_datagram_socket (t:t) (actions : _ r Handler.actions) = - let t = Impl.raw t in - let as_socket x = (x :> [`Generic] Eio.Net.datagram_socket_ty r) in - Handler.seq t.on_datagram_socket (List.map (Action.map as_socket) actions) - -let on_getaddrinfo (t:t) actions = Handler.seq (Impl.raw t).on_getaddrinfo actions - -let on_getnameinfo (t:t) actions = Handler.seq (Impl.raw t).on_getnameinfo actions - -type listening_socket_ty = [`Generic | `Mock] Eio.Net.listening_socket_ty -type listening_socket = listening_socket_ty r - -module Listening_socket = struct - type t = { - label : string; - listening_addr : Eio.Net.Sockaddr.stream; - on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t; - } - - type tag = [`Generic] - - let make ?(listening_addr = `Tcp (Eio.Net.Ipaddr.V4.any, 0)) label = - { - label; - listening_addr; - on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured")) - } - - let on_accept t = t.on_accept - - let accept t ~sw = - let socket, addr = Handler.run t.on_accept in - Flow.attach_to_switch (socket : Flow.t) sw; - traceln "%s: accepted connection from %a" t.label Eio.Net.Sockaddr.pp addr; - (socket :> tag Eio.Net.stream_socket_ty r), addr - - let close t = - traceln "%s: closed" t.label - - let listening_addr { listening_addr; _ } = listening_addr - - type (_, _, _) Eio.Resource.pi += Type : ('t, 't -> t, listening_socket_ty) Eio.Resource.pi - let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Type t -end - -let listening_socket_handler = - Eio.Resource.handler @@ - Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module Listening_socket)) @ [ - H (Listening_socket.Type, Fun.id); - ] - -let listening_socket ?listening_addr label : listening_socket = - Eio.Resource.T (Listening_socket.make ?listening_addr label, listening_socket_handler) - -let on_accept l actions = - let r = Listening_socket.raw l in - let as_accept_pair x = (x :> Flow.t * Eio.Net.Sockaddr.stream) in - Handler.seq r.on_accept (List.map (Action.map as_accept_pair) actions) +open Eio.Std + +type ty = [`Generic | `Mock] Eio.Net.ty +type t = ty r + +module Impl = struct + type tag = [`Generic] + + type t = { + label : string; + on_listen : tag Eio.Net.listening_socket_ty r Handler.t; + on_connect : tag Eio.Net.stream_socket_ty r Handler.t; + on_datagram_socket : tag Eio.Net.datagram_socket_ty r Handler.t; + on_getaddrinfo : Eio.Net.Sockaddr.t list Handler.t; + on_getnameinfo : (string * string) Handler.t; + } + + let make label = { + label; + on_listen = Handler.make (`Raise (Failure "Mock listen handler not configured")); + on_connect = Handler.make (`Raise (Failure "Mock connect handler not configured")); + on_datagram_socket = Handler.make (`Raise (Failure "Mock datagram_socket handler not configured")); + on_getaddrinfo = Handler.make (`Raise (Failure "Mock getaddrinfo handler not configured")); + on_getnameinfo = Handler.make (`Raise (Failure "Mock getnameinfo handler not configured")); + } + + let on_listen t = t.on_listen + let on_connect t = t.on_connect + let on_datagram_socket t = t.on_datagram_socket + let on_getaddrinfo t = t.on_getaddrinfo + let on_getnameinfo t = t.on_getnameinfo + + let listen t ~reuse_addr:_ ~reuse_port:_ ~backlog:_ ~sw addr = + traceln "%s: listen on %a" t.label Eio.Net.Sockaddr.pp addr; + let socket = Handler.run t.on_listen in + Switch.on_release sw (fun () -> Eio.Resource.close socket); + socket + + let connect t ~sw addr = + traceln "%s: connect to %a" t.label Eio.Net.Sockaddr.pp addr; + let socket = Handler.run t.on_connect in + Switch.on_release sw (fun () -> Eio.Flow.close socket); + socket + + let datagram_socket t ~reuse_addr:_ ~reuse_port:_ ~sw addr = + (match addr with + | #Eio.Net.Sockaddr.datagram as saddr -> traceln "%s: datagram_socket %a" t.label Eio.Net.Sockaddr.pp saddr + | `UdpV4 -> traceln "%s: datagram_socket UDPv4" t.label + | `UdpV6 -> traceln "%s: datagram_socket UDPv6" t.label + ); + let socket = Handler.run t.on_datagram_socket in + Switch.on_release sw (fun () -> Eio.Flow.close socket); + socket + + let getaddrinfo t ~service node = + traceln "%s: getaddrinfo ~service:%s %s" t.label service node; + Handler.run t.on_getaddrinfo + + let getnameinfo t sockaddr = + traceln "%s: getnameinfo %a" t.label Eio.Net.Sockaddr.pp sockaddr; + Handler.run t.on_getnameinfo + + type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, ty) Eio.Resource.pi + let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t +end + +let make : string -> t = + let super = Eio.Net.Pi.network (module Impl) in + let handler = Eio.Resource.handler ( + H (Impl.Raw, Fun.id) :: + Eio.Resource.bindings super + ) in + fun label -> Eio.Resource.T (Impl.make label, handler) + +let on_connect (t:t) actions = + let t = Impl.raw t in + let as_socket x = (x :> [`Generic] Eio.Net.stream_socket_ty r) in + Handler.seq t.on_connect (List.map (Action.map as_socket) actions) + +let on_listen (t:t) actions = + let t = Impl.raw t in + let as_socket x = (x :> [`Generic] Eio.Net.listening_socket_ty r) in + Handler.seq t.on_listen (List.map (Action.map as_socket) actions) + +let on_datagram_socket (t:t) (actions : _ r Handler.actions) = + let t = Impl.raw t in + let as_socket x = (x :> [`Generic] Eio.Net.datagram_socket_ty r) in + Handler.seq t.on_datagram_socket (List.map (Action.map as_socket) actions) + +let on_getaddrinfo (t:t) actions = Handler.seq (Impl.raw t).on_getaddrinfo actions + +let on_getnameinfo (t:t) actions = Handler.seq (Impl.raw t).on_getnameinfo actions + +type listening_socket_ty = [`Generic | `Mock] Eio.Net.listening_socket_ty +type listening_socket = listening_socket_ty r + +module Listening_socket = struct + type t = { + label : string; + listening_addr : Eio.Net.Sockaddr.stream; + on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t; + } + + type tag = [`Generic] + + let make ?(listening_addr = `Tcp (Eio.Net.Ipaddr.V4.any, 0)) label = + { + label; + listening_addr; + on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured")) + } + + let on_accept t = t.on_accept + + let accept t ~sw = + let socket, addr = Handler.run t.on_accept in + Flow.attach_to_switch (socket : Flow.t) sw; + traceln "%s: accepted connection from %a" t.label Eio.Net.Sockaddr.pp addr; + (socket :> tag Eio.Net.stream_socket_ty r), addr + + let close t = + traceln "%s: closed" t.label + + let listening_addr { listening_addr; _ } = listening_addr + + type (_, _, _) Eio.Resource.pi += Type : ('t, 't -> t, listening_socket_ty) Eio.Resource.pi + let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Type t +end + +let listening_socket_handler = + Eio.Resource.handler @@ + Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module Listening_socket)) @ [ + H (Listening_socket.Type, Fun.id); + ] + +let listening_socket ?listening_addr label : listening_socket = + Eio.Resource.T (Listening_socket.make ?listening_addr label, listening_socket_handler) + +let on_accept l actions = + let r = Listening_socket.raw l in + let as_accept_pair x = (x :> Flow.t * Eio.Net.Sockaddr.stream) in + Handler.seq r.on_accept (List.map (Action.map as_accept_pair) actions) diff --git a/lib_eio/net.ml b/lib_eio/net.ml index 3dffe2c4a..e6ccd9072 100644 --- a/lib_eio/net.ml +++ b/lib_eio/net.ml @@ -1,390 +1,390 @@ -open Std - -type connection_failure = - | Refused of Exn.Backend.t - | No_matching_addresses - | Timeout - -type error = - | Connection_reset of Exn.Backend.t - | Connection_failure of connection_failure - -type Exn.err += E of error - -let err e = Exn.create (E e) - -let () = - Exn.register_pp (fun f -> function - | E e -> - Fmt.string f "Net "; - begin match e with - | Connection_reset e -> Fmt.pf f "Connection_reset %a" Exn.Backend.pp e - | Connection_failure Refused e -> Fmt.pf f "Connection_failure Refused %a" Exn.Backend.pp e - | Connection_failure Timeout -> Fmt.pf f "Connection_failure Timeout" - | Connection_failure No_matching_addresses -> Fmt.pf f "Connection_failure No_matching_addresses" - end; - true - | _ -> false - ) - -module Ipaddr = struct - type 'a t = string (* = [Unix.inet_addr], but avoid a Unix dependency here *) - - module V4 = struct - let any = "\000\000\000\000" - let loopback = "\127\000\000\001" - - let pp f t = - Fmt.pf f "%d.%d.%d.%d" - (Char.code t.[0]) - (Char.code t.[1]) - (Char.code t.[2]) - (Char.code t.[3]) - end - - module V6 = struct - let any = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" - let loopback = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001" - - let to_int16 t = - let get i = Char.code (t.[i]) in - let pair i = (get i lsl 8) lor (get (i + 1)) in - List.init 8 (fun i -> pair (i * 2)) - - (* [calc_elide elide zeros acc parts] finds the best place for the "::" - when printing an IPv6 address. - Returns [None, rev t] if there are no pairs of zeros, or - [Some (-n), rev t'] where [n] is the length of the longest run of zeros - and [t'] is [t] with all runs of zeroes replaced with [-len_run]. *) - let calc_elide t = - (* [elide] is the negative of the length of the best previous run of zeros seen. - [zeros] is the current run. - [acc] is the values seen so far, with runs of zeros replaced by a - negative value giving the length of the run. *) - let rec loop elide zeros acc = function - | 0 :: xs -> loop elide (zeros - 1) acc xs - | n :: xs when zeros = 0 -> loop elide 0 (n :: acc) xs - | n :: xs -> loop (min elide zeros) 0 (n :: zeros :: acc) xs - | [] -> - let elide = min elide zeros in - let parts = if zeros = 0 then acc else zeros :: acc in - ((if elide < -1 then Some elide else None), List.rev parts) - - in - loop 0 0 [] t - - let rec cons_zeros l x = - if x >= 0 then l else cons_zeros (Some 0 :: l) (x + 1) - - let elide l = - let rec aux ~elide = function - | [] -> [] - | x :: xs when x >= 0 -> - Some x :: aux ~elide xs - | x :: xs when Some x = elide -> - None :: aux ~elide:None xs - | z :: xs -> - cons_zeros (aux ~elide xs) z - in - let elide, l = calc_elide l in - assert (match elide with Some x when x < -8 -> false | _ -> true); - aux ~elide l - - (* Based on https://github.com/mirage/ocaml-ipaddr/ - See http://tools.ietf.org/html/rfc5952 *) - let pp f t = - let comp = to_int16 t in - let v4 = match comp with [0; 0; 0; 0; 0; 0xffff; _; _] -> true | _ -> false in - let l = elide comp in - let rec fill = function - | [ Some hi; Some lo ] when v4 -> - Fmt.pf f "%d.%d.%d.%d" - (hi lsr 8) (hi land 0xff) - (lo lsr 8) (lo land 0xff) - | None :: xs -> - Fmt.string f "::"; - fill xs - | [ Some n ] -> Fmt.pf f "%x" n - | Some n :: None :: xs -> - Fmt.pf f "%x::" n; - fill xs - | Some n :: xs -> - Fmt.pf f "%x:" n; - fill xs - | [] -> () - in - fill l - end - - type v4v6 = [`V4 | `V6] t - - let fold ~v4 ~v6 t = - match String.length t with - | 4 -> v4 t - | 16 -> v6 t - | _ -> assert false - - let of_raw t = - match String.length t with - | 4 | 16 -> t - | x -> Fmt.invalid_arg "An IP address must be either 4 or 16 bytes long (%S is %d bytes)" t x - - let pp f = fold ~v4:(V4.pp f) ~v6:(V6.pp f) - - let pp_for_uri f = - fold - ~v4:(V4.pp f) - ~v6:(Fmt.pf f "[%a]" V6.pp) -end - -module Sockaddr = struct - type stream = [ - | `Unix of string - | `Tcp of Ipaddr.v4v6 * int - ] - - type datagram = [ - | `Udp of Ipaddr.v4v6 * int - | `Unix of string - ] - - type t = [ stream | datagram ] - - let pp f = function - | `Unix path -> - Format.fprintf f "unix:%s" path - | `Tcp (addr, port) -> - Format.fprintf f "tcp:%a:%d" Ipaddr.pp_for_uri addr port - | `Udp (addr, port) -> - Format.fprintf f "udp:%a:%d" Ipaddr.pp_for_uri addr port -end - -type socket_ty = [`Socket | `Close] -type 'a socket = ([> socket_ty] as 'a) r - -type 'tag stream_socket_ty = [`Stream | `Platform of 'tag | `Shutdown | socket_ty | Flow.source_ty | Flow.sink_ty] -type 'a stream_socket = 'a r - constraint 'a = [> [> `Generic] stream_socket_ty] - -type 'tag listening_socket_ty = [ `Accept | `Platform of 'tag | socket_ty] -type 'a listening_socket = 'a r - constraint 'a = [> [> `Generic] listening_socket_ty] - -type 'a connection_handler = 'a stream_socket -> Sockaddr.stream -> unit - -type 'tag datagram_socket_ty = [`Datagram | `Platform of 'tag | `Shutdown | socket_ty] -type 'a datagram_socket = 'a r - constraint 'a = [> [> `Generic] datagram_socket_ty] - -type 'tag ty = [`Network | `Platform of 'tag] -type 'a t = 'a r - constraint 'a = [> [> `Generic] ty] - -module Pi = struct - module type STREAM_SOCKET = sig - type tag - include Flow.Pi.SHUTDOWN - include Flow.Pi.SOURCE with type t := t - include Flow.Pi.SINK with type t := t - val close : t -> unit - end - - let stream_socket (type t tag) (module X : STREAM_SOCKET with type t = t and type tag = tag) = - Resource.handler @@ - H (Resource.Close, X.close) :: - Resource.bindings (Flow.Pi.two_way (module X)) - - module type DATAGRAM_SOCKET = sig - type tag - include Flow.Pi.SHUTDOWN - val send : t -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit - val recv : t -> Cstruct.t -> Sockaddr.datagram * int - val close : t -> unit - end - - type (_, _, _) Resource.pi += - | Datagram_socket : ('t, (module DATAGRAM_SOCKET with type t = 't), [> _ datagram_socket_ty]) Resource.pi - - let datagram_socket (type t tag) (module X : DATAGRAM_SOCKET with type t = t and type tag = tag) = - Resource.handler @@ - Resource.bindings (Flow.Pi.shutdown (module X)) @ [ - H (Datagram_socket, (module X)); - H (Resource.Close, X.close) - ] - - module type LISTENING_SOCKET = sig - type t - type tag - - val accept : t -> sw:Switch.t -> tag stream_socket_ty r * Sockaddr.stream - val close : t -> unit - val listening_addr : t -> Sockaddr.stream - end - - type (_, _, _) Resource.pi += - | Listening_socket : ('t, (module LISTENING_SOCKET with type t = 't and type tag = 'tag), [> 'tag listening_socket_ty]) Resource.pi - - let listening_socket (type t tag) (module X : LISTENING_SOCKET with type t = t and type tag = tag) = - Resource.handler [ - H (Resource.Close, X.close); - H (Listening_socket, (module X)) - ] - - module type NETWORK = sig - type t - type tag - - val listen : t -> reuse_addr:bool -> reuse_port:bool -> backlog:int -> sw:Switch.t -> Sockaddr.stream -> tag listening_socket_ty r - val connect : t -> sw:Switch.t -> Sockaddr.stream -> tag stream_socket_ty r - val datagram_socket : - t - -> reuse_addr:bool - -> reuse_port:bool - -> sw:Switch.t - -> [Sockaddr.datagram | `UdpV4 | `UdpV6] - -> tag datagram_socket_ty r - - val getaddrinfo : t -> service:string -> string -> Sockaddr.t list - val getnameinfo : t -> Sockaddr.t -> (string * string) - end - - type (_, _, _) Resource.pi += - | Network : ('t, (module NETWORK with type t = 't and type tag = 'tag), [> 'tag ty]) Resource.pi - - let network (type t tag) (module X : NETWORK with type t = t and type tag = tag) = - Resource.handler [ - H (Network, (module X)); - ] -end - -let accept ~sw (type tag) (Resource.T (t, ops) : [> tag listening_socket_ty] r) = - let module X = (val (Resource.get ops Pi.Listening_socket)) in - X.accept t ~sw - -let accept_fork ~sw (t : [> 'a listening_socket_ty] r) ~on_error handle = - let child_started = ref false in - let flow, addr = accept ~sw t in - Fun.protect ~finally:(fun () -> if !child_started = false then Flow.close flow) - (fun () -> - Fiber.fork ~sw (fun () -> - match child_started := true; handle (flow :> 'a stream_socket_ty r) addr with - | x -> Flow.close flow; x - | exception (Cancel.Cancelled _ as ex) -> - Flow.close flow; - raise ex - | exception ex -> - Flow.close flow; - on_error (Exn.add_context ex "handling connection from %a" Sockaddr.pp addr) - ) - ) - -let listening_addr (type tag) (Resource.T (t, ops) : [> tag listening_socket_ty] r) = - let module X = (val (Resource.get ops Pi.Listening_socket)) in - X.listening_addr t - -let send (Resource.T (t, ops)) ?dst bufs = - let module X = (val (Resource.get ops Pi.Datagram_socket)) in - X.send t ?dst bufs - -let recv (Resource.T (t, ops)) buf = - let module X = (val (Resource.get ops Pi.Datagram_socket)) in - X.recv t buf - -let listen (type tag) ?(reuse_addr=false) ?(reuse_port=false) ~backlog ~sw (t:[> tag ty] r) = - let (Resource.T (t, ops)) = t in - let module X = (val (Resource.get ops Pi.Network)) in - X.listen t ~reuse_addr ~reuse_port ~backlog ~sw - -let connect (type tag) ~sw (t:[> tag ty] r) addr = - let (Resource.T (t, ops)) = t in - let module X = (val (Resource.get ops Pi.Network)) in - try X.connect t ~sw addr - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "connecting to %a" Sockaddr.pp addr - -let datagram_socket (type tag) ?(reuse_addr=false) ?(reuse_port=false) ~sw (t:[> tag ty] r) addr = - let (Resource.T (t, ops)) = t in - let module X = (val (Resource.get ops Pi.Network)) in - let addr = (addr :> [Sockaddr.datagram | `UdpV4 | `UdpV6]) in - X.datagram_socket t ~reuse_addr ~reuse_port ~sw addr - -let getaddrinfo (type tag) ?(service="") (t:[> tag ty] r) hostname = - let (Resource.T (t, ops)) = t in - let module X = (val (Resource.get ops Pi.Network)) in - X.getaddrinfo t ~service hostname - -let getaddrinfo_stream ?service t hostname = - getaddrinfo ?service t hostname - |> List.filter_map (function - | #Sockaddr.stream as x -> Some x - | _ -> None - ) - -let getaddrinfo_datagram ?service t hostname = - getaddrinfo ?service t hostname - |> List.filter_map (function - | #Sockaddr.datagram as x -> Some x - | _ -> None - ) - -let getnameinfo (type tag) (t:[> tag ty] r) sockaddr = - let (Resource.T (t, ops)) = t in - let module X = (val (Resource.get ops Pi.Network)) in - X.getnameinfo t sockaddr - -let close = Resource.close - -let with_tcp_connect ?(timeout=Time.Timeout.none) ~host ~service t f = - Switch.run ~name:"with_tcp_connect" @@ fun sw -> - match - let rec aux = function - | [] -> raise @@ err (Connection_failure No_matching_addresses) - | addr :: addrs -> - try Time.Timeout.run_exn timeout (fun () -> connect ~sw t addr) with - | Time.Timeout | Exn.Io _ when addrs <> [] -> - aux addrs - | Time.Timeout -> - raise @@ err (Connection_failure Timeout) - in - getaddrinfo_stream ~service t host - |> List.filter_map (function - | `Tcp _ as x -> Some x - | `Unix _ -> None - ) - |> aux - with - | conn -> f conn - | exception (Exn.Io _ as ex) -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "connecting to %S:%s" host service - -(* Run a server loop in a single domain. *) -let run_server_loop ~sw ~connections ~on_error ~stop listening_socket connection_handler = - let rec accept () = - Semaphore.acquire connections; - accept_fork ~sw ~on_error listening_socket (fun conn addr -> - Fun.protect (fun () -> connection_handler conn addr) - ~finally:(fun () -> Semaphore.release connections) - ); - accept () - in - match stop with - | None -> accept () - | Some stop -> Fiber.first accept (fun () -> Promise.await stop) - -let run_server ?(max_connections=Int.max_int) ?(additional_domains) ?stop ~on_error listening_socket connection_handler : 'a = - if max_connections <= 0 then invalid_arg "max_connections"; - Switch.run ~name:"run_server" @@ fun sw -> - let connections = Semaphore.make max_connections in - let run_server_loop sw = run_server_loop ~sw ~connections ~on_error ~stop listening_socket connection_handler in - additional_domains |> Option.iter (fun (domain_mgr, domains) -> - if domains < 0 then invalid_arg "additional_domains"; - for _ = 1 to domains do - Fiber.fork ~sw (fun () -> Domain_manager.run domain_mgr (fun () -> - Switch.run ~name:"run_server" @@ fun sw -> - ignore (run_server_loop sw : 'a) - )) - done; - ); - run_server_loop sw +open Std + +type connection_failure = + | Refused of Exn.Backend.t + | No_matching_addresses + | Timeout + +type error = + | Connection_reset of Exn.Backend.t + | Connection_failure of connection_failure + +type Exn.err += E of error + +let err e = Exn.create (E e) + +let () = + Exn.register_pp (fun f -> function + | E e -> + Fmt.string f "Net "; + begin match e with + | Connection_reset e -> Fmt.pf f "Connection_reset %a" Exn.Backend.pp e + | Connection_failure Refused e -> Fmt.pf f "Connection_failure Refused %a" Exn.Backend.pp e + | Connection_failure Timeout -> Fmt.pf f "Connection_failure Timeout" + | Connection_failure No_matching_addresses -> Fmt.pf f "Connection_failure No_matching_addresses" + end; + true + | _ -> false + ) + +module Ipaddr = struct + type 'a t = string (* = [Unix.inet_addr], but avoid a Unix dependency here *) + + module V4 = struct + let any = "\000\000\000\000" + let loopback = "\127\000\000\001" + + let pp f t = + Fmt.pf f "%d.%d.%d.%d" + (Char.code t.[0]) + (Char.code t.[1]) + (Char.code t.[2]) + (Char.code t.[3]) + end + + module V6 = struct + let any = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" + let loopback = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001" + + let to_int16 t = + let get i = Char.code (t.[i]) in + let pair i = (get i lsl 8) lor (get (i + 1)) in + List.init 8 (fun i -> pair (i * 2)) + + (* [calc_elide elide zeros acc parts] finds the best place for the "::" + when printing an IPv6 address. + Returns [None, rev t] if there are no pairs of zeros, or + [Some (-n), rev t'] where [n] is the length of the longest run of zeros + and [t'] is [t] with all runs of zeroes replaced with [-len_run]. *) + let calc_elide t = + (* [elide] is the negative of the length of the best previous run of zeros seen. + [zeros] is the current run. + [acc] is the values seen so far, with runs of zeros replaced by a + negative value giving the length of the run. *) + let rec loop elide zeros acc = function + | 0 :: xs -> loop elide (zeros - 1) acc xs + | n :: xs when zeros = 0 -> loop elide 0 (n :: acc) xs + | n :: xs -> loop (min elide zeros) 0 (n :: zeros :: acc) xs + | [] -> + let elide = min elide zeros in + let parts = if zeros = 0 then acc else zeros :: acc in + ((if elide < -1 then Some elide else None), List.rev parts) + + in + loop 0 0 [] t + + let rec cons_zeros l x = + if x >= 0 then l else cons_zeros (Some 0 :: l) (x + 1) + + let elide l = + let rec aux ~elide = function + | [] -> [] + | x :: xs when x >= 0 -> + Some x :: aux ~elide xs + | x :: xs when Some x = elide -> + None :: aux ~elide:None xs + | z :: xs -> + cons_zeros (aux ~elide xs) z + in + let elide, l = calc_elide l in + assert (match elide with Some x when x < -8 -> false | _ -> true); + aux ~elide l + + (* Based on https://github.com/mirage/ocaml-ipaddr/ + See http://tools.ietf.org/html/rfc5952 *) + let pp f t = + let comp = to_int16 t in + let v4 = match comp with [0; 0; 0; 0; 0; 0xffff; _; _] -> true | _ -> false in + let l = elide comp in + let rec fill = function + | [ Some hi; Some lo ] when v4 -> + Fmt.pf f "%d.%d.%d.%d" + (hi lsr 8) (hi land 0xff) + (lo lsr 8) (lo land 0xff) + | None :: xs -> + Fmt.string f "::"; + fill xs + | [ Some n ] -> Fmt.pf f "%x" n + | Some n :: None :: xs -> + Fmt.pf f "%x::" n; + fill xs + | Some n :: xs -> + Fmt.pf f "%x:" n; + fill xs + | [] -> () + in + fill l + end + + type v4v6 = [`V4 | `V6] t + + let fold ~v4 ~v6 t = + match String.length t with + | 4 -> v4 t + | 16 -> v6 t + | _ -> assert false + + let of_raw t = + match String.length t with + | 4 | 16 -> t + | x -> Fmt.invalid_arg "An IP address must be either 4 or 16 bytes long (%S is %d bytes)" t x + + let pp f = fold ~v4:(V4.pp f) ~v6:(V6.pp f) + + let pp_for_uri f = + fold + ~v4:(V4.pp f) + ~v6:(Fmt.pf f "[%a]" V6.pp) +end + +module Sockaddr = struct + type stream = [ + | `Unix of string + | `Tcp of Ipaddr.v4v6 * int + ] + + type datagram = [ + | `Udp of Ipaddr.v4v6 * int + | `Unix of string + ] + + type t = [ stream | datagram ] + + let pp f = function + | `Unix path -> + Format.fprintf f "unix:%s" path + | `Tcp (addr, port) -> + Format.fprintf f "tcp:%a:%d" Ipaddr.pp_for_uri addr port + | `Udp (addr, port) -> + Format.fprintf f "udp:%a:%d" Ipaddr.pp_for_uri addr port +end + +type socket_ty = [`Socket | `Close] +type 'a socket = ([> socket_ty] as 'a) r + +type 'tag stream_socket_ty = [`Stream | `Platform of 'tag | `Shutdown | socket_ty | Flow.source_ty | Flow.sink_ty] +type 'a stream_socket = 'a r + constraint 'a = [> [> `Generic] stream_socket_ty] + +type 'tag listening_socket_ty = [ `Accept | `Platform of 'tag | socket_ty] +type 'a listening_socket = 'a r + constraint 'a = [> [> `Generic] listening_socket_ty] + +type 'a connection_handler = 'a stream_socket -> Sockaddr.stream -> unit + +type 'tag datagram_socket_ty = [`Datagram | `Platform of 'tag | `Shutdown | socket_ty] +type 'a datagram_socket = 'a r + constraint 'a = [> [> `Generic] datagram_socket_ty] + +type 'tag ty = [`Network | `Platform of 'tag] +type 'a t = 'a r + constraint 'a = [> [> `Generic] ty] + +module Pi = struct + module type STREAM_SOCKET = sig + type tag + include Flow.Pi.SHUTDOWN + include Flow.Pi.SOURCE with type t := t + include Flow.Pi.SINK with type t := t + val close : t -> unit + end + + let stream_socket (type t tag) (module X : STREAM_SOCKET with type t = t and type tag = tag) = + Resource.handler @@ + H (Resource.Close, X.close) :: + Resource.bindings (Flow.Pi.two_way (module X)) + + module type DATAGRAM_SOCKET = sig + type tag + include Flow.Pi.SHUTDOWN + val send : t -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit + val recv : t -> Cstruct.t -> Sockaddr.datagram * int + val close : t -> unit + end + + type (_, _, _) Resource.pi += + | Datagram_socket : ('t, (module DATAGRAM_SOCKET with type t = 't), [> _ datagram_socket_ty]) Resource.pi + + let datagram_socket (type t tag) (module X : DATAGRAM_SOCKET with type t = t and type tag = tag) = + Resource.handler @@ + Resource.bindings (Flow.Pi.shutdown (module X)) @ [ + H (Datagram_socket, (module X)); + H (Resource.Close, X.close) + ] + + module type LISTENING_SOCKET = sig + type t + type tag + + val accept : t -> sw:Switch.t -> tag stream_socket_ty r * Sockaddr.stream + val close : t -> unit + val listening_addr : t -> Sockaddr.stream + end + + type (_, _, _) Resource.pi += + | Listening_socket : ('t, (module LISTENING_SOCKET with type t = 't and type tag = 'tag), [> 'tag listening_socket_ty]) Resource.pi + + let listening_socket (type t tag) (module X : LISTENING_SOCKET with type t = t and type tag = tag) = + Resource.handler [ + H (Resource.Close, X.close); + H (Listening_socket, (module X)) + ] + + module type NETWORK = sig + type t + type tag + + val listen : t -> reuse_addr:bool -> reuse_port:bool -> backlog:int -> sw:Switch.t -> Sockaddr.stream -> tag listening_socket_ty r + val connect : t -> sw:Switch.t -> Sockaddr.stream -> tag stream_socket_ty r + val datagram_socket : + t + -> reuse_addr:bool + -> reuse_port:bool + -> sw:Switch.t + -> [Sockaddr.datagram | `UdpV4 | `UdpV6] + -> tag datagram_socket_ty r + + val getaddrinfo : t -> service:string -> string -> Sockaddr.t list + val getnameinfo : t -> Sockaddr.t -> (string * string) + end + + type (_, _, _) Resource.pi += + | Network : ('t, (module NETWORK with type t = 't and type tag = 'tag), [> 'tag ty]) Resource.pi + + let network (type t tag) (module X : NETWORK with type t = t and type tag = tag) = + Resource.handler [ + H (Network, (module X)); + ] +end + +let accept ~sw (type tag) (Resource.T (t, ops) : [> tag listening_socket_ty] r) = + let module X = (val (Resource.get ops Pi.Listening_socket)) in + X.accept t ~sw + +let accept_fork ~sw (t : [> 'a listening_socket_ty] r) ~on_error handle = + let child_started = ref false in + let flow, addr = accept ~sw t in + Fun.protect ~finally:(fun () -> if !child_started = false then Flow.close flow) + (fun () -> + Fiber.fork ~sw (fun () -> + match child_started := true; handle (flow :> 'a stream_socket_ty r) addr with + | x -> Flow.close flow; x + | exception (Cancel.Cancelled _ as ex) -> + Flow.close flow; + raise ex + | exception ex -> + Flow.close flow; + on_error (Exn.add_context ex "handling connection from %a" Sockaddr.pp addr) + ) + ) + +let listening_addr (type tag) (Resource.T (t, ops) : [> tag listening_socket_ty] r) = + let module X = (val (Resource.get ops Pi.Listening_socket)) in + X.listening_addr t + +let send (Resource.T (t, ops)) ?dst bufs = + let module X = (val (Resource.get ops Pi.Datagram_socket)) in + X.send t ?dst bufs + +let recv (Resource.T (t, ops)) buf = + let module X = (val (Resource.get ops Pi.Datagram_socket)) in + X.recv t buf + +let listen (type tag) ?(reuse_addr=false) ?(reuse_port=false) ~backlog ~sw (t:[> tag ty] r) = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in + X.listen t ~reuse_addr ~reuse_port ~backlog ~sw + +let connect (type tag) ~sw (t:[> tag ty] r) addr = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in + try X.connect t ~sw addr + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "connecting to %a" Sockaddr.pp addr + +let datagram_socket (type tag) ?(reuse_addr=false) ?(reuse_port=false) ~sw (t:[> tag ty] r) addr = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in + let addr = (addr :> [Sockaddr.datagram | `UdpV4 | `UdpV6]) in + X.datagram_socket t ~reuse_addr ~reuse_port ~sw addr + +let getaddrinfo (type tag) ?(service="") (t:[> tag ty] r) hostname = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in + X.getaddrinfo t ~service hostname + +let getaddrinfo_stream ?service t hostname = + getaddrinfo ?service t hostname + |> List.filter_map (function + | #Sockaddr.stream as x -> Some x + | _ -> None + ) + +let getaddrinfo_datagram ?service t hostname = + getaddrinfo ?service t hostname + |> List.filter_map (function + | #Sockaddr.datagram as x -> Some x + | _ -> None + ) + +let getnameinfo (type tag) (t:[> tag ty] r) sockaddr = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in + X.getnameinfo t sockaddr + +let close = Resource.close + +let with_tcp_connect ?(timeout=Time.Timeout.none) ~host ~service t f = + Switch.run ~name:"with_tcp_connect" @@ fun sw -> + match + let rec aux = function + | [] -> raise @@ err (Connection_failure No_matching_addresses) + | addr :: addrs -> + try Time.Timeout.run_exn timeout (fun () -> connect ~sw t addr) with + | Time.Timeout | Exn.Io _ when addrs <> [] -> + aux addrs + | Time.Timeout -> + raise @@ err (Connection_failure Timeout) + in + getaddrinfo_stream ~service t host + |> List.filter_map (function + | `Tcp _ as x -> Some x + | `Unix _ -> None + ) + |> aux + with + | conn -> f conn + | exception (Exn.Io _ as ex) -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "connecting to %S:%s" host service + +(* Run a server loop in a single domain. *) +let run_server_loop ~sw ~connections ~on_error ~stop listening_socket connection_handler = + let rec accept () = + Semaphore.acquire connections; + accept_fork ~sw ~on_error listening_socket (fun conn addr -> + Fun.protect (fun () -> connection_handler conn addr) + ~finally:(fun () -> Semaphore.release connections) + ); + accept () + in + match stop with + | None -> accept () + | Some stop -> Fiber.first accept (fun () -> Promise.await stop) + +let run_server ?(max_connections=Int.max_int) ?(additional_domains) ?stop ~on_error listening_socket connection_handler : 'a = + if max_connections <= 0 then invalid_arg "max_connections"; + Switch.run ~name:"run_server" @@ fun sw -> + let connections = Semaphore.make max_connections in + let run_server_loop sw = run_server_loop ~sw ~connections ~on_error ~stop listening_socket connection_handler in + additional_domains |> Option.iter (fun (domain_mgr, domains) -> + if domains < 0 then invalid_arg "additional_domains"; + for _ = 1 to domains do + Fiber.fork ~sw (fun () -> Domain_manager.run domain_mgr (fun () -> + Switch.run ~name:"run_server" @@ fun sw -> + ignore (run_server_loop sw : 'a) + )) + done; + ); + run_server_loop sw diff --git a/lib_eio/net.mli b/lib_eio/net.mli index 78761316f..50670005a 100644 --- a/lib_eio/net.mli +++ b/lib_eio/net.mli @@ -1,366 +1,366 @@ -(** Example: - {[ - let addr = `Tcp (Ipaddr.V4.loopback, 8080) - - let http_get ~net ~stdout addr = - Switch.run @@ fun sw -> - let flow = Net.connect ~sw net addr in - Flow.copy_string "GET / HTTP/1.0\r\n\r\n" flow; - Flow.shutdown flow `Send; - Flow.copy flow stdout - ]} -*) - -open Std - -type connection_failure = - | Refused of Exn.Backend.t - | No_matching_addresses - | Timeout - -type error = - | Connection_reset of Exn.Backend.t - (** This is a wrapper for epipe, econnreset and similar errors. - It indicates that the flow has failed, and data may have been lost. *) - | Connection_failure of connection_failure - -type Exn.err += E of error - -val err : error -> exn -(** [err e] is [Eio.Exn.create (Net e)] *) - -(** IP addresses. *) -module Ipaddr : sig - type 'a t = private string - (** The raw bytes of the IP address. - It is either 4 bytes long (for an IPv4 address) or - 16 bytes long (for IPv6). *) - - (** IPv4 addresses. *) - module V4 : sig - val any : [> `V4] t - (** A special IPv4 address, for use only with [listen], representing - all the Internet addresses that the host machine possesses. *) - - val loopback : [> `V4] t - (** A special IPv4 address representing the host machine ([127.0.0.1]). *) - end - - (** IPv6 addresses. *) - module V6 : sig - val any : [> `V6] t - (** A special IPv6 address, for use only with [listen], representing - all the Internet addresses that the host machine possesses. *) - - val loopback : [> `V6] t - (** A special IPv6 address representing the host machine ([::1]). *) - end - - val pp : [< `V4 | `V6] t Fmt.t - (** [pp] formats IP addresses. - For IPv6 addresses, it follows {{:http://tools.ietf.org/html/rfc5952}}. *) - - type v4v6 = [`V4 | `V6] t - - val fold : - v4:([> `V4] t -> 'a) -> - v6:([> `V6] t -> 'a) -> - [< `V4 | `V6] t -> - 'a - (** [fold ~v4 ~v6 t] is [v4 t] if [t] is an IPv4 address, or [v6 t] if it's an IPv6 address. *) - - (** {2 Interoperability} - - To convert to or from OCaml Unix addresses, use {!Eio_unix.Ipaddr}. - - To interoperate with the {{:https://opam.ocaml.org/packages/ipaddr/} ipaddr} library: - - [Ipaddr.to_octets ipaddr_ip |> Eio.Net.Ipaddr.of_raw] - - [Ipaddr.of_octets_exn (eio_ip :> string)] *) - - val of_raw : string -> v4v6 - (** [of_raw addr] casts [addr] to an IP address. - @raise Invalid_argument if it is not 4 or 16 bytes long. *) -end - -(** Network addresses. *) -module Sockaddr : sig - type stream = [ - | `Unix of string - | `Tcp of Ipaddr.v4v6 * int - ] - (** Socket addresses that we can build a {! Flow.two_way} for i.e. stream-oriented - protocols. *) - - type datagram = [ - | `Udp of Ipaddr.v4v6 * int - | `Unix of string - ] - (** Socket addresses that are message-oriented. *) - - type t = [ stream | datagram ] - - val pp : Format.formatter -> [< t] -> unit -end - -(** {2 Types} *) - -type socket_ty = [`Socket | `Close] -type 'a socket = ([> socket_ty] as 'a) r - -type 'tag stream_socket_ty = [`Stream | `Platform of 'tag | `Shutdown | socket_ty | Flow.source_ty | Flow.sink_ty] -type 'a stream_socket = 'a r - constraint 'a = [> [> `Generic] stream_socket_ty] - -type 'tag listening_socket_ty = [ `Accept | `Platform of 'tag | socket_ty] -type 'a listening_socket = 'a r - constraint 'a = [> [> `Generic] listening_socket_ty] - -type 'a connection_handler = 'a stream_socket -> Sockaddr.stream -> unit -(** A [_ connection_handler] handles incoming connections from a listening socket. *) - -type 'tag datagram_socket_ty = [`Datagram | `Platform of 'tag | `Shutdown | socket_ty] -type 'a datagram_socket = 'a r - constraint 'a = [> [> `Generic] datagram_socket_ty] - -type 'tag ty = [`Network | `Platform of 'tag] - -type 'a t = 'a r - constraint 'a = [> [> `Generic] ty] - -(** {2 Out-bound Connections} *) - -val connect : sw:Switch.t -> [> 'tag ty] t -> Sockaddr.stream -> 'tag stream_socket_ty r -(** [connect ~sw t addr] is a new socket connected to remote address [addr]. - - The new socket will be closed when [sw] finishes, unless closed manually first. *) - -val with_tcp_connect : - ?timeout:Time.Timeout.t -> - host:string -> - service:string -> - [> 'tag ty] r -> - ('tag stream_socket_ty r -> 'b) -> - 'b -(** [with_tcp_connect ~host ~service t f] creates a tcp connection [conn] to [host] and [service] and executes - [f conn]. - - [conn] is closed after [f] returns (if it isn't already closed by then). - - [host] is either an IP address or a domain name, eg. "www.example.org", "www.ocaml.org" or "127.0.0.1". - - [service] is an IANA recognized service name or port number, eg. "http", "ftp", "8080" etc. - See https://www.iana.org/assignments/service-names-port-numbers/service-names-port-numbers.xhtml. - - Addresses are tried in the order they are returned by {!getaddrinfo}, until one succeeds. - - @param timeout Limits how long to wait for each connection attempt before moving on to the next. - By default there is no timeout (beyond what the underlying network does). - - @raise Connection_failure A connection couldn't be established for any of the addresses defined for [host]. *) - -(** {2 Incoming Connections} *) - -val listen : - ?reuse_addr:bool -> ?reuse_port:bool -> backlog:int -> sw:Switch.t -> - [> 'tag ty] r -> Sockaddr.stream -> 'tag listening_socket_ty r -(** [listen ~sw ~backlog t addr] is a new listening socket bound to local address [addr]. - - The new socket will be closed when [sw] finishes, unless closed manually first. - - On platforms that support this, passing port [0] will bind to a random port. - - For (non-abstract) Unix domain sockets, the path will be removed afterwards. - - @param backlog The number of pending connections that can be queued up (see listen(2)). - @param reuse_addr Set the {!Unix.SO_REUSEADDR} socket option. - For Unix paths, also remove any stale left-over socket. - @param reuse_port Set the {!Unix.SO_REUSEPORT} socket option. *) - -val accept : - sw:Switch.t -> - [> 'tag listening_socket_ty] r -> - 'tag stream_socket_ty r * Sockaddr.stream -(** [accept ~sw socket] waits until a new connection is ready on [socket] and returns it. - - The new socket will be closed automatically when [sw] finishes, if not closed earlier. - If you want to handle multiple connections, consider using {!accept_fork} instead. *) - -val accept_fork : - sw:Switch.t -> - [> 'tag listening_socket_ty] r -> - on_error:(exn -> unit) -> - [< 'tag stream_socket_ty] connection_handler -> - unit -(** [accept_fork ~sw ~on_error socket fn] accepts a connection and handles it in a new fiber. - - After accepting a connection to [socket], it runs [fn flow client_addr] in a new fiber. - - [flow] will be closed when [fn] returns. The new fiber is attached to [sw]. - - @param on_error Called if [connection_handler] raises an exception. - This is typically a good place to log the error and continue. - If the exception is an {!Eio.Io} error then the caller's address is added to it. - - If you don't want to handle connection errors, - use [~on_error:raise] to cancel the caller's context. - - [on_error] is not called for {!Cancel.Cancelled} exceptions, - which do not need to be reported. *) - -val listening_addr : [> 'tag listening_socket_ty] r -> Sockaddr.stream - -(** {2 Running Servers} *) - -val run_server : - ?max_connections:int -> - ?additional_domains:(_ Domain_manager.t * int) -> - ?stop:'a Promise.t -> - on_error:(exn -> unit) -> - [> 'tag listening_socket_ty ] r -> - [< 'tag stream_socket_ty] connection_handler -> - 'a -(** [run_server ~on_error sock connection_handler] establishes a concurrent socket server [s]. - - It accepts incoming client connections on socket [sock] and handles them with {!accept_fork} - (see that for the description of [on_error] and [connection_handler]). - - {b Running a Parallel Server} - - By default [s] runs on a {e single} OCaml {!module:Domain}. However, if [additional_domains:(domain_mgr, domains)] - parameter is given, then [s] will spawn [domains] additional domains and run accept loops in those too. - In such cases you must ensure that [connection_handler] only accesses thread-safe values. - Note that having more than {!Domain.recommended_domain_count} domains in total is likely to result in bad performance. - - @param max_connections The maximum number of concurrent connections accepted by [s] at any time. - The default is [Int.max_int]. - @param stop Resolving this promise causes [s] to stop accepting new connections. - [run_server] will wait for all existing connections to finish and then return. - This is useful to upgrade a server without clients noticing. - To stop immediately, cancelling all connections, just cancel [s]'s fiber instead. - @param on_error Connection error handler (see {!accept_fork}). - @raise Invalid_argument if [max_connections <= 0]. - if [additional_domains = (domain_mgr, domains)] is used and [domains < 0]. *) - -(** {2 Datagram Sockets} *) - -val datagram_socket : - ?reuse_addr:bool - -> ?reuse_port:bool - -> sw:Switch.t - -> [> 'tag ty] r - -> [< Sockaddr.datagram | `UdpV4 | `UdpV6] - -> 'tag datagram_socket_ty r - (** [datagram_socket ~sw t addr] creates a new datagram socket bound to [addr]. The new - socket will be closed when [sw] finishes. - - [`UdpV4] and [`UdpV6] represents IPv4 and IPv6 - datagram client sockets where the OS assigns the next available socket address and port - automatically. [`Udp ..] can be used to create both listening server socket and client - socket. - - @param reuse_addr Set the {!Unix.SO_REUSEADDR} socket option. - @param reuse_port Set the {!Unix.SO_REUSEPORT} socket option. *) - -val send : _ datagram_socket -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit -(** [send sock buf] sends the data in [buf] using the the datagram socket [sock]. - - @param dst If [sock] isn't connected, this provides the destination. *) - -val recv : _ datagram_socket -> Cstruct.t -> Sockaddr.datagram * int -(** [recv sock buf] receives data from the socket [sock] putting it in [buf]. The number of bytes received is - returned along with the sender address and port. If the [buf] is too small then excess bytes may be discarded - depending on the type of the socket the message is received from. *) - -(** {2 DNS queries} *) - -val getaddrinfo: ?service:string -> _ t -> string -> Sockaddr.t list -(** [getaddrinfo ?service t node] returns a list of IP addresses for [node]. [node] is either a domain name or - an IP address. - - @param service is a human friendly textual name for internet services assigned by IANA., eg. - 'http', 'https', 'ftp', etc. - - For a more thorough treatment, see {{:https://man7.org/linux/man-pages/man3/getaddrinfo.3.html} getaddrinfo}. *) - -val getaddrinfo_stream: ?service:string -> _ t -> string -> Sockaddr.stream list -(** [getaddrinfo_stream] is like {!getaddrinfo}, but filters out non-stream protocols. *) - -val getaddrinfo_datagram: ?service:string -> _ t -> string -> Sockaddr.datagram list -(** [getaddrinfo_datagram] is like {!getaddrinfo}, but filters out non-datagram protocols. *) - -val getnameinfo : _ t -> Sockaddr.t -> (string * string) -(** [getnameinfo t sockaddr] is [(hostname, service)] corresponding to [sockaddr]. [hostname] is the - registered domain name represented by [sockaddr]. [service] is the IANA specified textual name of the - port specified in [sockaddr], e.g. 'ftp', 'http', 'https', etc. *) - -(** {2 Closing} *) - -val close : [> `Close] r -> unit -(** Alias of {!Resource.close}. *) - -(** {2 Provider Interface} *) - -module Pi : sig - module type STREAM_SOCKET = sig - type tag - include Flow.Pi.SHUTDOWN - include Flow.Pi.SOURCE with type t := t - include Flow.Pi.SINK with type t := t - val close : t -> unit - end - - val stream_socket : - (module STREAM_SOCKET with type t = 't and type tag = 'tag) -> - ('t, 'tag stream_socket_ty) Resource.handler - - module type DATAGRAM_SOCKET = sig - type tag - include Flow.Pi.SHUTDOWN - val send : t -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit - val recv : t -> Cstruct.t -> Sockaddr.datagram * int - val close : t -> unit - end - - val datagram_socket : - (module DATAGRAM_SOCKET with type t = 't and type tag = 'tag) -> - ('t, 'tag datagram_socket_ty) Resource.handler - - module type LISTENING_SOCKET = sig - type t - type tag - - val accept : t -> sw:Switch.t -> tag stream_socket_ty r * Sockaddr.stream - val close : t -> unit - val listening_addr : t -> Sockaddr.stream - end - - val listening_socket : - (module LISTENING_SOCKET with type t = 't and type tag = 'tag) -> - ('t, 'tag listening_socket_ty) Resource.handler - - module type NETWORK = sig - type t - type tag - - val listen : - t -> reuse_addr:bool -> reuse_port:bool -> backlog:int -> sw:Switch.t -> - Sockaddr.stream -> tag listening_socket_ty r - - val connect : t -> sw:Switch.t -> Sockaddr.stream -> tag stream_socket_ty r - - val datagram_socket : - t - -> reuse_addr:bool - -> reuse_port:bool - -> sw:Switch.t - -> [Sockaddr.datagram | `UdpV4 | `UdpV6] - -> tag datagram_socket_ty r - - val getaddrinfo : t -> service:string -> string -> Sockaddr.t list - val getnameinfo : t -> Sockaddr.t -> (string * string) - end - - val network : - (module NETWORK with type t = 't and type tag = 'tag) -> - ('t, 'tag ty) Resource.handler -end +(** Example: + {[ + let addr = `Tcp (Ipaddr.V4.loopback, 8080) + + let http_get ~net ~stdout addr = + Switch.run @@ fun sw -> + let flow = Net.connect ~sw net addr in + Flow.copy_string "GET / HTTP/1.0\r\n\r\n" flow; + Flow.shutdown flow `Send; + Flow.copy flow stdout + ]} +*) + +open Std + +type connection_failure = + | Refused of Exn.Backend.t + | No_matching_addresses + | Timeout + +type error = + | Connection_reset of Exn.Backend.t + (** This is a wrapper for epipe, econnreset and similar errors. + It indicates that the flow has failed, and data may have been lost. *) + | Connection_failure of connection_failure + +type Exn.err += E of error + +val err : error -> exn +(** [err e] is [Eio.Exn.create (Net e)] *) + +(** IP addresses. *) +module Ipaddr : sig + type 'a t = private string + (** The raw bytes of the IP address. + It is either 4 bytes long (for an IPv4 address) or + 16 bytes long (for IPv6). *) + + (** IPv4 addresses. *) + module V4 : sig + val any : [> `V4] t + (** A special IPv4 address, for use only with [listen], representing + all the Internet addresses that the host machine possesses. *) + + val loopback : [> `V4] t + (** A special IPv4 address representing the host machine ([127.0.0.1]). *) + end + + (** IPv6 addresses. *) + module V6 : sig + val any : [> `V6] t + (** A special IPv6 address, for use only with [listen], representing + all the Internet addresses that the host machine possesses. *) + + val loopback : [> `V6] t + (** A special IPv6 address representing the host machine ([::1]). *) + end + + val pp : [< `V4 | `V6] t Fmt.t + (** [pp] formats IP addresses. + For IPv6 addresses, it follows {{:http://tools.ietf.org/html/rfc5952}}. *) + + type v4v6 = [`V4 | `V6] t + + val fold : + v4:([> `V4] t -> 'a) -> + v6:([> `V6] t -> 'a) -> + [< `V4 | `V6] t -> + 'a + (** [fold ~v4 ~v6 t] is [v4 t] if [t] is an IPv4 address, or [v6 t] if it's an IPv6 address. *) + + (** {2 Interoperability} + + To convert to or from OCaml Unix addresses, use {!Eio_unix.Ipaddr}. + + To interoperate with the {{:https://opam.ocaml.org/packages/ipaddr/} ipaddr} library: + - [Ipaddr.to_octets ipaddr_ip |> Eio.Net.Ipaddr.of_raw] + - [Ipaddr.of_octets_exn (eio_ip :> string)] *) + + val of_raw : string -> v4v6 + (** [of_raw addr] casts [addr] to an IP address. + @raise Invalid_argument if it is not 4 or 16 bytes long. *) +end + +(** Network addresses. *) +module Sockaddr : sig + type stream = [ + | `Unix of string + | `Tcp of Ipaddr.v4v6 * int + ] + (** Socket addresses that we can build a {! Flow.two_way} for i.e. stream-oriented + protocols. *) + + type datagram = [ + | `Udp of Ipaddr.v4v6 * int + | `Unix of string + ] + (** Socket addresses that are message-oriented. *) + + type t = [ stream | datagram ] + + val pp : Format.formatter -> [< t] -> unit +end + +(** {2 Types} *) + +type socket_ty = [`Socket | `Close] +type 'a socket = ([> socket_ty] as 'a) r + +type 'tag stream_socket_ty = [`Stream | `Platform of 'tag | `Shutdown | socket_ty | Flow.source_ty | Flow.sink_ty] +type 'a stream_socket = 'a r + constraint 'a = [> [> `Generic] stream_socket_ty] + +type 'tag listening_socket_ty = [ `Accept | `Platform of 'tag | socket_ty] +type 'a listening_socket = 'a r + constraint 'a = [> [> `Generic] listening_socket_ty] + +type 'a connection_handler = 'a stream_socket -> Sockaddr.stream -> unit +(** A [_ connection_handler] handles incoming connections from a listening socket. *) + +type 'tag datagram_socket_ty = [`Datagram | `Platform of 'tag | `Shutdown | socket_ty] +type 'a datagram_socket = 'a r + constraint 'a = [> [> `Generic] datagram_socket_ty] + +type 'tag ty = [`Network | `Platform of 'tag] + +type 'a t = 'a r + constraint 'a = [> [> `Generic] ty] + +(** {2 Out-bound Connections} *) + +val connect : sw:Switch.t -> [> 'tag ty] t -> Sockaddr.stream -> 'tag stream_socket_ty r +(** [connect ~sw t addr] is a new socket connected to remote address [addr]. + + The new socket will be closed when [sw] finishes, unless closed manually first. *) + +val with_tcp_connect : + ?timeout:Time.Timeout.t -> + host:string -> + service:string -> + [> 'tag ty] r -> + ('tag stream_socket_ty r -> 'b) -> + 'b +(** [with_tcp_connect ~host ~service t f] creates a tcp connection [conn] to [host] and [service] and executes + [f conn]. + + [conn] is closed after [f] returns (if it isn't already closed by then). + + [host] is either an IP address or a domain name, eg. "www.example.org", "www.ocaml.org" or "127.0.0.1". + + [service] is an IANA recognized service name or port number, eg. "http", "ftp", "8080" etc. + See https://www.iana.org/assignments/service-names-port-numbers/service-names-port-numbers.xhtml. + + Addresses are tried in the order they are returned by {!getaddrinfo}, until one succeeds. + + @param timeout Limits how long to wait for each connection attempt before moving on to the next. + By default there is no timeout (beyond what the underlying network does). + + @raise Connection_failure A connection couldn't be established for any of the addresses defined for [host]. *) + +(** {2 Incoming Connections} *) + +val listen : + ?reuse_addr:bool -> ?reuse_port:bool -> backlog:int -> sw:Switch.t -> + [> 'tag ty] r -> Sockaddr.stream -> 'tag listening_socket_ty r +(** [listen ~sw ~backlog t addr] is a new listening socket bound to local address [addr]. + + The new socket will be closed when [sw] finishes, unless closed manually first. + + On platforms that support this, passing port [0] will bind to a random port. + + For (non-abstract) Unix domain sockets, the path will be removed afterwards. + + @param backlog The number of pending connections that can be queued up (see listen(2)). + @param reuse_addr Set the {!Unix.SO_REUSEADDR} socket option. + For Unix paths, also remove any stale left-over socket. + @param reuse_port Set the {!Unix.SO_REUSEPORT} socket option. *) + +val accept : + sw:Switch.t -> + [> 'tag listening_socket_ty] r -> + 'tag stream_socket_ty r * Sockaddr.stream +(** [accept ~sw socket] waits until a new connection is ready on [socket] and returns it. + + The new socket will be closed automatically when [sw] finishes, if not closed earlier. + If you want to handle multiple connections, consider using {!accept_fork} instead. *) + +val accept_fork : + sw:Switch.t -> + [> 'tag listening_socket_ty] r -> + on_error:(exn -> unit) -> + [< 'tag stream_socket_ty] connection_handler -> + unit +(** [accept_fork ~sw ~on_error socket fn] accepts a connection and handles it in a new fiber. + + After accepting a connection to [socket], it runs [fn flow client_addr] in a new fiber. + + [flow] will be closed when [fn] returns. The new fiber is attached to [sw]. + + @param on_error Called if [connection_handler] raises an exception. + This is typically a good place to log the error and continue. + If the exception is an {!Eio.Io} error then the caller's address is added to it. + + If you don't want to handle connection errors, + use [~on_error:raise] to cancel the caller's context. + + [on_error] is not called for {!Cancel.Cancelled} exceptions, + which do not need to be reported. *) + +val listening_addr : [> 'tag listening_socket_ty] r -> Sockaddr.stream + +(** {2 Running Servers} *) + +val run_server : + ?max_connections:int -> + ?additional_domains:(_ Domain_manager.t * int) -> + ?stop:'a Promise.t -> + on_error:(exn -> unit) -> + [> 'tag listening_socket_ty ] r -> + [< 'tag stream_socket_ty] connection_handler -> + 'a +(** [run_server ~on_error sock connection_handler] establishes a concurrent socket server [s]. + + It accepts incoming client connections on socket [sock] and handles them with {!accept_fork} + (see that for the description of [on_error] and [connection_handler]). + + {b Running a Parallel Server} + + By default [s] runs on a {e single} OCaml {!module:Domain}. However, if [additional_domains:(domain_mgr, domains)] + parameter is given, then [s] will spawn [domains] additional domains and run accept loops in those too. + In such cases you must ensure that [connection_handler] only accesses thread-safe values. + Note that having more than {!Domain.recommended_domain_count} domains in total is likely to result in bad performance. + + @param max_connections The maximum number of concurrent connections accepted by [s] at any time. + The default is [Int.max_int]. + @param stop Resolving this promise causes [s] to stop accepting new connections. + [run_server] will wait for all existing connections to finish and then return. + This is useful to upgrade a server without clients noticing. + To stop immediately, cancelling all connections, just cancel [s]'s fiber instead. + @param on_error Connection error handler (see {!accept_fork}). + @raise Invalid_argument if [max_connections <= 0]. + if [additional_domains = (domain_mgr, domains)] is used and [domains < 0]. *) + +(** {2 Datagram Sockets} *) + +val datagram_socket : + ?reuse_addr:bool + -> ?reuse_port:bool + -> sw:Switch.t + -> [> 'tag ty] r + -> [< Sockaddr.datagram | `UdpV4 | `UdpV6] + -> 'tag datagram_socket_ty r + (** [datagram_socket ~sw t addr] creates a new datagram socket bound to [addr]. The new + socket will be closed when [sw] finishes. + + [`UdpV4] and [`UdpV6] represents IPv4 and IPv6 + datagram client sockets where the OS assigns the next available socket address and port + automatically. [`Udp ..] can be used to create both listening server socket and client + socket. + + @param reuse_addr Set the {!Unix.SO_REUSEADDR} socket option. + @param reuse_port Set the {!Unix.SO_REUSEPORT} socket option. *) + +val send : _ datagram_socket -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit +(** [send sock buf] sends the data in [buf] using the the datagram socket [sock]. + + @param dst If [sock] isn't connected, this provides the destination. *) + +val recv : _ datagram_socket -> Cstruct.t -> Sockaddr.datagram * int +(** [recv sock buf] receives data from the socket [sock] putting it in [buf]. The number of bytes received is + returned along with the sender address and port. If the [buf] is too small then excess bytes may be discarded + depending on the type of the socket the message is received from. *) + +(** {2 DNS queries} *) + +val getaddrinfo: ?service:string -> _ t -> string -> Sockaddr.t list +(** [getaddrinfo ?service t node] returns a list of IP addresses for [node]. [node] is either a domain name or + an IP address. + + @param service is a human friendly textual name for internet services assigned by IANA., eg. + 'http', 'https', 'ftp', etc. + + For a more thorough treatment, see {{:https://man7.org/linux/man-pages/man3/getaddrinfo.3.html} getaddrinfo}. *) + +val getaddrinfo_stream: ?service:string -> _ t -> string -> Sockaddr.stream list +(** [getaddrinfo_stream] is like {!getaddrinfo}, but filters out non-stream protocols. *) + +val getaddrinfo_datagram: ?service:string -> _ t -> string -> Sockaddr.datagram list +(** [getaddrinfo_datagram] is like {!getaddrinfo}, but filters out non-datagram protocols. *) + +val getnameinfo : _ t -> Sockaddr.t -> (string * string) +(** [getnameinfo t sockaddr] is [(hostname, service)] corresponding to [sockaddr]. [hostname] is the + registered domain name represented by [sockaddr]. [service] is the IANA specified textual name of the + port specified in [sockaddr], e.g. 'ftp', 'http', 'https', etc. *) + +(** {2 Closing} *) + +val close : [> `Close] r -> unit +(** Alias of {!Resource.close}. *) + +(** {2 Provider Interface} *) + +module Pi : sig + module type STREAM_SOCKET = sig + type tag + include Flow.Pi.SHUTDOWN + include Flow.Pi.SOURCE with type t := t + include Flow.Pi.SINK with type t := t + val close : t -> unit + end + + val stream_socket : + (module STREAM_SOCKET with type t = 't and type tag = 'tag) -> + ('t, 'tag stream_socket_ty) Resource.handler + + module type DATAGRAM_SOCKET = sig + type tag + include Flow.Pi.SHUTDOWN + val send : t -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit + val recv : t -> Cstruct.t -> Sockaddr.datagram * int + val close : t -> unit + end + + val datagram_socket : + (module DATAGRAM_SOCKET with type t = 't and type tag = 'tag) -> + ('t, 'tag datagram_socket_ty) Resource.handler + + module type LISTENING_SOCKET = sig + type t + type tag + + val accept : t -> sw:Switch.t -> tag stream_socket_ty r * Sockaddr.stream + val close : t -> unit + val listening_addr : t -> Sockaddr.stream + end + + val listening_socket : + (module LISTENING_SOCKET with type t = 't and type tag = 'tag) -> + ('t, 'tag listening_socket_ty) Resource.handler + + module type NETWORK = sig + type t + type tag + + val listen : + t -> reuse_addr:bool -> reuse_port:bool -> backlog:int -> sw:Switch.t -> + Sockaddr.stream -> tag listening_socket_ty r + + val connect : t -> sw:Switch.t -> Sockaddr.stream -> tag stream_socket_ty r + + val datagram_socket : + t + -> reuse_addr:bool + -> reuse_port:bool + -> sw:Switch.t + -> [Sockaddr.datagram | `UdpV4 | `UdpV6] + -> tag datagram_socket_ty r + + val getaddrinfo : t -> service:string -> string -> Sockaddr.t list + val getnameinfo : t -> Sockaddr.t -> (string * string) + end + + val network : + (module NETWORK with type t = 't and type tag = 'tag) -> + ('t, 'tag ty) Resource.handler +end diff --git a/lib_eio/path.ml b/lib_eio/path.ml index 37cd5ff09..860b90009 100644 --- a/lib_eio/path.ml +++ b/lib_eio/path.ml @@ -1,240 +1,240 @@ -type 'a t = 'a Fs.dir * Fs.path - -(* Like [Filename.is_relative] but always using "/" as the separator. *) -let is_relative = function - | "" -> true - | x -> x.[0] <> '/' - -(* Like [Filename.concat] but always using "/" as the separator. *) -let concat a b = - let l = String.length a in - if l = 0 || a.[l - 1] = '/' then a ^ b - else a ^ "/" ^ b - -let ( / ) (dir, p1) p2 = - match p1, p2 with - | p1, "" -> (dir, concat p1 p2) - | _, p2 when not (is_relative p2) -> (dir, p2) - | ".", p2 -> (dir, p2) - | p1, p2 -> (dir, concat p1 p2) - -let pp f (Resource.T (t, ops), p) = - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - if p = "" then Fmt.pf f "<%a>" X.pp t - else Fmt.pf f "<%a:%s>" X.pp t (String.escaped p) - -let native (Resource.T (t, ops), p) = - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - X.native t p - -let native_exn t = - match native t with - | Some p -> p - | None -> raise (Fs.err (Not_native (Fmt.str "%a" pp t))) - -(* Drop the first [n] characters from [s]. *) -let string_drop s n = - String.sub s n (String.length s - n) - -(* "/foo/bar//" -> "/foo/bar" - "///" -> "/" - "foo/bar" -> "foo/bar" - *) -let remove_trailing_slashes s = - let rec aux i = - if i <= 1 || s.[i - 1] <> '/' then ( - if i = String.length s then s - else String.sub s 0 i - ) else aux (i - 1) - in - aux (String.length s) - -let split (dir, p) = - match remove_trailing_slashes p with - | "" -> None - | "/" -> None - | p -> - match String.rindex_opt p '/' with - | None -> Some ((dir, ""), p) - | Some idx -> - let basename = string_drop p (idx + 1) in - let dirname = - if idx = 0 then "/" - else remove_trailing_slashes (String.sub p 0 idx) - in - Some ((dir, dirname), basename) - -let open_in ~sw t = - let (Resource.T (dir, ops), path) = t in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try X.open_in dir ~sw path - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "opening %a" pp t - -let open_out ~sw ?(append=false) ~create t = - let (Resource.T (dir, ops), path) = t in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try X.open_out dir ~sw ~append ~create path - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "opening %a" pp t - -let open_dir ~sw t = - let (Resource.T (dir, ops), path) = t in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try - let sub = X.open_dir dir ~sw path, "" in - (sub : [`Close | `Dir] t :> [< `Close | `Dir] t) - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "opening directory %a" pp t - -let mkdir ~perm t = - let (Resource.T (dir, ops), path) = t in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try X.mkdir dir ~perm path - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "creating directory %a" pp t - -let read_dir t = - let (Resource.T (dir, ops), path) = t in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try List.sort String.compare (X.read_dir dir path) - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "reading directory %a" pp t - -let stat ~follow t = - let (Resource.T (dir, ops), path) = t in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try X.stat ~follow dir path - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "examining %a" pp t - -let kind ~follow t = - try ((stat ~follow t).kind :> [File.Stat.kind | `Not_found]) - with Exn.Io (Fs.E Not_found _, _) -> `Not_found - -let is_file t = - kind ~follow:true t = `Regular_file - -let is_directory t = - kind ~follow:true t = `Directory - -let with_open_in path fn = - Switch.run ~name:"with_open_in" @@ fun sw -> fn (open_in ~sw path) - -let with_open_out ?append ~create path fn = - Switch.run ~name:"with_open_out" @@ fun sw -> fn (open_out ~sw ?append ~create path) - -let with_open_dir path fn = - Switch.run ~name:"with_open_dir" @@ fun sw -> fn (open_dir ~sw path) - -let with_lines path fn = - with_open_in path @@ fun flow -> - let buf = Buf_read.of_flow flow ~max_size:max_int in - fn (Buf_read.lines buf) - -let load (t, path) = - with_open_in (t, path) @@ fun flow -> - try - let size = File.size flow in - if Optint.Int63.(compare size (of_int Sys.max_string_length)) = 1 then - raise @@ Fs.err File_too_large; - let buf = Cstruct.create (Optint.Int63.to_int size) in - let rec loop buf got = - match Flow.single_read flow buf with - | n -> loop (Cstruct.shift buf n) (n + got) - | exception End_of_file -> got - in - let got = loop buf 0 in - Cstruct.to_string ~len:got buf - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "loading %a" pp (t, path) - -let save ?append ~create path data = - with_open_out ?append ~create path @@ fun flow -> - Flow.copy_string data flow - -let unlink t = - let (Resource.T (dir, ops), path) = t in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try X.unlink dir path - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "removing file %a" pp t - -let rmdir t = - let (Resource.T (dir, ops), path) = t in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try X.rmdir dir path - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "removing directory %a" pp t - -let catch_missing ~missing_ok fn x = - if missing_ok then - try fn x - with Exn.Io (Fs.E Not_found _, _) -> () - else fn x - -let rec rmtree ~missing_ok t = - match kind ~follow:false t with - | `Directory -> - Switch.run ~name:"rmtree" (fun sw -> - match - let t = open_dir ~sw t in - t, read_dir t - with - | t, items -> List.iter (fun x -> rmtree ~missing_ok (t / x)) items - | exception Exn.Io (Fs.E Not_found _, _) when missing_ok -> () - ); - catch_missing ~missing_ok rmdir t - | `Not_found when missing_ok -> () - | _ -> - catch_missing ~missing_ok unlink t - -let rmtree ?(missing_ok=false) t = - rmtree ~missing_ok (t :> Fs.dir_ty t) - -let rename t1 t2 = - let (dir2, new_path) = t2 in - let (Resource.T (dir, ops), old_path) = t1 in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try X.rename dir old_path (dir2 :> _ Fs.dir) new_path - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "renaming %a to %a" pp t1 pp t2 - -let symlink ~link_to source = - let (Resource.T (dir, ops), path) = source in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try X.symlink dir path ~link_to - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "creating symlink %a -> %s" pp source link_to - -let rec mkdirs ?(exists_ok=false) ~perm t = - (* Check parent exists first. *) - split t |> Option.iter (fun (parent, _) -> - match is_directory parent with - | true -> () - | false -> mkdirs ~perm ~exists_ok:true parent - | exception (Exn.Io _ as ex) -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "creating directory %a" pp t - ); - try mkdir ~perm t - with Exn.Io (Fs.E Already_exists _, _) when exists_ok && is_directory t -> () - -let read_link t = - let (Resource.T (dir, ops), path) = t in - let module X = (val (Resource.get ops Fs.Pi.Dir)) in - try X.read_link dir path - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "reading target of symlink %a" pp t +type 'a t = 'a Fs.dir * Fs.path + +(* Like [Filename.is_relative] but always using "/" as the separator. *) +let is_relative = function + | "" -> true + | x -> x.[0] <> '/' + +(* Like [Filename.concat] but always using "/" as the separator. *) +let concat a b = + let l = String.length a in + if l = 0 || a.[l - 1] = '/' then a ^ b + else a ^ "/" ^ b + +let ( / ) (dir, p1) p2 = + match p1, p2 with + | p1, "" -> (dir, concat p1 p2) + | _, p2 when not (is_relative p2) -> (dir, p2) + | ".", p2 -> (dir, p2) + | p1, p2 -> (dir, concat p1 p2) + +let pp f (Resource.T (t, ops), p) = + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + if p = "" then Fmt.pf f "<%a>" X.pp t + else Fmt.pf f "<%a:%s>" X.pp t (String.escaped p) + +let native (Resource.T (t, ops), p) = + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + X.native t p + +let native_exn t = + match native t with + | Some p -> p + | None -> raise (Fs.err (Not_native (Fmt.str "%a" pp t))) + +(* Drop the first [n] characters from [s]. *) +let string_drop s n = + String.sub s n (String.length s - n) + +(* "/foo/bar//" -> "/foo/bar" + "///" -> "/" + "foo/bar" -> "foo/bar" + *) +let remove_trailing_slashes s = + let rec aux i = + if i <= 1 || s.[i - 1] <> '/' then ( + if i = String.length s then s + else String.sub s 0 i + ) else aux (i - 1) + in + aux (String.length s) + +let split (dir, p) = + match remove_trailing_slashes p with + | "" -> None + | "/" -> None + | p -> + match String.rindex_opt p '/' with + | None -> Some ((dir, ""), p) + | Some idx -> + let basename = string_drop p (idx + 1) in + let dirname = + if idx = 0 then "/" + else remove_trailing_slashes (String.sub p 0 idx) + in + Some ((dir, dirname), basename) + +let open_in ~sw t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.open_in dir ~sw path + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "opening %a" pp t + +let open_out ~sw ?(append=false) ~create t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.open_out dir ~sw ~append ~create path + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "opening %a" pp t + +let open_dir ~sw t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try + let sub = X.open_dir dir ~sw path, "" in + (sub : [`Close | `Dir] t :> [< `Close | `Dir] t) + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "opening directory %a" pp t + +let mkdir ~perm t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.mkdir dir ~perm path + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "creating directory %a" pp t + +let read_dir t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try List.sort String.compare (X.read_dir dir path) + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "reading directory %a" pp t + +let stat ~follow t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.stat ~follow dir path + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "examining %a" pp t + +let kind ~follow t = + try ((stat ~follow t).kind :> [File.Stat.kind | `Not_found]) + with Exn.Io (Fs.E Not_found _, _) -> `Not_found + +let is_file t = + kind ~follow:true t = `Regular_file + +let is_directory t = + kind ~follow:true t = `Directory + +let with_open_in path fn = + Switch.run ~name:"with_open_in" @@ fun sw -> fn (open_in ~sw path) + +let with_open_out ?append ~create path fn = + Switch.run ~name:"with_open_out" @@ fun sw -> fn (open_out ~sw ?append ~create path) + +let with_open_dir path fn = + Switch.run ~name:"with_open_dir" @@ fun sw -> fn (open_dir ~sw path) + +let with_lines path fn = + with_open_in path @@ fun flow -> + let buf = Buf_read.of_flow flow ~max_size:max_int in + fn (Buf_read.lines buf) + +let load (t, path) = + with_open_in (t, path) @@ fun flow -> + try + let size = File.size flow in + if Optint.Int63.(compare size (of_int Sys.max_string_length)) = 1 then + raise @@ Fs.err File_too_large; + let buf = Cstruct.create (Optint.Int63.to_int size) in + let rec loop buf got = + match Flow.single_read flow buf with + | n -> loop (Cstruct.shift buf n) (n + got) + | exception End_of_file -> got + in + let got = loop buf 0 in + Cstruct.to_string ~len:got buf + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "loading %a" pp (t, path) + +let save ?append ~create path data = + with_open_out ?append ~create path @@ fun flow -> + Flow.copy_string data flow + +let unlink t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.unlink dir path + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "removing file %a" pp t + +let rmdir t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.rmdir dir path + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "removing directory %a" pp t + +let catch_missing ~missing_ok fn x = + if missing_ok then + try fn x + with Exn.Io (Fs.E Not_found _, _) -> () + else fn x + +let rec rmtree ~missing_ok t = + match kind ~follow:false t with + | `Directory -> + Switch.run ~name:"rmtree" (fun sw -> + match + let t = open_dir ~sw t in + t, read_dir t + with + | t, items -> List.iter (fun x -> rmtree ~missing_ok (t / x)) items + | exception Exn.Io (Fs.E Not_found _, _) when missing_ok -> () + ); + catch_missing ~missing_ok rmdir t + | `Not_found when missing_ok -> () + | _ -> + catch_missing ~missing_ok unlink t + +let rmtree ?(missing_ok=false) t = + rmtree ~missing_ok (t :> Fs.dir_ty t) + +let rename t1 t2 = + let (dir2, new_path) = t2 in + let (Resource.T (dir, ops), old_path) = t1 in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.rename dir old_path (dir2 :> _ Fs.dir) new_path + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "renaming %a to %a" pp t1 pp t2 + +let symlink ~link_to source = + let (Resource.T (dir, ops), path) = source in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.symlink dir path ~link_to + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "creating symlink %a -> %s" pp source link_to + +let rec mkdirs ?(exists_ok=false) ~perm t = + (* Check parent exists first. *) + split t |> Option.iter (fun (parent, _) -> + match is_directory parent with + | true -> () + | false -> mkdirs ~perm ~exists_ok:true parent + | exception (Exn.Io _ as ex) -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "creating directory %a" pp t + ); + try mkdir ~perm t + with Exn.Io (Fs.E Already_exists _, _) when exists_ok && is_directory t -> () + +let read_link t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.read_link dir path + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "reading target of symlink %a" pp t diff --git a/lib_eio/path.mli b/lib_eio/path.mli index d147f5454..45bceec68 100644 --- a/lib_eio/path.mli +++ b/lib_eio/path.mli @@ -1,219 +1,219 @@ -(** A [_ Path.t] represents a particular location in some filesystem. - It is a pair of a base directory and a relative path from there. - - {!Eio.Stdenv.cwd} provides access to the current working directory. - For example: - - {[ - let ( / ) = Eio.Path.( / ) - - let run dir = - Eio.Path.save ~create:(`Exclusive 0o600) - (dir / "output.txt") "the data" - - let () = - Eio_main.run @@ fun env -> - run (Eio.Stdenv.cwd env) - ]} - - It is normally not permitted to access anything above the base directory, - even by following a symlink. - The exception is {!Stdenv.fs}, which provides access to the whole file-system: - - {[ - Eio.Path.load (fs / "/etc/passwd") - ]} - - In Eio, the directory separator is always "/", even on Windows. - Use {!native} to convert to a native path. -*) - -open Std -open Fs - -type 'a t = 'a Fs.dir * path -(** An OS directory FD and a path relative to it, for use with e.g. [openat(2)]. *) - -val ( / ) : 'a t -> string -> 'a t -(** [t / step] is [t] with [step] appended to [t]'s path, - or replacing [t]'s path if [step] is absolute: - - - [(fd, "foo") / "bar" = (fd, "foo/bar")] - - [(fd, "foo") / "/bar" = (fd, "/bar")] *) - -val pp : _ t Fmt.t -(** [pp] formats a [_ t] as "", suitable for logging. *) - -val native : _ t -> string option -(** [native t] returns a path that can be used to refer to [t] with the host - platform's native string-based file-system APIs, if available. - This is intended for interoperability with non-Eio libraries. - - This does not check for confinement (the resulting path might not be accessible - via [t] itself). Also, if a directory was opened with {!open_dir} and later - renamed, this might use the old name. - - Using strings as paths is not secure if components in the path can be - replaced by symlinks while the path is being used. For example, if you - try to write to "/home/mal/output.txt" just as mal replaces "output.txt" - with a symlink to "/etc/passwd". *) - -val native_exn : _ t -> string -(** Like {!native}, but raise a suitable exception if the path is not a native path. *) - -val split : 'a t -> ('a t * string) option -(** [split t] returns [Some (dir, basename)], where [basename] is the last path component in [t] - and [dir] is [t] without [basename]. - - [dir / basename] refers to the same path as [t]. - - [split t = None] if there is nothing to split. - - For example: - - - [split (root, "foo/bar") = Some ((root, "foo"), "bar")] - - [split (root, "/foo/bar") = Some ((root, "/foo"), "bar")] - - [split (root, "/foo/bar/baz") = Some ((root, "/foo/bar"), "baz")] - - [split (root, "/foo/bar//baz/") = Some ((root, "/foo/bar"), "baz")] - - [split (root, "bar") = Some ((root, ""), "bar")] - - [split (root, ".") = Some ((root, ""), ".")] - - [split (root, "") = None] - - [split (root, "/") = None] -*) - -(** {1 Reading files} *) - -val load : _ t -> string -(** [load t] returns the contents of the given file. - - This is a convenience wrapper around {!with_open_in}. *) - -val open_in : sw:Switch.t -> _ t -> File.ro_ty r -(** [open_in ~sw t] opens [t] for reading. - - Note: files are always opened in binary mode. *) - -val with_open_in : _ t -> (File.ro_ty r -> 'a) -> 'a -(** [with_open_in] is like [open_in], but calls [fn flow] with the new flow and closes - it automatically when [fn] returns (if it hasn't already been closed by then). *) - -val with_lines : _ t -> (string Seq.t -> 'a) -> 'a -(** [with_lines t fn] is a convenience function for streaming the lines of the file. - - It uses {!Buf_read.lines}. *) - -(** {1 Writing files} *) - -val save : ?append:bool -> create:create -> _ t -> string -> unit -(** [save t data ~create] writes [data] to [t]. - - This is a convenience wrapper around {!with_open_out}. *) - -val open_out : - sw:Switch.t -> - ?append:bool -> - create:create -> - _ t -> File.rw_ty Resource.t -(** [open_out ~sw t] opens [t] for reading and writing. - - Note: files are always opened in binary mode. - @param append Open for appending: always write at end of file. - @param create Controls whether to create the file, and what permissions to give it if so. *) - -val with_open_out : - ?append:bool -> - create:create -> - _ t -> (File.rw_ty r -> 'a) -> 'a -(** [with_open_out] is like [open_out], but calls [fn flow] with the new flow and closes - it automatically when [fn] returns (if it hasn't already been closed by then). *) - -(** {1 Directories} *) - -val mkdir : perm:File.Unix_perm.t -> _ t -> unit -(** [mkdir ~perm t] creates a new directory [t] with permissions [perm]. *) - -val mkdirs : ?exists_ok:bool -> perm:File.Unix_perm.t -> _ t -> unit -(** [mkdirs ~perm t] creates directory [t] along with any missing ancestor directories, recursively. - - All created directories get permissions [perm], but existing directories do not have their permissions changed. - - @param exist_ok If [false] (the default) then we raise {! Fs.Already_exists} if [t] is already a directory. *) - -val open_dir : sw:Switch.t -> _ t -> [< `Close | dir_ty] t -(** [open_dir ~sw t] opens [t]. - - This can be passed to functions to grant access only to the subtree [t]. *) - -val with_open_dir : _ t -> ([< `Close | dir_ty] t -> 'a) -> 'a -(** [with_open_dir] is like [open_dir], but calls [fn dir] with the new directory and closes - it automatically when [fn] returns (if it hasn't already been closed by then). *) - -val read_dir : _ t -> string list -(** [read_dir t] reads directory entries for [t]. - - The entries are sorted using {! String.compare}. - - Note: The special Unix entries "." and ".." are not included in the results. *) - -(** {1 Metadata} *) - -val stat : follow:bool -> _ t -> File.Stat.t -(** [stat ~follow t] returns metadata about the file [t]. - - If [t] is a symlink, the information returned is about the target if [follow = true], - otherwise it is about the link itself. *) - -val kind : follow:bool -> _ t -> [ File.Stat.kind | `Not_found ] -(** [kind ~follow t] is the type of [t], or [`Not_found] if it doesn't exist. - - @param follow If [true] and [t] is a symlink, return the type of the target rather than [`Symbolic_link]. *) - -val is_file : _ t -> bool -(** [is_file t] is [true] if [t] is a regular file, and [false] if it doesn't exist or has a different type. - - [is_file t] is [kind ~follow:true t = `Regular_file]. *) - -val is_directory : _ t -> bool -(** [is_directory t] is [true] if [t] is a directory, and [false] if it doesn't exist or has a different type. - - [is_directory t] is [kind ~follow:true t = `Directory]. *) - -val read_link : _ t -> string -(** [read_link t] is the target of symlink [t]. *) - -(** {1 Other} *) - -val unlink : _ t -> unit -(** [unlink t] removes directory entry [t]. - - Note: this cannot be used to unlink directories. - Use {!rmdir} for directories. *) - -val rmdir : _ t -> unit -(** [rmdir t] removes directory entry [t]. - This only works when the entry is itself a directory. - - Note: this usually requires the directory to be empty. *) - -val rmtree : ?missing_ok:bool -> _ t -> unit -(** [rmtree t] removes [t] (and its contents, recursively, if it's a directory). - - @param missing_ok If [false] (the default), raise an {!Fs.Not_found} IO error if [t] doesn't exist. - If [true], ignore missing items. - This applies recursively, allowing two processes - to attempt to remove a tree at the same time. *) - -val rename : _ t -> _ t -> unit -(** [rename old_t new_t] atomically unlinks [old_t] and links it as [new_t]. - - If [new_t] already exists, it is atomically replaced. *) - -val symlink : link_to:string -> _ t -> unit -(** [symlink ~link_to t] creates a symbolic link [t] to [link_to]. - - [t] is the symlink that is created and [link_to] is the name used in the link. - For example, this creates a "current" symlink pointing at "version-1.0": - - {[ - Eio.Path.symlink (dir / "current") ~link_to:"version-1.0" - ]} *) +(** A [_ Path.t] represents a particular location in some filesystem. + It is a pair of a base directory and a relative path from there. + + {!Eio.Stdenv.cwd} provides access to the current working directory. + For example: + + {[ + let ( / ) = Eio.Path.( / ) + + let run dir = + Eio.Path.save ~create:(`Exclusive 0o600) + (dir / "output.txt") "the data" + + let () = + Eio_main.run @@ fun env -> + run (Eio.Stdenv.cwd env) + ]} + + It is normally not permitted to access anything above the base directory, + even by following a symlink. + The exception is {!Stdenv.fs}, which provides access to the whole file-system: + + {[ + Eio.Path.load (fs / "/etc/passwd") + ]} + + In Eio, the directory separator is always "/", even on Windows. + Use {!native} to convert to a native path. +*) + +open Std +open Fs + +type 'a t = 'a Fs.dir * path +(** An OS directory FD and a path relative to it, for use with e.g. [openat(2)]. *) + +val ( / ) : 'a t -> string -> 'a t +(** [t / step] is [t] with [step] appended to [t]'s path, + or replacing [t]'s path if [step] is absolute: + + - [(fd, "foo") / "bar" = (fd, "foo/bar")] + - [(fd, "foo") / "/bar" = (fd, "/bar")] *) + +val pp : _ t Fmt.t +(** [pp] formats a [_ t] as "", suitable for logging. *) + +val native : _ t -> string option +(** [native t] returns a path that can be used to refer to [t] with the host + platform's native string-based file-system APIs, if available. + This is intended for interoperability with non-Eio libraries. + + This does not check for confinement (the resulting path might not be accessible + via [t] itself). Also, if a directory was opened with {!open_dir} and later + renamed, this might use the old name. + + Using strings as paths is not secure if components in the path can be + replaced by symlinks while the path is being used. For example, if you + try to write to "/home/mal/output.txt" just as mal replaces "output.txt" + with a symlink to "/etc/passwd". *) + +val native_exn : _ t -> string +(** Like {!native}, but raise a suitable exception if the path is not a native path. *) + +val split : 'a t -> ('a t * string) option +(** [split t] returns [Some (dir, basename)], where [basename] is the last path component in [t] + and [dir] is [t] without [basename]. + + [dir / basename] refers to the same path as [t]. + + [split t = None] if there is nothing to split. + + For example: + + - [split (root, "foo/bar") = Some ((root, "foo"), "bar")] + - [split (root, "/foo/bar") = Some ((root, "/foo"), "bar")] + - [split (root, "/foo/bar/baz") = Some ((root, "/foo/bar"), "baz")] + - [split (root, "/foo/bar//baz/") = Some ((root, "/foo/bar"), "baz")] + - [split (root, "bar") = Some ((root, ""), "bar")] + - [split (root, ".") = Some ((root, ""), ".")] + - [split (root, "") = None] + - [split (root, "/") = None] +*) + +(** {1 Reading files} *) + +val load : _ t -> string +(** [load t] returns the contents of the given file. + + This is a convenience wrapper around {!with_open_in}. *) + +val open_in : sw:Switch.t -> _ t -> File.ro_ty r +(** [open_in ~sw t] opens [t] for reading. + + Note: files are always opened in binary mode. *) + +val with_open_in : _ t -> (File.ro_ty r -> 'a) -> 'a +(** [with_open_in] is like [open_in], but calls [fn flow] with the new flow and closes + it automatically when [fn] returns (if it hasn't already been closed by then). *) + +val with_lines : _ t -> (string Seq.t -> 'a) -> 'a +(** [with_lines t fn] is a convenience function for streaming the lines of the file. + + It uses {!Buf_read.lines}. *) + +(** {1 Writing files} *) + +val save : ?append:bool -> create:create -> _ t -> string -> unit +(** [save t data ~create] writes [data] to [t]. + + This is a convenience wrapper around {!with_open_out}. *) + +val open_out : + sw:Switch.t -> + ?append:bool -> + create:create -> + _ t -> File.rw_ty Resource.t +(** [open_out ~sw t] opens [t] for reading and writing. + + Note: files are always opened in binary mode. + @param append Open for appending: always write at end of file. + @param create Controls whether to create the file, and what permissions to give it if so. *) + +val with_open_out : + ?append:bool -> + create:create -> + _ t -> (File.rw_ty r -> 'a) -> 'a +(** [with_open_out] is like [open_out], but calls [fn flow] with the new flow and closes + it automatically when [fn] returns (if it hasn't already been closed by then). *) + +(** {1 Directories} *) + +val mkdir : perm:File.Unix_perm.t -> _ t -> unit +(** [mkdir ~perm t] creates a new directory [t] with permissions [perm]. *) + +val mkdirs : ?exists_ok:bool -> perm:File.Unix_perm.t -> _ t -> unit +(** [mkdirs ~perm t] creates directory [t] along with any missing ancestor directories, recursively. + + All created directories get permissions [perm], but existing directories do not have their permissions changed. + + @param exist_ok If [false] (the default) then we raise {! Fs.Already_exists} if [t] is already a directory. *) + +val open_dir : sw:Switch.t -> _ t -> [< `Close | dir_ty] t +(** [open_dir ~sw t] opens [t]. + + This can be passed to functions to grant access only to the subtree [t]. *) + +val with_open_dir : _ t -> ([< `Close | dir_ty] t -> 'a) -> 'a +(** [with_open_dir] is like [open_dir], but calls [fn dir] with the new directory and closes + it automatically when [fn] returns (if it hasn't already been closed by then). *) + +val read_dir : _ t -> string list +(** [read_dir t] reads directory entries for [t]. + + The entries are sorted using {! String.compare}. + + Note: The special Unix entries "." and ".." are not included in the results. *) + +(** {1 Metadata} *) + +val stat : follow:bool -> _ t -> File.Stat.t +(** [stat ~follow t] returns metadata about the file [t]. + + If [t] is a symlink, the information returned is about the target if [follow = true], + otherwise it is about the link itself. *) + +val kind : follow:bool -> _ t -> [ File.Stat.kind | `Not_found ] +(** [kind ~follow t] is the type of [t], or [`Not_found] if it doesn't exist. + + @param follow If [true] and [t] is a symlink, return the type of the target rather than [`Symbolic_link]. *) + +val is_file : _ t -> bool +(** [is_file t] is [true] if [t] is a regular file, and [false] if it doesn't exist or has a different type. + + [is_file t] is [kind ~follow:true t = `Regular_file]. *) + +val is_directory : _ t -> bool +(** [is_directory t] is [true] if [t] is a directory, and [false] if it doesn't exist or has a different type. + + [is_directory t] is [kind ~follow:true t = `Directory]. *) + +val read_link : _ t -> string +(** [read_link t] is the target of symlink [t]. *) + +(** {1 Other} *) + +val unlink : _ t -> unit +(** [unlink t] removes directory entry [t]. + + Note: this cannot be used to unlink directories. + Use {!rmdir} for directories. *) + +val rmdir : _ t -> unit +(** [rmdir t] removes directory entry [t]. + This only works when the entry is itself a directory. + + Note: this usually requires the directory to be empty. *) + +val rmtree : ?missing_ok:bool -> _ t -> unit +(** [rmtree t] removes [t] (and its contents, recursively, if it's a directory). + + @param missing_ok If [false] (the default), raise an {!Fs.Not_found} IO error if [t] doesn't exist. + If [true], ignore missing items. + This applies recursively, allowing two processes + to attempt to remove a tree at the same time. *) + +val rename : _ t -> _ t -> unit +(** [rename old_t new_t] atomically unlinks [old_t] and links it as [new_t]. + + If [new_t] already exists, it is atomically replaced. *) + +val symlink : link_to:string -> _ t -> unit +(** [symlink ~link_to t] creates a symbolic link [t] to [link_to]. + + [t] is the symlink that is created and [link_to] is the name used in the link. + For example, this creates a "current" symlink pointing at "version-1.0": + + {[ + Eio.Path.symlink (dir / "current") ~link_to:"version-1.0" + ]} *) diff --git a/lib_eio/pool.ml b/lib_eio/pool.ml index 157416478..f2b4ffee3 100644 --- a/lib_eio/pool.ml +++ b/lib_eio/pool.ml @@ -1,178 +1,178 @@ -(* A pool is a sequence of cells containing either available slots or consumers waiting for them. - A slot may or may not contain an actual resource. - - To use a resource: - - 1. Get the next "suspend" cell. If it contains a resource slot, use it. - 2. If no slot is ready and we're below capacity, create a new slot and add it (to the next resume cell). - 3. Either way, wait for the cell to be resumed with a slot. - 4. Once you have a slot, ensure it contains a resource, creating one if not. - 5. When done, add the slot back (in the next resume cell). -*) - -(* Import these directly because we copy this file for the dscheck tests. *) -module Fiber_context = Eio__core.Private.Fiber_context -module Suspend = Eio__core.Private.Suspend - -type 'a slot = 'a option ref - -module Cell = struct - (* The possible behaviours are: - - 1. Suspender : In_transition -> Request Suspender waits for a resource - 1.1. Resumer : Request -> Finished Resumer then providers a resource - 1.2. Suspender : Request -> Finished Suspender cancels - 2. Resumer : In_transition -> Resource Resumer provides a spare resource - 2.1. Suspender : Resource -> Finished Suspender doesn't need to wait - *) - - type 'a t = - | In_transition - | Request of ('a slot -> unit) - | Resource of 'a slot - | Finished - - let init = In_transition - - let segment_order = 2 - - let dump f = function - | In_transition -> Fmt.string f "In_transition" - | Request _ -> Fmt.string f "Request" - | Resource _ -> Fmt.string f "Resource" - | Finished -> Fmt.string f "Finished" -end - -module Q = Cells.Make(Cell) - -type 'a t = { - slots : int Atomic.t; (* Total resources, available and in use *) - max_slots : int; - alloc : unit -> 'a; - validate : 'a -> bool; - dispose : 'a -> unit; - q : 'a Q.t; -} - -let create ?(validate=Fun.const true) ?(dispose=ignore) max_size alloc = - if max_size <= 0 then invalid_arg "Pool.create: max_size is <= 0"; - { - slots = Atomic.make 0; - max_slots = max_size; - alloc; - validate; - dispose; - q = Q.make (); - } - -(* [add t x] adds [x] to the queue of available slots. *) -let rec add t x = - let cell = Q.next_resume t.q in - let rec aux () = - match Atomic.get cell with - | In_transition -> if not (Atomic.compare_and_set cell In_transition (Resource x)) then aux () - | Finished -> add t x (* The consumer cancelled. Get another cell and retry. *) - | Request r as prev -> - if Atomic.compare_and_set cell prev Finished then ( - r x (* We had a consumer waiting. Give it to them. *) - ) else add t x (* Consumer cancelled; retry with another cell. *) - | Resource _ -> assert false (* Can't happen; only a resumer can set this, and we're the resumer. *) - in - aux () - -(* Try to cancel by transitioning from [Request] to [Finished]. - This can only be called after previously transitioning to [Request]. *) -let cancel segment cell = - match Atomic.exchange cell Cell.Finished with - | Request _ -> Q.cancel_cell segment; true - | Finished -> false (* Already resumed; reject cancellation *) - | In_transition | Resource _ -> assert false (* Can't get here from [Request]. *) - -(* If [t] is under capacity, add another (empty) slot. *) -let rec maybe_add_slot t current = - if current < t.max_slots then ( - if Atomic.compare_and_set t.slots current (current + 1) then add t (ref None) - else maybe_add_slot t (Atomic.get t.slots) (* Concurrent update; try again *) - ) - -(* [run_with t f slot] ensures that [slot] contains a valid resource and then runs [f resource] with it. - Afterwards, the slot is returned to [t]. *) -let run_with t f slot = - match - begin match !slot with - | Some x when t.validate x -> f x - | Some x -> - slot := None; - t.dispose x; - let x = t.alloc () in - slot := Some x; - f x - | None -> - let x = t.alloc () in - slot := Some x; - f x - end - with - | r -> - add t slot; - r - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - add t slot; - Printexc.raise_with_backtrace ex bt - -(* Creates a fresh resource [x], runs [f x], then disposes of [x] *) -let run_new_and_dispose t f = - let x = t.alloc () in - match f x with - | r -> - t.dispose x; - r - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - t.dispose x; - Printexc.raise_with_backtrace ex bt - -let use t ?(never_block=false) f = - let segment, cell = Q.next_suspend t.q in - match Atomic.get cell with - | Finished | Request _ -> assert false - | Resource slot -> - Atomic.set cell Finished; (* Allow value to be GC'd *) - run_with t f slot - | In_transition -> - let current = Atomic.get t.slots in - match current < t.max_slots with - | false when never_block -> ( - (* We are at capacity, but cannot block. - Create a new resource to run f but don't add it to the pool. *) - match Atomic.exchange cell Finished with - | Resource slot -> run_with t f slot - | _ -> run_new_and_dispose t f - ) - | can_add -> - (* Create a slot if not at capacity. *) - if can_add then maybe_add_slot t current; - (* No item is available right now. Start waiting *) - let slot = - Suspend.enter_unchecked "Pool.acquire" (fun ctx enqueue -> - let r x = enqueue (Ok x) in - if Atomic.compare_and_set cell In_transition (Request r) then ( - match Fiber_context.get_error ctx with - | Some ex -> - if cancel segment cell then enqueue (Error ex); - (* else being resumed *) - | None -> - Fiber_context.set_cancel_fn ctx (fun ex -> - if cancel segment cell then enqueue (Error ex) - (* else being resumed *) - ) - ) else ( - match Atomic.exchange cell Finished with - | Resource x -> enqueue (Ok x) - | _ -> assert false - ); - ) - in - (* assert (Atomic.get cell = Finished); *) - run_with t f slot +(* A pool is a sequence of cells containing either available slots or consumers waiting for them. + A slot may or may not contain an actual resource. + + To use a resource: + + 1. Get the next "suspend" cell. If it contains a resource slot, use it. + 2. If no slot is ready and we're below capacity, create a new slot and add it (to the next resume cell). + 3. Either way, wait for the cell to be resumed with a slot. + 4. Once you have a slot, ensure it contains a resource, creating one if not. + 5. When done, add the slot back (in the next resume cell). +*) + +(* Import these directly because we copy this file for the dscheck tests. *) +module Fiber_context = Eio__core.Private.Fiber_context +module Suspend = Eio__core.Private.Suspend + +type 'a slot = 'a option ref + +module Cell = struct + (* The possible behaviours are: + + 1. Suspender : In_transition -> Request Suspender waits for a resource + 1.1. Resumer : Request -> Finished Resumer then providers a resource + 1.2. Suspender : Request -> Finished Suspender cancels + 2. Resumer : In_transition -> Resource Resumer provides a spare resource + 2.1. Suspender : Resource -> Finished Suspender doesn't need to wait + *) + + type 'a t = + | In_transition + | Request of ('a slot -> unit) + | Resource of 'a slot + | Finished + + let init = In_transition + + let segment_order = 2 + + let dump f = function + | In_transition -> Fmt.string f "In_transition" + | Request _ -> Fmt.string f "Request" + | Resource _ -> Fmt.string f "Resource" + | Finished -> Fmt.string f "Finished" +end + +module Q = Cells.Make(Cell) + +type 'a t = { + slots : int Atomic.t; (* Total resources, available and in use *) + max_slots : int; + alloc : unit -> 'a; + validate : 'a -> bool; + dispose : 'a -> unit; + q : 'a Q.t; +} + +let create ?(validate=Fun.const true) ?(dispose=ignore) max_size alloc = + if max_size <= 0 then invalid_arg "Pool.create: max_size is <= 0"; + { + slots = Atomic.make 0; + max_slots = max_size; + alloc; + validate; + dispose; + q = Q.make (); + } + +(* [add t x] adds [x] to the queue of available slots. *) +let rec add t x = + let cell = Q.next_resume t.q in + let rec aux () = + match Atomic.get cell with + | In_transition -> if not (Atomic.compare_and_set cell In_transition (Resource x)) then aux () + | Finished -> add t x (* The consumer cancelled. Get another cell and retry. *) + | Request r as prev -> + if Atomic.compare_and_set cell prev Finished then ( + r x (* We had a consumer waiting. Give it to them. *) + ) else add t x (* Consumer cancelled; retry with another cell. *) + | Resource _ -> assert false (* Can't happen; only a resumer can set this, and we're the resumer. *) + in + aux () + +(* Try to cancel by transitioning from [Request] to [Finished]. + This can only be called after previously transitioning to [Request]. *) +let cancel segment cell = + match Atomic.exchange cell Cell.Finished with + | Request _ -> Q.cancel_cell segment; true + | Finished -> false (* Already resumed; reject cancellation *) + | In_transition | Resource _ -> assert false (* Can't get here from [Request]. *) + +(* If [t] is under capacity, add another (empty) slot. *) +let rec maybe_add_slot t current = + if current < t.max_slots then ( + if Atomic.compare_and_set t.slots current (current + 1) then add t (ref None) + else maybe_add_slot t (Atomic.get t.slots) (* Concurrent update; try again *) + ) + +(* [run_with t f slot] ensures that [slot] contains a valid resource and then runs [f resource] with it. + Afterwards, the slot is returned to [t]. *) +let run_with t f slot = + match + begin match !slot with + | Some x when t.validate x -> f x + | Some x -> + slot := None; + t.dispose x; + let x = t.alloc () in + slot := Some x; + f x + | None -> + let x = t.alloc () in + slot := Some x; + f x + end + with + | r -> + add t slot; + r + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + add t slot; + Printexc.raise_with_backtrace ex bt + +(* Creates a fresh resource [x], runs [f x], then disposes of [x] *) +let run_new_and_dispose t f = + let x = t.alloc () in + match f x with + | r -> + t.dispose x; + r + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + t.dispose x; + Printexc.raise_with_backtrace ex bt + +let use t ?(never_block=false) f = + let segment, cell = Q.next_suspend t.q in + match Atomic.get cell with + | Finished | Request _ -> assert false + | Resource slot -> + Atomic.set cell Finished; (* Allow value to be GC'd *) + run_with t f slot + | In_transition -> + let current = Atomic.get t.slots in + match current < t.max_slots with + | false when never_block -> ( + (* We are at capacity, but cannot block. + Create a new resource to run f but don't add it to the pool. *) + match Atomic.exchange cell Finished with + | Resource slot -> run_with t f slot + | _ -> run_new_and_dispose t f + ) + | can_add -> + (* Create a slot if not at capacity. *) + if can_add then maybe_add_slot t current; + (* No item is available right now. Start waiting *) + let slot = + Suspend.enter_unchecked "Pool.acquire" (fun ctx enqueue -> + let r x = enqueue (Ok x) in + if Atomic.compare_and_set cell In_transition (Request r) then ( + match Fiber_context.get_error ctx with + | Some ex -> + if cancel segment cell then enqueue (Error ex); + (* else being resumed *) + | None -> + Fiber_context.set_cancel_fn ctx (fun ex -> + if cancel segment cell then enqueue (Error ex) + (* else being resumed *) + ) + ) else ( + match Atomic.exchange cell Finished with + | Resource x -> enqueue (Ok x) + | _ -> assert false + ); + ) + in + (* assert (Atomic.get cell = Finished); *) + run_with t f slot diff --git a/lib_eio/pool.mli b/lib_eio/pool.mli index 0ed2265b4..8c0245d6f 100644 --- a/lib_eio/pool.mli +++ b/lib_eio/pool.mli @@ -1,46 +1,46 @@ -(** This is useful to manage a collection of resources where creating new ones is expensive - and so you want to reuse them where possible. - - Example: - - {[ - let buffer_pool = Eio.Pool.create 10 (fun () -> Bytes.create 1024) in - Eio.Pool.use buffer_pool (fun buf -> ...) - ]} - - Note: If you just need to limit how many resources are in use, it is simpler to use {!Eio.Semaphore} instead. -*) - -type 'a t - -val create : - ?validate:('a -> bool) -> - ?dispose:('a -> unit) -> - int -> - (unit -> 'a) -> - 'a t -(** [create n alloc] is a fresh pool which allows up to [n] resources to be live at a time. - It uses [alloc] to create new resources as needed. - If [alloc] raises an exception then that use fails, but future calls to {!use} will retry. - - The [alloc] function is called in the context of the fiber trying to use the pool. - - You should take care about handling cancellation in [alloc], since resources are typically - attached to a switch with the lifetime of the pool, meaning that if [alloc] fails then they won't - be freed automatically until the pool itself is finished. - - @param validate If given, this is used to check each resource before using it. - If it returns [false], the pool removes it with [dispose] and then allocates a fresh resource. - @param dispose Used to free resources rejected by [validate]. - If it raises, the exception is passed on to the user, - but resource is still considered to have been disposed. *) - -val use : 'a t -> ?never_block:bool -> ('a -> 'b) -> 'b -(** [use t fn] waits for some resource [x] to be available and then runs [f x]. - Afterwards (on success or error), [x] is returned to the pool. - - @param never_block If [true] and the pool has reached maximum capacity, - then a fresh resource is created to ensure that this [use] - call does not wait for a resource to become available. - This resource is immediately disposed after [f x] returns. - *) +(** This is useful to manage a collection of resources where creating new ones is expensive + and so you want to reuse them where possible. + + Example: + + {[ + let buffer_pool = Eio.Pool.create 10 (fun () -> Bytes.create 1024) in + Eio.Pool.use buffer_pool (fun buf -> ...) + ]} + + Note: If you just need to limit how many resources are in use, it is simpler to use {!Eio.Semaphore} instead. +*) + +type 'a t + +val create : + ?validate:('a -> bool) -> + ?dispose:('a -> unit) -> + int -> + (unit -> 'a) -> + 'a t +(** [create n alloc] is a fresh pool which allows up to [n] resources to be live at a time. + It uses [alloc] to create new resources as needed. + If [alloc] raises an exception then that use fails, but future calls to {!use} will retry. + + The [alloc] function is called in the context of the fiber trying to use the pool. + + You should take care about handling cancellation in [alloc], since resources are typically + attached to a switch with the lifetime of the pool, meaning that if [alloc] fails then they won't + be freed automatically until the pool itself is finished. + + @param validate If given, this is used to check each resource before using it. + If it returns [false], the pool removes it with [dispose] and then allocates a fresh resource. + @param dispose Used to free resources rejected by [validate]. + If it raises, the exception is passed on to the user, + but resource is still considered to have been disposed. *) + +val use : 'a t -> ?never_block:bool -> ('a -> 'b) -> 'b +(** [use t fn] waits for some resource [x] to be available and then runs [f x]. + Afterwards (on success or error), [x] is returned to the pool. + + @param never_block If [true] and the pool has reached maximum capacity, + then a fresh resource is created to ensure that this [use] + call does not wait for a resource to become available. + This resource is immediately disposed after [f x] returns. + *) diff --git a/lib_eio/process.ml b/lib_eio/process.ml index 587db13a4..e1255adaf 100644 --- a/lib_eio/process.ml +++ b/lib_eio/process.ml @@ -1,160 +1,160 @@ -open Std - -type exit_status = [ - | `Exited of int - | `Signaled of int -] - -type status = [ exit_status | `Stopped of int ] - -let pp_status ppf = function - | `Exited i -> Format.fprintf ppf "Exited (code %i)" i - | `Signaled i -> Format.fprintf ppf "Exited (signal %a)" Fmt.Dump.signal i - | `Stopped i -> Format.fprintf ppf "Stopped (signal %a)" Fmt.Dump.signal i - -type error = - | Executable_not_found of string - | Child_error of exit_status - -type Exn.err += E of error - -let err e = Exn.create (E e) - -let () = - Exn.register_pp (fun f -> function - | E e -> - Fmt.string f "Process "; - begin match e with - | Executable_not_found e -> Fmt.pf f "Executable %S not found" e; - | Child_error e -> Fmt.pf f "Child_error %a" pp_status e; - end; - true - | _ -> false - ) - -type 'tag ty = [ `Process | `Platform of 'tag ] - -type 'a t = ([> [> `Generic] ty] as 'a) r - -type 'tag mgr_ty = [ `Process_mgr | `Platform of 'tag ] - -type 'a mgr = 'a r - constraint 'a = [> [> `Generic] mgr_ty] - -module Pi = struct - module type PROCESS = sig - type t - type tag - - val pid : t -> int - val await : t -> exit_status - val signal : t -> int -> unit - end - - type (_, _, _) Resource.pi += - | Process : ('t, (module PROCESS with type t = 't and type tag = 'tag), [> 'tag ty]) Resource.pi - - let process (type t tag) (module X : PROCESS with type t = t and type tag = tag) = - Resource.handler [ - H (Process, (module X)); - ] - - module type MGR = sig - type tag - type t - - val pipe : - t -> - sw:Switch.t -> - [Flow.source_ty | Resource.close_ty] r * [Flow.sink_ty | Resource.close_ty] r - - val spawn : - t -> - sw:Switch.t -> - ?cwd:Fs.dir_ty Path.t -> - ?stdin:Flow.source_ty r -> - ?stdout:Flow.sink_ty r -> - ?stderr:Flow.sink_ty r -> - ?env:string array -> - ?executable:string -> - string list -> - tag ty r - end - - type (_, _, _) Resource.pi += - | Mgr : ('t, (module MGR with type t = 't and type tag = 'tag), [> 'tag mgr_ty]) Resource.pi - - let mgr (type t tag) (module X : MGR with type t = t and type tag = tag) = - Resource.handler [ - H (Mgr, (module X)); - ] -end - -let bad_char = function - | ' ' | '"' | '\'' | '\\' -> true - | c -> - let c = Char.code c in - c <= 32 || c >= 127 - -let pp_arg f x = - if x = "" || String.exists bad_char x then Fmt.pf f "%S" x - else Fmt.string f x - -let pp_args = Fmt.hbox (Fmt.list ~sep:Fmt.sp pp_arg) - -let await (type tag) ((Resource.T (v, ops)) : [> tag ty] r) = - let module X = (val (Resource.get ops Pi.Process)) in - X.await v - -let await_exn ?(is_success = Int.equal 0) proc = - match await proc with - | `Exited code when is_success code -> () - | status -> raise (err (Child_error status)) - -let pid (type tag) (t : [> tag ty] r) = - let (Resource.T (v, ops)) = t in - let module X = (val (Resource.get ops Pi.Process)) in - X.pid v - -let signal (type tag) (t : [> tag ty] r) s = - let (Resource.T (v, ops)) = t in - let module X = (val (Resource.get ops Pi.Process)) in - X.signal v s - -let spawn (type tag) ~sw (t : [> tag mgr_ty] r) ?cwd ?stdin ?stdout ?stderr ?env ?executable args : tag ty r = - let (Resource.T (v, ops)) = t in - let module X = (val (Resource.get ops Pi.Mgr)) in - X.spawn v ~sw - ?cwd:(cwd :> Fs.dir_ty Path.t option) - ?env - ?executable args - ?stdin:(stdin :> Flow.source_ty r option) - ?stdout:(stdout :> Flow.sink_ty r option) - ?stderr:(stderr :> Flow.sink_ty r option) - -let run t ?cwd ?stdin ?stdout ?stderr ?(is_success = Int.equal 0) ?env ?executable args = - Switch.run ~name:"Process.run" @@ fun sw -> - let child = spawn ~sw t ?cwd ?stdin ?stdout ?stderr ?env ?executable args in - match await child with - | `Exited code when is_success code -> () - | status -> - let ex = err (Child_error status) in - raise (Exn.add_context ex "running command: %a" pp_args args) - -let pipe (type tag) ~sw ((Resource.T (v, ops)) : [> tag mgr_ty] r) = - let module X = (val (Resource.get ops Pi.Mgr)) in - X.pipe v ~sw - -let parse_out (type tag) (t : [> tag mgr_ty] r) parse ?cwd ?stdin ?stderr ?is_success ?env ?executable args = - Switch.run ~name:"Process.parse_out" @@ fun sw -> - let r, w = pipe t ~sw in - try - let child = spawn ~sw t ?cwd ?stdin ~stdout:w ?stderr ?env ?executable args in - Flow.close w; - let output = Buf_read.parse_exn parse r ~max_size:max_int in - Flow.close r; - await_exn ?is_success child; - output - with Exn.Io _ as ex -> - let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "running command: %a" pp_args args +open Std + +type exit_status = [ + | `Exited of int + | `Signaled of int +] + +type status = [ exit_status | `Stopped of int ] + +let pp_status ppf = function + | `Exited i -> Format.fprintf ppf "Exited (code %i)" i + | `Signaled i -> Format.fprintf ppf "Exited (signal %a)" Fmt.Dump.signal i + | `Stopped i -> Format.fprintf ppf "Stopped (signal %a)" Fmt.Dump.signal i + +type error = + | Executable_not_found of string + | Child_error of exit_status + +type Exn.err += E of error + +let err e = Exn.create (E e) + +let () = + Exn.register_pp (fun f -> function + | E e -> + Fmt.string f "Process "; + begin match e with + | Executable_not_found e -> Fmt.pf f "Executable %S not found" e; + | Child_error e -> Fmt.pf f "Child_error %a" pp_status e; + end; + true + | _ -> false + ) + +type 'tag ty = [ `Process | `Platform of 'tag ] + +type 'a t = ([> [> `Generic] ty] as 'a) r + +type 'tag mgr_ty = [ `Process_mgr | `Platform of 'tag ] + +type 'a mgr = 'a r + constraint 'a = [> [> `Generic] mgr_ty] + +module Pi = struct + module type PROCESS = sig + type t + type tag + + val pid : t -> int + val await : t -> exit_status + val signal : t -> int -> unit + end + + type (_, _, _) Resource.pi += + | Process : ('t, (module PROCESS with type t = 't and type tag = 'tag), [> 'tag ty]) Resource.pi + + let process (type t tag) (module X : PROCESS with type t = t and type tag = tag) = + Resource.handler [ + H (Process, (module X)); + ] + + module type MGR = sig + type tag + type t + + val pipe : + t -> + sw:Switch.t -> + [Flow.source_ty | Resource.close_ty] r * [Flow.sink_ty | Resource.close_ty] r + + val spawn : + t -> + sw:Switch.t -> + ?cwd:Fs.dir_ty Path.t -> + ?stdin:Flow.source_ty r -> + ?stdout:Flow.sink_ty r -> + ?stderr:Flow.sink_ty r -> + ?env:string array -> + ?executable:string -> + string list -> + tag ty r + end + + type (_, _, _) Resource.pi += + | Mgr : ('t, (module MGR with type t = 't and type tag = 'tag), [> 'tag mgr_ty]) Resource.pi + + let mgr (type t tag) (module X : MGR with type t = t and type tag = tag) = + Resource.handler [ + H (Mgr, (module X)); + ] +end + +let bad_char = function + | ' ' | '"' | '\'' | '\\' -> true + | c -> + let c = Char.code c in + c <= 32 || c >= 127 + +let pp_arg f x = + if x = "" || String.exists bad_char x then Fmt.pf f "%S" x + else Fmt.string f x + +let pp_args = Fmt.hbox (Fmt.list ~sep:Fmt.sp pp_arg) + +let await (type tag) ((Resource.T (v, ops)) : [> tag ty] r) = + let module X = (val (Resource.get ops Pi.Process)) in + X.await v + +let await_exn ?(is_success = Int.equal 0) proc = + match await proc with + | `Exited code when is_success code -> () + | status -> raise (err (Child_error status)) + +let pid (type tag) (t : [> tag ty] r) = + let (Resource.T (v, ops)) = t in + let module X = (val (Resource.get ops Pi.Process)) in + X.pid v + +let signal (type tag) (t : [> tag ty] r) s = + let (Resource.T (v, ops)) = t in + let module X = (val (Resource.get ops Pi.Process)) in + X.signal v s + +let spawn (type tag) ~sw (t : [> tag mgr_ty] r) ?cwd ?stdin ?stdout ?stderr ?env ?executable args : tag ty r = + let (Resource.T (v, ops)) = t in + let module X = (val (Resource.get ops Pi.Mgr)) in + X.spawn v ~sw + ?cwd:(cwd :> Fs.dir_ty Path.t option) + ?env + ?executable args + ?stdin:(stdin :> Flow.source_ty r option) + ?stdout:(stdout :> Flow.sink_ty r option) + ?stderr:(stderr :> Flow.sink_ty r option) + +let run t ?cwd ?stdin ?stdout ?stderr ?(is_success = Int.equal 0) ?env ?executable args = + Switch.run ~name:"Process.run" @@ fun sw -> + let child = spawn ~sw t ?cwd ?stdin ?stdout ?stderr ?env ?executable args in + match await child with + | `Exited code when is_success code -> () + | status -> + let ex = err (Child_error status) in + raise (Exn.add_context ex "running command: %a" pp_args args) + +let pipe (type tag) ~sw ((Resource.T (v, ops)) : [> tag mgr_ty] r) = + let module X = (val (Resource.get ops Pi.Mgr)) in + X.pipe v ~sw + +let parse_out (type tag) (t : [> tag mgr_ty] r) parse ?cwd ?stdin ?stderr ?is_success ?env ?executable args = + Switch.run ~name:"Process.parse_out" @@ fun sw -> + let r, w = pipe t ~sw in + try + let child = spawn ~sw t ?cwd ?stdin ~stdout:w ?stderr ?env ?executable args in + Flow.close w; + let output = Buf_read.parse_exn parse r ~max_size:max_int in + Flow.close r; + await_exn ?is_success child; + output + with Exn.Io _ as ex -> + let bt = Printexc.get_raw_backtrace () in + Exn.reraise_with_context ex bt "running command: %a" pp_args args diff --git a/lib_eio/process.mli b/lib_eio/process.mli index 5966bbd8f..11716ee21 100644 --- a/lib_eio/process.mli +++ b/lib_eio/process.mli @@ -1,195 +1,195 @@ -(** Example: - {[ - # Eio_main.run @@ fun env -> - let proc_mgr = Eio.Stdenv.process_mgr env in - Eio.Process.parse_out proc_mgr Eio.Buf_read.line ["echo"; "hello"] - ]} - *) - -open Std - -(** {2 Status and error types} *) - -type exit_status = [ - | `Exited of int (** Process exited with the given return code. *) - | `Signaled of int (** Process was killed by the given signal. *) -] - -type status = [ - | exit_status - | `Stopped of int (** Process was stopped (paused) by the given signal. *) -] - -val pp_status : [< status] Fmt.t - -type error = - | Executable_not_found of string (** The requested executable does not exist. *) - | Child_error of exit_status (** The process exited with an error status. *) - -type Exn.err += E of error - -val err : error -> exn -(** [err e] is [Eio.Exn.create (E e)] *) - -val pp_args : string list Fmt.t -(** Formats a list of arguments, quoting any that might cause confusion to the reader. - - This is intended for use in error messages and logging.*) - -(** {2 Types} *) - -type 'tag ty = [ `Process | `Platform of 'tag ] - -type 'a t = ([> [> `Generic] ty] as 'a) r -(** A process. *) - -type 'tag mgr_ty = [ `Process_mgr | `Platform of 'tag ] - -type 'a mgr = 'a r - constraint 'a = [> [> `Generic] mgr_ty] -(** A process manager capable of spawning new processes. *) - -(** {2 Processes} *) - -val pid : _ t -> int -(** [pid t] is the process ID of [t]. *) - -val await : _ t -> exit_status -(** [await t] waits for process [t] to exit and then reports the status. *) - -val await_exn : ?is_success:(int -> bool) -> _ t -> unit -(** Like {! await} except an exception is raised if does not return a successful - exit status. - - @param is_success Used to determine if an exit code is successful. - Default is [Int.equal 0]. *) - -val signal : _ t -> int -> unit -(** [signal t i] sends the signal [i] to process [t]. - - If the process has already exited then this does nothing - (it will not signal a different process, even if the PID has been reused). - - See {!Sys} for the signal numbers. *) - -val spawn : - sw:Switch.t -> - [> 'tag mgr_ty] r -> - ?cwd:Fs.dir_ty Path.t -> - ?stdin:_ Flow.source -> - ?stdout:_ Flow.sink -> - ?stderr:_ Flow.sink -> - ?env:string array -> - ?executable:string -> - string list -> 'tag ty r -(** [spawn ~sw mgr args] creates a new child process that is connected to the switch [sw]. - - The child process will be sent {! Sys.sigkill} when the switch is released. - - If the flows [stdin], [stdout] and [stderr] are not backed by file descriptors then - this also creates pipes and spawns fibers to copy the data as necessary. - If you need more control over file descriptors, see {!Eio_unix.Process}. - - @param cwd The current working directory of the process (default: same as parent process). - @param stdin The flow to attach to the process's standard input (default: same as parent process). - @param stdout A flow that the process's standard output goes to (default: same as parent process). - @param stderr A flow that the process's standard error goes to (default: same as parent process). - @param env The environment for the process (default: same as parent process). - @param executable The path of the executable to run. - If not given then the first item in [args] is used, - searching $PATH for it if necessary. *) - -val run : - _ mgr -> - ?cwd:_ Path.t -> - ?stdin:_ Flow.source -> - ?stdout:_ Flow.sink -> - ?stderr:_ Flow.sink -> - ?is_success:(int -> bool) -> - ?env:string array -> - ?executable:string -> - string list -> unit -(** [run] does {!spawn} followed by {!await_exn}, with the advantage that if the process fails then - the error message includes the command that failed. - - When [is_success] is provided, it is called with the exit code to determine whether it indicates success or failure. - Without [is_success], success requires the process to return an exit code of 0. - - Note: If [spawn] needed to create extra fibers to copy [stdin], etc, then it also waits for those to finish. *) - -val parse_out : - _ mgr -> - 'a Buf_read.parser -> - ?cwd:_ Path.t -> - ?stdin:_ Flow.source -> - ?stderr:_ Flow.sink -> - ?is_success:(int -> bool) -> - ?env:string array -> - ?executable:string -> - string list -> 'a -(** [parse_out mgr parser args] runs [args] and parses the child's stdout with [parser]. - - It also waits for the process to finish and checks its exit status is zero. - - Note that [parser] must consume the entire output of the process (like {!Buf_read.parse}). - - To return all the output as a string, use {!Buf_read.take_all} as the parser. - - This is a convenience wrapper around {!run}, - and the optional arguments have the same meanings. *) - -(** {2 Pipes} *) - -val pipe : sw:Switch.t -> _ mgr -> [Flow.source_ty | Resource.close_ty] r * [Flow.sink_ty | Resource.close_ty] r -(** [pipe ~sw mgr] creates a pipe backed by the OS. - - The flows can be used by {!spawn} without the need for extra fibers to copy the data. - This can be used to connect multiple processes together. *) - -(** {2 Provider Interface} *) -module Pi : sig - module type PROCESS = sig - type t - type tag - - val pid : t -> int - val await : t -> exit_status - val signal : t -> int -> unit - end - - type (_, _, _) Resource.pi += - | Process : ('t, (module PROCESS with type t = 't and type tag = 'tag), [> 'tag ty]) Resource.pi - - val process : - (module PROCESS with type t = 't and type tag = 'tag) -> - ('t, 'tag ty) Resource.handler - - module type MGR = sig - type tag - type t - - val pipe : - t -> - sw:Switch.t -> - [Flow.source_ty | Resource.close_ty] r * [Flow.sink_ty | Resource.close_ty] r - - val spawn : - t -> - sw:Switch.t -> - ?cwd:Fs.dir_ty Path.t -> - ?stdin:Flow.source_ty r -> - ?stdout:Flow.sink_ty r -> - ?stderr:Flow.sink_ty r -> - ?env:string array -> - ?executable:string -> - string list -> - tag ty r - end - - type (_, _, _) Resource.pi += - | Mgr : ('t, (module MGR with type t = 't and type tag = 'tag), [> 'tag mgr_ty]) Resource.pi - - val mgr : - (module MGR with type t = 't and type tag = 'tag) -> - ('t, 'tag mgr_ty) Resource.handler -end +(** Example: + {[ + # Eio_main.run @@ fun env -> + let proc_mgr = Eio.Stdenv.process_mgr env in + Eio.Process.parse_out proc_mgr Eio.Buf_read.line ["echo"; "hello"] + ]} + *) + +open Std + +(** {2 Status and error types} *) + +type exit_status = [ + | `Exited of int (** Process exited with the given return code. *) + | `Signaled of int (** Process was killed by the given signal. *) +] + +type status = [ + | exit_status + | `Stopped of int (** Process was stopped (paused) by the given signal. *) +] + +val pp_status : [< status] Fmt.t + +type error = + | Executable_not_found of string (** The requested executable does not exist. *) + | Child_error of exit_status (** The process exited with an error status. *) + +type Exn.err += E of error + +val err : error -> exn +(** [err e] is [Eio.Exn.create (E e)] *) + +val pp_args : string list Fmt.t +(** Formats a list of arguments, quoting any that might cause confusion to the reader. + + This is intended for use in error messages and logging.*) + +(** {2 Types} *) + +type 'tag ty = [ `Process | `Platform of 'tag ] + +type 'a t = ([> [> `Generic] ty] as 'a) r +(** A process. *) + +type 'tag mgr_ty = [ `Process_mgr | `Platform of 'tag ] + +type 'a mgr = 'a r + constraint 'a = [> [> `Generic] mgr_ty] +(** A process manager capable of spawning new processes. *) + +(** {2 Processes} *) + +val pid : _ t -> int +(** [pid t] is the process ID of [t]. *) + +val await : _ t -> exit_status +(** [await t] waits for process [t] to exit and then reports the status. *) + +val await_exn : ?is_success:(int -> bool) -> _ t -> unit +(** Like {! await} except an exception is raised if does not return a successful + exit status. + + @param is_success Used to determine if an exit code is successful. + Default is [Int.equal 0]. *) + +val signal : _ t -> int -> unit +(** [signal t i] sends the signal [i] to process [t]. + + If the process has already exited then this does nothing + (it will not signal a different process, even if the PID has been reused). + + See {!Sys} for the signal numbers. *) + +val spawn : + sw:Switch.t -> + [> 'tag mgr_ty] r -> + ?cwd:Fs.dir_ty Path.t -> + ?stdin:_ Flow.source -> + ?stdout:_ Flow.sink -> + ?stderr:_ Flow.sink -> + ?env:string array -> + ?executable:string -> + string list -> 'tag ty r +(** [spawn ~sw mgr args] creates a new child process that is connected to the switch [sw]. + + The child process will be sent {! Sys.sigkill} when the switch is released. + + If the flows [stdin], [stdout] and [stderr] are not backed by file descriptors then + this also creates pipes and spawns fibers to copy the data as necessary. + If you need more control over file descriptors, see {!Eio_unix.Process}. + + @param cwd The current working directory of the process (default: same as parent process). + @param stdin The flow to attach to the process's standard input (default: same as parent process). + @param stdout A flow that the process's standard output goes to (default: same as parent process). + @param stderr A flow that the process's standard error goes to (default: same as parent process). + @param env The environment for the process (default: same as parent process). + @param executable The path of the executable to run. + If not given then the first item in [args] is used, + searching $PATH for it if necessary. *) + +val run : + _ mgr -> + ?cwd:_ Path.t -> + ?stdin:_ Flow.source -> + ?stdout:_ Flow.sink -> + ?stderr:_ Flow.sink -> + ?is_success:(int -> bool) -> + ?env:string array -> + ?executable:string -> + string list -> unit +(** [run] does {!spawn} followed by {!await_exn}, with the advantage that if the process fails then + the error message includes the command that failed. + + When [is_success] is provided, it is called with the exit code to determine whether it indicates success or failure. + Without [is_success], success requires the process to return an exit code of 0. + + Note: If [spawn] needed to create extra fibers to copy [stdin], etc, then it also waits for those to finish. *) + +val parse_out : + _ mgr -> + 'a Buf_read.parser -> + ?cwd:_ Path.t -> + ?stdin:_ Flow.source -> + ?stderr:_ Flow.sink -> + ?is_success:(int -> bool) -> + ?env:string array -> + ?executable:string -> + string list -> 'a +(** [parse_out mgr parser args] runs [args] and parses the child's stdout with [parser]. + + It also waits for the process to finish and checks its exit status is zero. + + Note that [parser] must consume the entire output of the process (like {!Buf_read.parse}). + + To return all the output as a string, use {!Buf_read.take_all} as the parser. + + This is a convenience wrapper around {!run}, + and the optional arguments have the same meanings. *) + +(** {2 Pipes} *) + +val pipe : sw:Switch.t -> _ mgr -> [Flow.source_ty | Resource.close_ty] r * [Flow.sink_ty | Resource.close_ty] r +(** [pipe ~sw mgr] creates a pipe backed by the OS. + + The flows can be used by {!spawn} without the need for extra fibers to copy the data. + This can be used to connect multiple processes together. *) + +(** {2 Provider Interface} *) +module Pi : sig + module type PROCESS = sig + type t + type tag + + val pid : t -> int + val await : t -> exit_status + val signal : t -> int -> unit + end + + type (_, _, _) Resource.pi += + | Process : ('t, (module PROCESS with type t = 't and type tag = 'tag), [> 'tag ty]) Resource.pi + + val process : + (module PROCESS with type t = 't and type tag = 'tag) -> + ('t, 'tag ty) Resource.handler + + module type MGR = sig + type tag + type t + + val pipe : + t -> + sw:Switch.t -> + [Flow.source_ty | Resource.close_ty] r * [Flow.sink_ty | Resource.close_ty] r + + val spawn : + t -> + sw:Switch.t -> + ?cwd:Fs.dir_ty Path.t -> + ?stdin:Flow.source_ty r -> + ?stdout:Flow.sink_ty r -> + ?stderr:Flow.sink_ty r -> + ?env:string array -> + ?executable:string -> + string list -> + tag ty r + end + + type (_, _, _) Resource.pi += + | Mgr : ('t, (module MGR with type t = 't and type tag = 'tag), [> 'tag mgr_ty]) Resource.pi + + val mgr : + (module MGR with type t = 't and type tag = 'tag) -> + ('t, 'tag mgr_ty) Resource.handler +end diff --git a/lib_eio/resource.ml b/lib_eio/resource.ml index 94db35b20..7a6984db7 100644 --- a/lib_eio/resource.ml +++ b/lib_eio/resource.ml @@ -1,35 +1,35 @@ -type ('t, 'impl, 'tags) pi = .. -type _ binding = H : ('t, 'impl, 'tags) pi * 'impl -> 't binding -type 't ops = 't binding array -type ('t, 'tags) handler = 't ops -type -'a t = T : ('t * 't ops) -> 'a t - -let not_supported () = failwith "Operation not supported!" - -let handler = Array.of_list -let bindings = Array.to_list - -let get : 't ops -> ('t, 'impl, 'tags) pi -> 'impl = fun ops op -> - let rec aux i = - if i = Array.length ops then not_supported (); - let H (k, v) = ops.(i) in - if Obj.repr k == Obj.repr op then Obj.magic v - else aux (i + 1) - in - aux 0 - -let get_opt : 't ops -> ('t, 'impl, 'tags) pi -> 'impl option = fun ops op -> - let rec aux i = - if i = Array.length ops then None - else ( - let H (k, v) = ops.(i) in - if Obj.repr k == Obj.repr op then Some (Obj.magic v) - else aux (i + 1) - ) - in - aux 0 - -type close_ty = [`Close] -type (_, _, _) pi += Close : ('t, 't -> unit, [> close_ty]) pi - -let close (T (t, ops)) = get ops Close t +type ('t, 'impl, 'tags) pi = .. +type _ binding = H : ('t, 'impl, 'tags) pi * 'impl -> 't binding +type 't ops = 't binding array +type ('t, 'tags) handler = 't ops +type -'a t = T : ('t * 't ops) -> 'a t + +let not_supported () = failwith "Operation not supported!" + +let handler = Array.of_list +let bindings = Array.to_list + +let get : 't ops -> ('t, 'impl, 'tags) pi -> 'impl = fun ops op -> + let rec aux i = + if i = Array.length ops then not_supported (); + let H (k, v) = ops.(i) in + if Obj.repr k == Obj.repr op then Obj.magic v + else aux (i + 1) + in + aux 0 + +let get_opt : 't ops -> ('t, 'impl, 'tags) pi -> 'impl option = fun ops op -> + let rec aux i = + if i = Array.length ops then None + else ( + let H (k, v) = ops.(i) in + if Obj.repr k == Obj.repr op then Some (Obj.magic v) + else aux (i + 1) + ) + in + aux 0 + +type close_ty = [`Close] +type (_, _, _) pi += Close : ('t, 't -> unit, [> close_ty]) pi + +let close (T (t, ops)) = get ops Close t diff --git a/lib_eio/resource.mli b/lib_eio/resource.mli index 545737e41..dde6c465e 100644 --- a/lib_eio/resource.mli +++ b/lib_eio/resource.mli @@ -1,114 +1,114 @@ -(** Resources are typically operating-system provided resources such as open files - and network sockets. However, they can also be pure OCaml resources (such as mocks) - or wrappers (such as an encrypted flow that wraps an unencrypted OS flow). - - A resource's type shows which interfaces it supports. For example, a - [[source | sink] t] is a resource that can be used as a source or a sink. - - If you are familiar with object types, this is roughly equivalent to the - type []. We avoid using object types here as some OCaml - programmers find them confusing. *) - -(** {2 Types} *) - -type ('t, -'tags) handler -(** A [('t, 'tags) handler] can be used to look up the implementation for a type ['t]. - - ['tags] is a phantom type to record which interfaces are supported. - - Internally, a handler is a set of {!type-binding}s. *) - -type -'tags t = T : ('t * ('t, 'tags) handler) -> 'tags t (** *) -(** A resource is a pair of a value and a handler for it. - - Normally there will be convenience functions provided for using resources - and you will not need to match on [T] yourself except when defining a new interface. *) - -(** {2 Defining new interfaces} - - These types and functions can be used to define new interfaces that others - can implement. - - When defining a new interface, you will typically provide: - - - The tags that indicate that the interface is supported (e.g. {!Flow.source_ty}). - - A convenience type to match all sub-types easily (e.g. {!Flow.source}). - - Functions allowing users to call the interface (e.g. {!Flow.single_read}). - - A module to let providers implement the interface (e.g. {!Flow.Pi}). -*) - -type ('t, 'iface, 'tag) pi = .. -(** A provider interface describes an interface that a resource can implement. - - - ['t] is the type of the resource itself. - - ['iface] is the API that can be requested. - - ['tag] is the tag (or tags) indicating that the interface is supported. - - For example, the value {!Close} (of type [(fd, fd -> unit, [> `Close]) pi]) can be - used with a resource backed by an [fd], and which offers at least the - [`Close] tag, to request its close function. - Often, the API requested will be a module type, but it can be a single function - as in this example. -*) - -type _ binding = H : ('t, 'impl, 'tags) pi * 'impl -> 't binding (** *) -(** A binding [H (pi, impl)] says to use [impl] to implement [pi]. - - For example: [H (Close, M.close)]. *) - -val handler : 't binding list -> ('t, _) handler -(** [handler ops] is a handler that looks up interfaces using the assoc list [ops]. - - For example [shutdown (module Foo)] is a handler that handles the [Close] and [Shutdown] - interfaces for resources of type [Foo.t] by using the [Foo] module: - - {[ - let shutdown (type t) (module X : SHUTDOWN with type t = t) : (t, shutdown_ty) handler = - handler [ - H (Close, X.close); - H (Shutdown, (module X)); - ] - ]} - - Be sure to give the return type explicitly, as this cannot be inferred. -*) - -val bindings : ('t, _) handler -> 't binding list -(** [bindings (handler ops) = ops]. - - This is useful if you want to extend an interface - and you already have a handler for that interface. *) - -val get : ('t, 'tags) handler -> ('t, 'impl, 'tags) pi -> 'impl -(** [get handler iface] uses [handler] to get the implementation of [iface]. - - For example: - {[ - let write (Resource.T (t, ops)) bufs = - let module X = (val (Resource.get ops Sink)) in - X.write t bufs - ]} -*) - -val get_opt : ('t, _) handler -> ('t, 'impl, _) pi -> 'impl option -(** [get_opt] is like {!get}, but the handler need not have a compatible type. - Instead, this performs a check at runtime and returns [None] if the interface - is not supported. *) - -(** {2 Closing} - - Resources are usually attached to switches and closed automatically when the switch - finishes. However, it can be useful to close them sooner in some cases. *) - -type close_ty = [`Close] -type (_, _, _) pi += Close : ('t, 't -> unit, [> close_ty]) pi - -val close : [> close_ty] t -> unit -(** [close t] marks the resource as closed. It can no longer be used after this. - - If [t] is already closed then this does nothing (it does not raise an exception). - - Note: if an operation is currently in progress when this is called then it is not - necessarily cancelled, and any underlying OS resource (such as a file descriptor) - might not be closed immediately if other operations are using it. Closing a resource - only prevents new operations from starting. *) +(** Resources are typically operating-system provided resources such as open files + and network sockets. However, they can also be pure OCaml resources (such as mocks) + or wrappers (such as an encrypted flow that wraps an unencrypted OS flow). + + A resource's type shows which interfaces it supports. For example, a + [[source | sink] t] is a resource that can be used as a source or a sink. + + If you are familiar with object types, this is roughly equivalent to the + type []. We avoid using object types here as some OCaml + programmers find them confusing. *) + +(** {2 Types} *) + +type ('t, -'tags) handler +(** A [('t, 'tags) handler] can be used to look up the implementation for a type ['t]. + + ['tags] is a phantom type to record which interfaces are supported. + + Internally, a handler is a set of {!type-binding}s. *) + +type -'tags t = T : ('t * ('t, 'tags) handler) -> 'tags t (** *) +(** A resource is a pair of a value and a handler for it. + + Normally there will be convenience functions provided for using resources + and you will not need to match on [T] yourself except when defining a new interface. *) + +(** {2 Defining new interfaces} + + These types and functions can be used to define new interfaces that others + can implement. + + When defining a new interface, you will typically provide: + + - The tags that indicate that the interface is supported (e.g. {!Flow.source_ty}). + - A convenience type to match all sub-types easily (e.g. {!Flow.source}). + - Functions allowing users to call the interface (e.g. {!Flow.single_read}). + - A module to let providers implement the interface (e.g. {!Flow.Pi}). +*) + +type ('t, 'iface, 'tag) pi = .. +(** A provider interface describes an interface that a resource can implement. + + - ['t] is the type of the resource itself. + - ['iface] is the API that can be requested. + - ['tag] is the tag (or tags) indicating that the interface is supported. + + For example, the value {!Close} (of type [(fd, fd -> unit, [> `Close]) pi]) can be + used with a resource backed by an [fd], and which offers at least the + [`Close] tag, to request its close function. + Often, the API requested will be a module type, but it can be a single function + as in this example. +*) + +type _ binding = H : ('t, 'impl, 'tags) pi * 'impl -> 't binding (** *) +(** A binding [H (pi, impl)] says to use [impl] to implement [pi]. + + For example: [H (Close, M.close)]. *) + +val handler : 't binding list -> ('t, _) handler +(** [handler ops] is a handler that looks up interfaces using the assoc list [ops]. + + For example [shutdown (module Foo)] is a handler that handles the [Close] and [Shutdown] + interfaces for resources of type [Foo.t] by using the [Foo] module: + + {[ + let shutdown (type t) (module X : SHUTDOWN with type t = t) : (t, shutdown_ty) handler = + handler [ + H (Close, X.close); + H (Shutdown, (module X)); + ] + ]} + + Be sure to give the return type explicitly, as this cannot be inferred. +*) + +val bindings : ('t, _) handler -> 't binding list +(** [bindings (handler ops) = ops]. + + This is useful if you want to extend an interface + and you already have a handler for that interface. *) + +val get : ('t, 'tags) handler -> ('t, 'impl, 'tags) pi -> 'impl +(** [get handler iface] uses [handler] to get the implementation of [iface]. + + For example: + {[ + let write (Resource.T (t, ops)) bufs = + let module X = (val (Resource.get ops Sink)) in + X.write t bufs + ]} +*) + +val get_opt : ('t, _) handler -> ('t, 'impl, _) pi -> 'impl option +(** [get_opt] is like {!get}, but the handler need not have a compatible type. + Instead, this performs a check at runtime and returns [None] if the interface + is not supported. *) + +(** {2 Closing} + + Resources are usually attached to switches and closed automatically when the switch + finishes. However, it can be useful to close them sooner in some cases. *) + +type close_ty = [`Close] +type (_, _, _) pi += Close : ('t, 't -> unit, [> close_ty]) pi + +val close : [> close_ty] t -> unit +(** [close t] marks the resource as closed. It can no longer be used after this. + + If [t] is already closed then this does nothing (it does not raise an exception). + + Note: if an operation is currently in progress when this is called then it is not + necessarily cancelled, and any underlying OS resource (such as a file descriptor) + might not be closed immediately if other operations are using it. Closing a resource + only prevents new operations from starting. *) diff --git a/lib_eio/runtime_events/dune b/lib_eio/runtime_events/dune index 6ba2acc86..17ab1f58c 100644 --- a/lib_eio/runtime_events/dune +++ b/lib_eio/runtime_events/dune @@ -1,4 +1,4 @@ -(library - (name eio_runtime_events) - (public_name eio.runtime_events) - (libraries runtime_events)) +(library + (name eio_runtime_events) + (public_name eio.runtime_events) + (libraries runtime_events)) diff --git a/lib_eio/runtime_events/eio_runtime_events.ml b/lib_eio/runtime_events/eio_runtime_events.ml index e1d50de3a..3fcc2ec05 100644 --- a/lib_eio/runtime_events/eio_runtime_events.ml +++ b/lib_eio/runtime_events/eio_runtime_events.ml @@ -1,294 +1,294 @@ -type id = int - -type obj_ty = - | Promise - | Semaphore - | Stream - | Mutex - -let obj_ty_to_uint8 = function - | Promise -> 15 - | Semaphore -> 16 - | Stream -> 18 - | Mutex -> 19 - -let obj_ty_of_uint8 = function - | 15 -> Promise - | 16 -> Semaphore - | 18 -> Stream - | 19 -> Mutex - | _ -> assert false - -let obj_ty_to_string (t : obj_ty) = - match t with - | Promise -> "promise" - | Semaphore -> "semaphore" - | Stream -> "stream" - | Mutex -> "mutex" - -type cc_ty = - | Switch - | Protect - | Sub - | Root - | Any - -let cc_ty_to_uint8 = function - | Switch -> 3 - | Protect -> 4 - | Sub -> 5 - | Root -> 6 - | Any -> 7 - -let cc_ty_of_uint8 = function - | 3 -> Switch - | 4 -> Protect - | 5 -> Sub - | 6 -> Root - | 7 -> Any - | _ -> assert false - -let cc_ty_to_string = function - | Switch -> "switch" - | Protect -> "protect" - | Sub -> "sub" - | Root -> "root" - | Any -> "any" - -let string = - let encode buf s = - let len = min (Bytes.length buf) (String.length s) in - Bytes.blit_string s 0 buf 0 len; - len - in - let decode buf len = Bytes.sub_string buf 0 len in - Runtime_events.Type.register ~encode ~decode - -let id_obj_type = - let encode buf (id, ty) = - Bytes.set_int64_le buf 0 (Int64.of_int id); - Bytes.set_int8 buf 8 (obj_ty_to_uint8 ty); - 9 - in - let decode buf _size = - let id = Bytes.get_int64_le buf 0 |> Int64.to_int in - let ty = obj_ty_of_uint8 (Bytes.get_int8 buf 8) in - (id, ty) - in - Runtime_events.Type.register ~encode ~decode - -let id_id_type = - let encode buf (id1, id2) = - Bytes.set_int64_le buf 0 (Int64.of_int id1); - Bytes.set_int64_le buf 8 (Int64.of_int id2); - 16 - in - let decode buf _size = - let id1 = Bytes.get_int64_le buf 0 |> Int64.to_int in - let id2 = Bytes.get_int64_le buf 8 |> Int64.to_int in - (id1, id2) - in - Runtime_events.Type.register ~encode ~decode - -let id_cc_type = - let encode buf (id, ty) = - Bytes.set_int64_le buf 0 (Int64.of_int id); - Bytes.set_int8 buf 8 (cc_ty_to_uint8 ty); - 9 - in - let decode buf _size = - let id = Bytes.get_int64_le buf 0 |> Int64.to_int in - let ty = cc_ty_of_uint8 (Bytes.get_int8 buf 8) in - (id, ty) - in - Runtime_events.Type.register ~encode ~decode - -let id_string_type = - let encode buf (id, msg) = - (* Check size of buf and use smallest size which means we may - have to truncate the label. *) - let available_buf_len = Bytes.length buf - 8 in - let msg_len = String.length msg in - let data_len = min available_buf_len msg_len in - Bytes.set_int64_le buf 0 (Int64.of_int id); - Bytes.blit_string msg 0 buf 8 data_len; - data_len + 8 - in - let decode buf size = - let id = Bytes.get_int64_le buf 0 |> Int64.to_int in - (id, Bytes.sub_string buf 8 (size - 8)) - in - Runtime_events.Type.register ~encode ~decode - -let exn_type = - let encode buf (id, exn) = - (* Check size of buf and use smallest size which means we may - have to truncate the label. *) - let available_buf_len = Bytes.length buf - 8 in - let msg = Printexc.to_string exn in - let msg_len = String.length msg in - let data_len = min available_buf_len msg_len in - Bytes.set_int64_le buf 0 (Int64.of_int id); - Bytes.blit_string msg 0 buf 8 data_len; - data_len + 8 - in - let decode buf size = - let id = Bytes.get_int64_le buf 0 |> Int64.to_int in - (id, Failure (Bytes.sub_string buf 8 (size - 8))) - in - Runtime_events.Type.register ~encode ~decode - -(* Runtime events registration *) - -type Runtime_events.User.tag += - | Create_obj - | Create_fiber - | Get - | Create_cc - | Try_get - | Put - | Error - | Exit_cc - | Exit_fiber - | Name - | Log - | Enter_span - | Exit_span - | Suspend_fiber - | Fiber - | Suspend_domain - | Domain_spawn - -let create_obj = Runtime_events.User.register "eio.create_obj" Create_obj id_obj_type -let create_cc = Runtime_events.User.register "eio.create_cc" Create_cc id_cc_type -let create_fiber = Runtime_events.User.register "eio.create_fiber" Create_fiber id_id_type - -let get = Runtime_events.User.register "eio.get" Get Runtime_events.Type.int -let try_get = Runtime_events.User.register "eio.try_get" Try_get Runtime_events.Type.int -let put = Runtime_events.User.register "eio.put" Put Runtime_events.Type.int - -let exit_cc = Runtime_events.User.register "eio.exit_cc" Exit_cc Runtime_events.Type.unit -let exit_fiber = Runtime_events.User.register "eio.exit_fiber" Exit_fiber Runtime_events.Type.int -let error = Runtime_events.User.register "eio.error" Error exn_type - -let name = Runtime_events.User.register "eio.name" Name id_string_type -let log = Runtime_events.User.register "eio.log" Log string -let enter_span = Runtime_events.User.register "eio.enter_span" Enter_span string -let exit_span = Runtime_events.User.register "eio.exit_span" Exit_span Runtime_events.Type.unit - -let fiber = Runtime_events.User.register "eio.fiber" Fiber Runtime_events.Type.int -let suspend_fiber = Runtime_events.User.register "eio.suspend_fiber" Suspend_fiber string -let suspend_domain = Runtime_events.User.register "eio.suspend_domain" Suspend_domain Runtime_events.Type.span -let domain_spawn = Runtime_events.User.register "eio.domain_spawn" Domain_spawn Runtime_events.Type.int - -type event = [ - | `Create of id * [ - | `Fiber_in of id - | `Cc of cc_ty - | `Obj of obj_ty - ] - | `Fiber of id - | `Name of id * string - | `Log of string - | `Enter_span of string - | `Exit_span - | `Get of id - | `Try_get of id - | `Put of id - | `Error of (id * string) - | `Exit_cc - | `Exit_fiber of id - | `Suspend_domain of Runtime_events.Type.span - | `Suspend_fiber of string - | `Domain_spawn of id -] - -let pf = Format.fprintf - -let pp_event f (e : event) = - match e with - | `Create (id, `Fiber_in cc) -> pf f "create fiber %d in CC %d" id cc - | `Create (id, `Cc ty) -> pf f "create %s CC %d" (cc_ty_to_string ty) id - | `Create (id, `Obj ty) -> pf f "create %s %d" (obj_ty_to_string ty) id - | `Fiber id -> pf f "fiber %d is now running" id - | `Name (id, name) -> pf f "%d is named %S" id name - | `Log msg -> pf f "log: %S" msg - | `Enter_span op -> pf f "enter span %S" op - | `Exit_span -> pf f "exit span" - | `Get id -> pf f "get from %d" id - | `Try_get id -> pf f "waiting to get from %d" id - | `Put id -> pf f "put %d" id - | `Error (id, msg) -> pf f "%d fails: %S" id msg - | `Exit_cc -> pf f "CC finishes" - | `Exit_fiber id -> pf f "fiber %d finishes" id - | `Suspend_domain Begin -> pf f "domain suspend" - | `Suspend_domain End -> pf f "domain resume" - | `Suspend_fiber op -> pf f "fiber suspended: %s" op - | `Domain_spawn parent -> pf f "domain spawned by fiber %d" parent - -type 'a handler = int -> Runtime_events.Timestamp.t -> 'a -> unit - -let add_callbacks (fn : event handler) x = - let create_event ring_id ts ev (id, ty) = - match Runtime_events.User.tag ev with - | Create_obj -> fn ring_id ts (`Create (id, `Obj ty)) - | _ -> () - in - let create_cc_event ring_id ts ev (id, ty) = - match Runtime_events.User.tag ev with - | Create_cc -> fn ring_id ts (`Create (id, `Cc ty)) - | _ -> () - in - let int_event ring_id ts ev v = - match Runtime_events.User.tag ev with - | Get -> fn ring_id ts (`Get v) - | Try_get -> fn ring_id ts (`Try_get v) - | Put -> fn ring_id ts (`Put v) - | Fiber -> fn ring_id ts (`Fiber v) - | Exit_fiber -> fn ring_id ts (`Exit_fiber v) - | Domain_spawn -> fn ring_id ts (`Domain_spawn v) - | _ -> () - in - let span_event ring_id ts ev v = - match Runtime_events.User.tag ev with - | Suspend_domain -> fn ring_id ts (`Suspend_domain v) - | _ -> () - in - let id_id_event ring_id ts ev (id1, id2) = - match Runtime_events.User.tag ev with - | Create_fiber -> fn ring_id ts (`Create (id1, `Fiber_in id2)) - | _ -> () - in - let int_exn_event ring_id ts ev (id, ex) = - match Runtime_events.User.tag ev, ex with - | Error, Failure msg -> fn ring_id ts (`Error (id, msg)) - | _ -> () - in - let id_string_event ring_id ts ev v = - match Runtime_events.User.tag ev with - | Name -> fn ring_id ts (`Name v) - | _ -> () - in - let string_event ring_id ts ev v = - match Runtime_events.User.tag ev with - | Log -> fn ring_id ts (`Log v) - | Enter_span -> fn ring_id ts (`Enter_span v) - | Suspend_fiber -> fn ring_id ts (`Suspend_fiber v) - | _ -> () - in - let unit_event ring_id ts ev () = - match Runtime_events.User.tag ev with - | Exit_cc -> fn ring_id ts `Exit_cc - | Exit_span -> fn ring_id ts `Exit_span - | _ -> () - in - x - |> Runtime_events.Callbacks.add_user_event id_obj_type create_event - |> Runtime_events.Callbacks.add_user_event id_id_type id_id_event - |> Runtime_events.Callbacks.add_user_event id_cc_type create_cc_event - |> Runtime_events.Callbacks.add_user_event Runtime_events.Type.int int_event - |> Runtime_events.Callbacks.add_user_event exn_type int_exn_event - |> Runtime_events.Callbacks.add_user_event string string_event - |> Runtime_events.Callbacks.add_user_event id_string_type id_string_event - |> Runtime_events.Callbacks.add_user_event Runtime_events.Type.span span_event - |> Runtime_events.Callbacks.add_user_event Runtime_events.Type.unit unit_event +type id = int + +type obj_ty = + | Promise + | Semaphore + | Stream + | Mutex + +let obj_ty_to_uint8 = function + | Promise -> 15 + | Semaphore -> 16 + | Stream -> 18 + | Mutex -> 19 + +let obj_ty_of_uint8 = function + | 15 -> Promise + | 16 -> Semaphore + | 18 -> Stream + | 19 -> Mutex + | _ -> assert false + +let obj_ty_to_string (t : obj_ty) = + match t with + | Promise -> "promise" + | Semaphore -> "semaphore" + | Stream -> "stream" + | Mutex -> "mutex" + +type cc_ty = + | Switch + | Protect + | Sub + | Root + | Any + +let cc_ty_to_uint8 = function + | Switch -> 3 + | Protect -> 4 + | Sub -> 5 + | Root -> 6 + | Any -> 7 + +let cc_ty_of_uint8 = function + | 3 -> Switch + | 4 -> Protect + | 5 -> Sub + | 6 -> Root + | 7 -> Any + | _ -> assert false + +let cc_ty_to_string = function + | Switch -> "switch" + | Protect -> "protect" + | Sub -> "sub" + | Root -> "root" + | Any -> "any" + +let string = + let encode buf s = + let len = min (Bytes.length buf) (String.length s) in + Bytes.blit_string s 0 buf 0 len; + len + in + let decode buf len = Bytes.sub_string buf 0 len in + Runtime_events.Type.register ~encode ~decode + +let id_obj_type = + let encode buf (id, ty) = + Bytes.set_int64_le buf 0 (Int64.of_int id); + Bytes.set_int8 buf 8 (obj_ty_to_uint8 ty); + 9 + in + let decode buf _size = + let id = Bytes.get_int64_le buf 0 |> Int64.to_int in + let ty = obj_ty_of_uint8 (Bytes.get_int8 buf 8) in + (id, ty) + in + Runtime_events.Type.register ~encode ~decode + +let id_id_type = + let encode buf (id1, id2) = + Bytes.set_int64_le buf 0 (Int64.of_int id1); + Bytes.set_int64_le buf 8 (Int64.of_int id2); + 16 + in + let decode buf _size = + let id1 = Bytes.get_int64_le buf 0 |> Int64.to_int in + let id2 = Bytes.get_int64_le buf 8 |> Int64.to_int in + (id1, id2) + in + Runtime_events.Type.register ~encode ~decode + +let id_cc_type = + let encode buf (id, ty) = + Bytes.set_int64_le buf 0 (Int64.of_int id); + Bytes.set_int8 buf 8 (cc_ty_to_uint8 ty); + 9 + in + let decode buf _size = + let id = Bytes.get_int64_le buf 0 |> Int64.to_int in + let ty = cc_ty_of_uint8 (Bytes.get_int8 buf 8) in + (id, ty) + in + Runtime_events.Type.register ~encode ~decode + +let id_string_type = + let encode buf (id, msg) = + (* Check size of buf and use smallest size which means we may + have to truncate the label. *) + let available_buf_len = Bytes.length buf - 8 in + let msg_len = String.length msg in + let data_len = min available_buf_len msg_len in + Bytes.set_int64_le buf 0 (Int64.of_int id); + Bytes.blit_string msg 0 buf 8 data_len; + data_len + 8 + in + let decode buf size = + let id = Bytes.get_int64_le buf 0 |> Int64.to_int in + (id, Bytes.sub_string buf 8 (size - 8)) + in + Runtime_events.Type.register ~encode ~decode + +let exn_type = + let encode buf (id, exn) = + (* Check size of buf and use smallest size which means we may + have to truncate the label. *) + let available_buf_len = Bytes.length buf - 8 in + let msg = Printexc.to_string exn in + let msg_len = String.length msg in + let data_len = min available_buf_len msg_len in + Bytes.set_int64_le buf 0 (Int64.of_int id); + Bytes.blit_string msg 0 buf 8 data_len; + data_len + 8 + in + let decode buf size = + let id = Bytes.get_int64_le buf 0 |> Int64.to_int in + (id, Failure (Bytes.sub_string buf 8 (size - 8))) + in + Runtime_events.Type.register ~encode ~decode + +(* Runtime events registration *) + +type Runtime_events.User.tag += + | Create_obj + | Create_fiber + | Get + | Create_cc + | Try_get + | Put + | Error + | Exit_cc + | Exit_fiber + | Name + | Log + | Enter_span + | Exit_span + | Suspend_fiber + | Fiber + | Suspend_domain + | Domain_spawn + +let create_obj = Runtime_events.User.register "eio.create_obj" Create_obj id_obj_type +let create_cc = Runtime_events.User.register "eio.create_cc" Create_cc id_cc_type +let create_fiber = Runtime_events.User.register "eio.create_fiber" Create_fiber id_id_type + +let get = Runtime_events.User.register "eio.get" Get Runtime_events.Type.int +let try_get = Runtime_events.User.register "eio.try_get" Try_get Runtime_events.Type.int +let put = Runtime_events.User.register "eio.put" Put Runtime_events.Type.int + +let exit_cc = Runtime_events.User.register "eio.exit_cc" Exit_cc Runtime_events.Type.unit +let exit_fiber = Runtime_events.User.register "eio.exit_fiber" Exit_fiber Runtime_events.Type.int +let error = Runtime_events.User.register "eio.error" Error exn_type + +let name = Runtime_events.User.register "eio.name" Name id_string_type +let log = Runtime_events.User.register "eio.log" Log string +let enter_span = Runtime_events.User.register "eio.enter_span" Enter_span string +let exit_span = Runtime_events.User.register "eio.exit_span" Exit_span Runtime_events.Type.unit + +let fiber = Runtime_events.User.register "eio.fiber" Fiber Runtime_events.Type.int +let suspend_fiber = Runtime_events.User.register "eio.suspend_fiber" Suspend_fiber string +let suspend_domain = Runtime_events.User.register "eio.suspend_domain" Suspend_domain Runtime_events.Type.span +let domain_spawn = Runtime_events.User.register "eio.domain_spawn" Domain_spawn Runtime_events.Type.int + +type event = [ + | `Create of id * [ + | `Fiber_in of id + | `Cc of cc_ty + | `Obj of obj_ty + ] + | `Fiber of id + | `Name of id * string + | `Log of string + | `Enter_span of string + | `Exit_span + | `Get of id + | `Try_get of id + | `Put of id + | `Error of (id * string) + | `Exit_cc + | `Exit_fiber of id + | `Suspend_domain of Runtime_events.Type.span + | `Suspend_fiber of string + | `Domain_spawn of id +] + +let pf = Format.fprintf + +let pp_event f (e : event) = + match e with + | `Create (id, `Fiber_in cc) -> pf f "create fiber %d in CC %d" id cc + | `Create (id, `Cc ty) -> pf f "create %s CC %d" (cc_ty_to_string ty) id + | `Create (id, `Obj ty) -> pf f "create %s %d" (obj_ty_to_string ty) id + | `Fiber id -> pf f "fiber %d is now running" id + | `Name (id, name) -> pf f "%d is named %S" id name + | `Log msg -> pf f "log: %S" msg + | `Enter_span op -> pf f "enter span %S" op + | `Exit_span -> pf f "exit span" + | `Get id -> pf f "get from %d" id + | `Try_get id -> pf f "waiting to get from %d" id + | `Put id -> pf f "put %d" id + | `Error (id, msg) -> pf f "%d fails: %S" id msg + | `Exit_cc -> pf f "CC finishes" + | `Exit_fiber id -> pf f "fiber %d finishes" id + | `Suspend_domain Begin -> pf f "domain suspend" + | `Suspend_domain End -> pf f "domain resume" + | `Suspend_fiber op -> pf f "fiber suspended: %s" op + | `Domain_spawn parent -> pf f "domain spawned by fiber %d" parent + +type 'a handler = int -> Runtime_events.Timestamp.t -> 'a -> unit + +let add_callbacks (fn : event handler) x = + let create_event ring_id ts ev (id, ty) = + match Runtime_events.User.tag ev with + | Create_obj -> fn ring_id ts (`Create (id, `Obj ty)) + | _ -> () + in + let create_cc_event ring_id ts ev (id, ty) = + match Runtime_events.User.tag ev with + | Create_cc -> fn ring_id ts (`Create (id, `Cc ty)) + | _ -> () + in + let int_event ring_id ts ev v = + match Runtime_events.User.tag ev with + | Get -> fn ring_id ts (`Get v) + | Try_get -> fn ring_id ts (`Try_get v) + | Put -> fn ring_id ts (`Put v) + | Fiber -> fn ring_id ts (`Fiber v) + | Exit_fiber -> fn ring_id ts (`Exit_fiber v) + | Domain_spawn -> fn ring_id ts (`Domain_spawn v) + | _ -> () + in + let span_event ring_id ts ev v = + match Runtime_events.User.tag ev with + | Suspend_domain -> fn ring_id ts (`Suspend_domain v) + | _ -> () + in + let id_id_event ring_id ts ev (id1, id2) = + match Runtime_events.User.tag ev with + | Create_fiber -> fn ring_id ts (`Create (id1, `Fiber_in id2)) + | _ -> () + in + let int_exn_event ring_id ts ev (id, ex) = + match Runtime_events.User.tag ev, ex with + | Error, Failure msg -> fn ring_id ts (`Error (id, msg)) + | _ -> () + in + let id_string_event ring_id ts ev v = + match Runtime_events.User.tag ev with + | Name -> fn ring_id ts (`Name v) + | _ -> () + in + let string_event ring_id ts ev v = + match Runtime_events.User.tag ev with + | Log -> fn ring_id ts (`Log v) + | Enter_span -> fn ring_id ts (`Enter_span v) + | Suspend_fiber -> fn ring_id ts (`Suspend_fiber v) + | _ -> () + in + let unit_event ring_id ts ev () = + match Runtime_events.User.tag ev with + | Exit_cc -> fn ring_id ts `Exit_cc + | Exit_span -> fn ring_id ts `Exit_span + | _ -> () + in + x + |> Runtime_events.Callbacks.add_user_event id_obj_type create_event + |> Runtime_events.Callbacks.add_user_event id_id_type id_id_event + |> Runtime_events.Callbacks.add_user_event id_cc_type create_cc_event + |> Runtime_events.Callbacks.add_user_event Runtime_events.Type.int int_event + |> Runtime_events.Callbacks.add_user_event exn_type int_exn_event + |> Runtime_events.Callbacks.add_user_event string string_event + |> Runtime_events.Callbacks.add_user_event id_string_type id_string_event + |> Runtime_events.Callbacks.add_user_event Runtime_events.Type.span span_event + |> Runtime_events.Callbacks.add_user_event Runtime_events.Type.unit unit_event diff --git a/lib_eio/runtime_events/eio_runtime_events.mli b/lib_eio/runtime_events/eio_runtime_events.mli index b3eb69ef2..05d32b89e 100644 --- a/lib_eio/runtime_events/eio_runtime_events.mli +++ b/lib_eio/runtime_events/eio_runtime_events.mli @@ -1,76 +1,76 @@ -(** This library is used to write event traces using OCaml's runtime events infrastructure. *) - -type id = int - -type obj_ty = - | Promise - | Semaphore - | Stream - | Mutex -(** Types of recorded objects. *) - -val obj_ty_to_string : obj_ty -> string - -type cc_ty = - | Switch - | Protect - | Sub - | Root - | Any -(** Types of cancellation contexts. *) - -val cc_ty_to_string : cc_ty -> string - -(** {2 Writing events} *) - -val create_fiber : (id * id) Runtime_events.User.t -val create_cc : (id * cc_ty) Runtime_events.User.t -val create_obj : (id * obj_ty) Runtime_events.User.t -val log : string Runtime_events.User.t -val enter_span : string Runtime_events.User.t -val exit_span : unit Runtime_events.User.t -val name : (id * string) Runtime_events.User.t -val suspend_fiber : string Runtime_events.User.t -val exit_cc : unit Runtime_events.User.t -val exit_fiber : id Runtime_events.User.t -val error : (id * exn) Runtime_events.User.t -val fiber : id Runtime_events.User.t -val get : id Runtime_events.User.t -val try_get : id Runtime_events.User.t -val put : id Runtime_events.User.t -val suspend_domain : Runtime_events.Type.span Runtime_events.User.t -val domain_spawn : id Runtime_events.User.t - -(** {2 Consuming events} *) - -type event = [ - | `Create of id * [ - | `Fiber_in of id (** A new fiber is created in the given CC. *) - | `Cc of cc_ty (** The running fiber creates a new CC. *) - | `Obj of obj_ty (** The running fiber creates a new object. *) - ] - | `Fiber of id (** The given fiber is now running. *) - | `Name of id * string (** Names a promise, stream, etc. *) - | `Log of string (** The running fiber logs a message. *) - | `Enter_span of string (** The running fiber enters a traced section. *) - | `Exit_span (** The running fiber leaves the current traced section. *) - | `Get of id (** The running fiber gets a value from a promise, stream, acquires a lock, etc. *) - | `Try_get of id (** The running fiber wants to get, but must wait. *) - | `Put of id (** The running fiber resolves a promise, adds to a stream, releases a lock etc. *) - | `Error of (id * string) (** A CC fails with the given error. *) - | `Exit_cc (** The current CC ends. *) - | `Exit_fiber of id (** The running fiber ends. *) - | `Suspend_domain of Runtime_events.Type.span (** The domain asks the OS to wait for events. *) - | `Suspend_fiber of string (** The running fiber is suspended (until resumed by [`Fiber]). *) - | `Domain_spawn of id (** The current domain was spawned by fiber [id]. *) -] - -val pp_event : Format.formatter -> event -> unit -(** [pp_event] formats an event as a human-readable string *) - -val add_callbacks: - (int -> Runtime_events.Timestamp.t -> event -> unit) -> - Runtime_events.Callbacks.t -> Runtime_events.Callbacks.t -(** [add_callbacks fn x] adds event handler [fn] to [x]. - - When an Eio event is processed, it calls [fn ring_id ts event]. *) +(** This library is used to write event traces using OCaml's runtime events infrastructure. *) + +type id = int + +type obj_ty = + | Promise + | Semaphore + | Stream + | Mutex +(** Types of recorded objects. *) + +val obj_ty_to_string : obj_ty -> string + +type cc_ty = + | Switch + | Protect + | Sub + | Root + | Any +(** Types of cancellation contexts. *) + +val cc_ty_to_string : cc_ty -> string + +(** {2 Writing events} *) + +val create_fiber : (id * id) Runtime_events.User.t +val create_cc : (id * cc_ty) Runtime_events.User.t +val create_obj : (id * obj_ty) Runtime_events.User.t +val log : string Runtime_events.User.t +val enter_span : string Runtime_events.User.t +val exit_span : unit Runtime_events.User.t +val name : (id * string) Runtime_events.User.t +val suspend_fiber : string Runtime_events.User.t +val exit_cc : unit Runtime_events.User.t +val exit_fiber : id Runtime_events.User.t +val error : (id * exn) Runtime_events.User.t +val fiber : id Runtime_events.User.t +val get : id Runtime_events.User.t +val try_get : id Runtime_events.User.t +val put : id Runtime_events.User.t +val suspend_domain : Runtime_events.Type.span Runtime_events.User.t +val domain_spawn : id Runtime_events.User.t + +(** {2 Consuming events} *) + +type event = [ + | `Create of id * [ + | `Fiber_in of id (** A new fiber is created in the given CC. *) + | `Cc of cc_ty (** The running fiber creates a new CC. *) + | `Obj of obj_ty (** The running fiber creates a new object. *) + ] + | `Fiber of id (** The given fiber is now running. *) + | `Name of id * string (** Names a promise, stream, etc. *) + | `Log of string (** The running fiber logs a message. *) + | `Enter_span of string (** The running fiber enters a traced section. *) + | `Exit_span (** The running fiber leaves the current traced section. *) + | `Get of id (** The running fiber gets a value from a promise, stream, acquires a lock, etc. *) + | `Try_get of id (** The running fiber wants to get, but must wait. *) + | `Put of id (** The running fiber resolves a promise, adds to a stream, releases a lock etc. *) + | `Error of (id * string) (** A CC fails with the given error. *) + | `Exit_cc (** The current CC ends. *) + | `Exit_fiber of id (** The running fiber ends. *) + | `Suspend_domain of Runtime_events.Type.span (** The domain asks the OS to wait for events. *) + | `Suspend_fiber of string (** The running fiber is suspended (until resumed by [`Fiber]). *) + | `Domain_spawn of id (** The current domain was spawned by fiber [id]. *) +] + +val pp_event : Format.formatter -> event -> unit +(** [pp_event] formats an event as a human-readable string *) + +val add_callbacks: + (int -> Runtime_events.Timestamp.t -> event -> unit) -> + Runtime_events.Callbacks.t -> Runtime_events.Callbacks.t +(** [add_callbacks fn x] adds event handler [fn] to [x]. + + When an Eio event is processed, it calls [fn ring_id ts event]. *) diff --git a/lib_eio/sem_state.ml b/lib_eio/sem_state.ml index 59df3f18a..48895fc63 100644 --- a/lib_eio/sem_state.ml +++ b/lib_eio/sem_state.ml @@ -1,176 +1,176 @@ -(* A lock-free semaphore, using Cells. - - We have a number of resources (1 in the case of a mutex). Each time a user - wants a resource, the user decrements the counter. When finished with the - resource, the user increments the counter again. - - If there are more users than resources then the counter will be negative. If - a user decrements the counter to a non-negative value then it gets ownership - of one of the free resources. If it decrements the counter to a negative - value then it must wait (by allocating a cell). When a user with a resource - increments the counter *from* a negative value, that user is responsible for - resuming one waiting cell (transferring ownership of the resource). This - ensures that every waiter will get woken exactly once. - - Cancellation - - We could consider cancelling a request to be simply replacing the callback - with a dummy one that immediately releases the resource. However, if callers - keep cancelling then the list of cancelled requests would keep growing. - - Instead, we'd like cancellation simply to undo the effects of suspending, by - incrementing the counter and marking the cell as Finished (so that the - resumer will ignore it and move on to the next waiter, and the Finished - cell can be freed). - - If the cancelling user increments from a negative value then it is responsible - for waking one user, which is fine as it is waking itself. However, it may find - itself incrementing from a non-negative one if it is racing with a resumer - (if the count is non-negative then once all current operations finish there - would be no suspended users, so the process of waking this user must have - already begun). - - To handle this, a cancelling user first transitions the cell to In_transition, - then increments the counter, then transitions to the final Finished state, - in the usual case where it incremented from a negative value. - - If a resumer runs at the same time then it may also increment the counter - from a non-negative value and try to wake this cell. It transitions the cell - from In_transition to Finished. The cancelling user will notice this when it - fails to CAS to Finished and can handle it. - - If the cancelling user sees the Finished state after In_transition then it - knows that the resuming user has transferred to it the responsibility of - waking one user. If the cancelling user is also responsible for waking one - user then it performs an extra resume on behalf of the resuming user. - - Finally, if the cancelling user is not responsible for waking anyone (even - itself) then it leaves the cell in In_transition (the CQS paper uses a - separate Refused state, but we don't actually need that). This can only - happen when a resume is happening at the same time. The resumer will - transition to Finished, creating an obligation to resume, but we've just - done that anyway. We know this In_transition state can't last long because - at the moment when the canceller incremented the counter all current - waiters, including itself, were in the process of being resumed. *) - -module Cell = struct - type _ t = - | In_transition (* The suspender will try to CAS this soon. *) - | Request of (unit -> unit) (* Waiting for a resource. *) - | Finished (* Ownership of the resource has been transferred, - or the suspender cancelled. *) - - let init = In_transition - (* We only resume when we know another thread is suspended or in the process of suspending. *) - - let segment_order = 2 - - let dump f = function - | Request _ -> Fmt.string f "Request" - | Finished -> Fmt.string f "Finished" - | In_transition -> Fmt.string f "In_transition" -end - -module Cells = Cells.Make(Cell) - -type cell = unit Cell.t - -type t = { - state : int Atomic.t; (* Free resources. Negative if there are waiters waiting. *) - cells : unit Cells.t; -} - -type request = t * unit Cells.segment * unit Cell.t Atomic.t - -(* Wake one waiter (and give it the resource being released). *) -let rec resume t = - let cell = Cells.next_resume t.cells in - match (Atomic.exchange cell Finished : cell) with - | Request r -> - (* The common case: there was a waiter for the value. - We pass ownership of the resource to it. *) - r () - | Finished -> - (* The waiter has finished cancelling. Ignore it and resume the next one. *) - resume t - | In_transition -> - (* The consumer is in the middle of doing something and will soon try to - CAS to a new state. It will see that we got there first and handle the - resume when it's done. *) - () - -(* [true] on success, or [false] if we need to suspend. - You MUST call [suspend] iff this returns [false]. - The reason for splitting this is because e.g. [Semaphore] needs to get - the continuation for the fiber between [acquire] and [suspend]. *) -let acquire t = - let s = Atomic.fetch_and_add t.state (-1) in - (* We got a resource if we decremented *to* a non-negative number, - which happens if we decremented *from* a positive one. *) - s > 0 - -let suspend t k : request option = - let (segment, cell) = Cells.next_suspend t.cells in - if Atomic.compare_and_set cell In_transition (Request k) then Some (t, segment, cell) - else match Atomic.get cell with - | Finished -> - (* We got resumed before we could add the waiter. *) - k (); - None - | Request _ | In_transition -> - (* These are unreachable from the previously-observed non-In_transition state - without us taking some action first *) - assert false - -let release t = - let s = Atomic.fetch_and_add t.state (+1) in - if s < 0 then ( - (* We incremented from a negative value. - We are therefore responsible for waking one waiter. *) - resume t - ) - -let cancel (t, segment, cell) = - match (Atomic.get cell : cell) with - | Request _ as old -> - if Atomic.compare_and_set cell old In_transition then ( - (* Undo the effect of [acquire] by incrementing the counter. - As always, if we increment from a negative value then we need to resume one waiter. *) - let need_resume = Atomic.fetch_and_add t.state (+1) < 0 in - if need_resume then ( - if Atomic.compare_and_set cell In_transition Finished then ( - (* The normal case. We resumed ourself by cancelling. - This is the only case we need to tell the segment because in all - other cases the resumer has already reached this segment so - freeing it is pointless. *) - Cells.cancel_cell segment - ) else ( - (* [release] got called at the same time and it also needed to resume one waiter. - So we call [resume] to handle the extra one, in addition to resuming ourself. *) - resume t - ) - ) else ( - (* This can only happen if [release] ran at the same time and incremented the counter - before we did. Since we were suspended, and later we saw the counter - show that no one was, it must have decided to wake us. Either it has placed Finished - in the cell, or it's about to do so. Either way, we discharge the obligation to - wake someone by resuming ourself with a cancellation. - The resource returns to the free pool. We know the resumer has already finished with it - even if it hasn't updated the cell state yet. *) - ); - true - ) else false (* We got resumed first *) - | Finished -> false (* We got resumed first *) - | In_transition -> invalid_arg "Already cancelling!" - -let dump f t = - Fmt.pf f "Semaphore (state=%d)@,%a" - (Atomic.get t.state) - Cells.dump t.cells - -let create n = - if n < 0 then raise (Invalid_argument "n < 0"); - { - cells = Cells.make (); - state = Atomic.make n; - } +(* A lock-free semaphore, using Cells. + + We have a number of resources (1 in the case of a mutex). Each time a user + wants a resource, the user decrements the counter. When finished with the + resource, the user increments the counter again. + + If there are more users than resources then the counter will be negative. If + a user decrements the counter to a non-negative value then it gets ownership + of one of the free resources. If it decrements the counter to a negative + value then it must wait (by allocating a cell). When a user with a resource + increments the counter *from* a negative value, that user is responsible for + resuming one waiting cell (transferring ownership of the resource). This + ensures that every waiter will get woken exactly once. + + Cancellation + + We could consider cancelling a request to be simply replacing the callback + with a dummy one that immediately releases the resource. However, if callers + keep cancelling then the list of cancelled requests would keep growing. + + Instead, we'd like cancellation simply to undo the effects of suspending, by + incrementing the counter and marking the cell as Finished (so that the + resumer will ignore it and move on to the next waiter, and the Finished + cell can be freed). + + If the cancelling user increments from a negative value then it is responsible + for waking one user, which is fine as it is waking itself. However, it may find + itself incrementing from a non-negative one if it is racing with a resumer + (if the count is non-negative then once all current operations finish there + would be no suspended users, so the process of waking this user must have + already begun). + + To handle this, a cancelling user first transitions the cell to In_transition, + then increments the counter, then transitions to the final Finished state, + in the usual case where it incremented from a negative value. + + If a resumer runs at the same time then it may also increment the counter + from a non-negative value and try to wake this cell. It transitions the cell + from In_transition to Finished. The cancelling user will notice this when it + fails to CAS to Finished and can handle it. + + If the cancelling user sees the Finished state after In_transition then it + knows that the resuming user has transferred to it the responsibility of + waking one user. If the cancelling user is also responsible for waking one + user then it performs an extra resume on behalf of the resuming user. + + Finally, if the cancelling user is not responsible for waking anyone (even + itself) then it leaves the cell in In_transition (the CQS paper uses a + separate Refused state, but we don't actually need that). This can only + happen when a resume is happening at the same time. The resumer will + transition to Finished, creating an obligation to resume, but we've just + done that anyway. We know this In_transition state can't last long because + at the moment when the canceller incremented the counter all current + waiters, including itself, were in the process of being resumed. *) + +module Cell = struct + type _ t = + | In_transition (* The suspender will try to CAS this soon. *) + | Request of (unit -> unit) (* Waiting for a resource. *) + | Finished (* Ownership of the resource has been transferred, + or the suspender cancelled. *) + + let init = In_transition + (* We only resume when we know another thread is suspended or in the process of suspending. *) + + let segment_order = 2 + + let dump f = function + | Request _ -> Fmt.string f "Request" + | Finished -> Fmt.string f "Finished" + | In_transition -> Fmt.string f "In_transition" +end + +module Cells = Cells.Make(Cell) + +type cell = unit Cell.t + +type t = { + state : int Atomic.t; (* Free resources. Negative if there are waiters waiting. *) + cells : unit Cells.t; +} + +type request = t * unit Cells.segment * unit Cell.t Atomic.t + +(* Wake one waiter (and give it the resource being released). *) +let rec resume t = + let cell = Cells.next_resume t.cells in + match (Atomic.exchange cell Finished : cell) with + | Request r -> + (* The common case: there was a waiter for the value. + We pass ownership of the resource to it. *) + r () + | Finished -> + (* The waiter has finished cancelling. Ignore it and resume the next one. *) + resume t + | In_transition -> + (* The consumer is in the middle of doing something and will soon try to + CAS to a new state. It will see that we got there first and handle the + resume when it's done. *) + () + +(* [true] on success, or [false] if we need to suspend. + You MUST call [suspend] iff this returns [false]. + The reason for splitting this is because e.g. [Semaphore] needs to get + the continuation for the fiber between [acquire] and [suspend]. *) +let acquire t = + let s = Atomic.fetch_and_add t.state (-1) in + (* We got a resource if we decremented *to* a non-negative number, + which happens if we decremented *from* a positive one. *) + s > 0 + +let suspend t k : request option = + let (segment, cell) = Cells.next_suspend t.cells in + if Atomic.compare_and_set cell In_transition (Request k) then Some (t, segment, cell) + else match Atomic.get cell with + | Finished -> + (* We got resumed before we could add the waiter. *) + k (); + None + | Request _ | In_transition -> + (* These are unreachable from the previously-observed non-In_transition state + without us taking some action first *) + assert false + +let release t = + let s = Atomic.fetch_and_add t.state (+1) in + if s < 0 then ( + (* We incremented from a negative value. + We are therefore responsible for waking one waiter. *) + resume t + ) + +let cancel (t, segment, cell) = + match (Atomic.get cell : cell) with + | Request _ as old -> + if Atomic.compare_and_set cell old In_transition then ( + (* Undo the effect of [acquire] by incrementing the counter. + As always, if we increment from a negative value then we need to resume one waiter. *) + let need_resume = Atomic.fetch_and_add t.state (+1) < 0 in + if need_resume then ( + if Atomic.compare_and_set cell In_transition Finished then ( + (* The normal case. We resumed ourself by cancelling. + This is the only case we need to tell the segment because in all + other cases the resumer has already reached this segment so + freeing it is pointless. *) + Cells.cancel_cell segment + ) else ( + (* [release] got called at the same time and it also needed to resume one waiter. + So we call [resume] to handle the extra one, in addition to resuming ourself. *) + resume t + ) + ) else ( + (* This can only happen if [release] ran at the same time and incremented the counter + before we did. Since we were suspended, and later we saw the counter + show that no one was, it must have decided to wake us. Either it has placed Finished + in the cell, or it's about to do so. Either way, we discharge the obligation to + wake someone by resuming ourself with a cancellation. + The resource returns to the free pool. We know the resumer has already finished with it + even if it hasn't updated the cell state yet. *) + ); + true + ) else false (* We got resumed first *) + | Finished -> false (* We got resumed first *) + | In_transition -> invalid_arg "Already cancelling!" + +let dump f t = + Fmt.pf f "Semaphore (state=%d)@,%a" + (Atomic.get t.state) + Cells.dump t.cells + +let create n = + if n < 0 then raise (Invalid_argument "n < 0"); + { + cells = Cells.make (); + state = Atomic.make n; + } diff --git a/lib_eio/semaphore.ml b/lib_eio/semaphore.ml index bda6f03c8..cf97570fc 100644 --- a/lib_eio/semaphore.ml +++ b/lib_eio/semaphore.ml @@ -1,42 +1,42 @@ -type t = { - id : Trace.id; - state : Sem_state.t; -} - -let make n = - let id = Trace.mint_id () in - Trace.create_obj id Semaphore; - { - id; - state = Sem_state.create n; - } - -let release t = - Trace.put t.id; - Sem_state.release t.state - -let acquire t = - if not (Sem_state.acquire t.state) then ( - (* No free resources. - We must wait until one of the existing users increments the counter and resumes us. - It's OK if they resume before we suspend; we'll just pick up the token they left. *) - Suspend.enter_unchecked "Semaphore.acquire" (fun ctx enqueue -> - match Sem_state.suspend t.state (fun () -> enqueue (Ok ())) with - | None -> () (* Already resumed *) - | Some request -> - Trace.try_get t.id; - match Fiber_context.get_error ctx with - | Some ex -> - if Sem_state.cancel request then enqueue (Error ex); - (* else already resumed *) - | None -> - Fiber_context.set_cancel_fn ctx (fun ex -> - if Sem_state.cancel request then enqueue (Error ex) - (* else already resumed *) - ) - ) - ); - Trace.get t.id - -let get_value t = - max 0 (Atomic.get t.state.state) +type t = { + id : Trace.id; + state : Sem_state.t; +} + +let make n = + let id = Trace.mint_id () in + Trace.create_obj id Semaphore; + { + id; + state = Sem_state.create n; + } + +let release t = + Trace.put t.id; + Sem_state.release t.state + +let acquire t = + if not (Sem_state.acquire t.state) then ( + (* No free resources. + We must wait until one of the existing users increments the counter and resumes us. + It's OK if they resume before we suspend; we'll just pick up the token they left. *) + Suspend.enter_unchecked "Semaphore.acquire" (fun ctx enqueue -> + match Sem_state.suspend t.state (fun () -> enqueue (Ok ())) with + | None -> () (* Already resumed *) + | Some request -> + Trace.try_get t.id; + match Fiber_context.get_error ctx with + | Some ex -> + if Sem_state.cancel request then enqueue (Error ex); + (* else already resumed *) + | None -> + Fiber_context.set_cancel_fn ctx (fun ex -> + if Sem_state.cancel request then enqueue (Error ex) + (* else already resumed *) + ) + ) + ); + Trace.get t.id + +let get_value t = + max 0 (Atomic.get t.state.state) diff --git a/lib_eio/semaphore.mli b/lib_eio/semaphore.mli index 0f4abf142..af1803787 100644 --- a/lib_eio/semaphore.mli +++ b/lib_eio/semaphore.mli @@ -1,27 +1,27 @@ -(** The API is based on OCaml's [Semaphore.Counting]. - - The difference is that when waiting for the semaphore this will switch to the next runnable fiber, - whereas the stdlib one will block the whole domain. - - Semaphores are thread-safe and so can be shared between domains and used - to synchronise between them. *) - -type t -(** The type of counting semaphores. *) - -val make : int -> t -(** [make n] returns a new counting semaphore, with initial value [n]. - The initial value [n] must be nonnegative. - @raise Invalid_argument if [n < 0] *) - -val release : t -> unit -(** [release t] increments the value of semaphore [t]. - If other fibers are waiting on [t], the one that has been waiting the longest is resumed. - @raise Sys_error if the value of the semaphore would overflow [max_int] *) - -val acquire : t -> unit -(** [acquire t] blocks the calling fiber until the value of semaphore [t] - is not zero, then atomically decrements the value of [t] and returns. *) - -val get_value : t -> int -(** [get_value t] returns the current value of semaphore [t]. *) +(** The API is based on OCaml's [Semaphore.Counting]. + + The difference is that when waiting for the semaphore this will switch to the next runnable fiber, + whereas the stdlib one will block the whole domain. + + Semaphores are thread-safe and so can be shared between domains and used + to synchronise between them. *) + +type t +(** The type of counting semaphores. *) + +val make : int -> t +(** [make n] returns a new counting semaphore, with initial value [n]. + The initial value [n] must be nonnegative. + @raise Invalid_argument if [n < 0] *) + +val release : t -> unit +(** [release t] increments the value of semaphore [t]. + If other fibers are waiting on [t], the one that has been waiting the longest is resumed. + @raise Sys_error if the value of the semaphore would overflow [max_int] *) + +val acquire : t -> unit +(** [acquire t] blocks the calling fiber until the value of semaphore [t] + is not zero, then atomically decrements the value of [t] and returns. *) + +val get_value : t -> int +(** [get_value t] returns the current value of semaphore [t]. *) diff --git a/lib_eio/std.ml b/lib_eio/std.ml index 84fff968f..86f7c2c36 100644 --- a/lib_eio/std.ml +++ b/lib_eio/std.ml @@ -1,5 +1,5 @@ -module Promise = Eio__core.Promise -module Fiber = Eio__core.Fiber -module Switch = Eio__core.Switch -type 'a r = 'a Resource.t -let traceln = Debug.traceln +module Promise = Eio__core.Promise +module Fiber = Eio__core.Fiber +module Switch = Eio__core.Switch +type 'a r = 'a Resource.t +let traceln = Debug.traceln diff --git a/lib_eio/std.mli b/lib_eio/std.mli index 4c7478e8d..ba7cdbc88 100644 --- a/lib_eio/std.mli +++ b/lib_eio/std.mli @@ -1,10 +1,10 @@ -module Promise = Eio__core.Promise -module Fiber = Eio__core.Fiber -module Switch = Eio__core.Switch - -type 'a r = 'a Resource.t - -val traceln : - ?__POS__:string * int * int * int -> - ('a, Format.formatter, unit, unit) format4 -> 'a - (** Same as {!Eio.traceln}. *) +module Promise = Eio__core.Promise +module Fiber = Eio__core.Fiber +module Switch = Eio__core.Switch + +type 'a r = 'a Resource.t + +val traceln : + ?__POS__:string * int * int * int -> + ('a, Format.formatter, unit, unit) format4 -> 'a + (** Same as {!Eio.traceln}. *) diff --git a/lib_eio/stream.ml b/lib_eio/stream.ml index 83d6687a3..9fc80f34e 100644 --- a/lib_eio/stream.ml +++ b/lib_eio/stream.ml @@ -1,141 +1,141 @@ -module Locking = struct - type 'a t = { - mutex : Mutex.t; - - id : Trace.id; - - capacity : int; (* [capacity > 0] *) - items : 'a Queue.t; - - (* Readers suspended because [items] is empty. *) - readers : 'a Waiters.t; - - (* Writers suspended because [items] is at capacity. *) - writers : unit Waiters.t; - } - - let with_mutex t f = - Mutex.lock t.mutex; - match f () with - | x -> Mutex.unlock t.mutex; x - | exception ex -> Mutex.unlock t.mutex; raise ex - - (* Invariants *) - let _validate t = - with_mutex t @@ fun () -> - assert (Queue.length t.items <= t.capacity); - assert (Waiters.is_empty t.readers || Queue.is_empty t.items); - assert (Waiters.is_empty t.writers || Queue.length t.items = t.capacity) - - let create capacity = - assert (capacity > 0); - let id = Trace.mint_id () in - Trace.create_obj id Stream; - { - mutex = Mutex.create (); - id; - capacity; - items = Queue.create (); - readers = Waiters.create (); - writers = Waiters.create (); - } - - let add t item = - Mutex.lock t.mutex; - match Waiters.wake_one t.readers item with - | `Ok -> Mutex.unlock t.mutex - | `Queue_empty -> - (* No-one is waiting for an item. Queue it. *) - if Queue.length t.items < t.capacity then ( - Queue.add item t.items; - Mutex.unlock t.mutex - ) else ( - (* The queue is full. Wait for our turn first. *) - Suspend.enter_unchecked "Stream.add" @@ fun ctx enqueue -> - Waiters.await_internal ~mutex:(Some t.mutex) t.writers ctx (fun r -> - (* This is called directly from [wake_one] and so we have the lock. - We're still running in [wake_one]'s domain here. *) - if Result.is_ok r then ( - (* We get here immediately when called by [take], after removing an item, - so there is space *) - Queue.add item t.items; - ); - enqueue r - ) - ) - - let take t = - Mutex.lock t.mutex; - match Queue.take_opt t.items with - | None -> - (* There aren't any items, so we need to wait for one. *) - let x = Waiters.await ~mutex:(Some t.mutex) "Stream.take" t.readers in - Trace.get t.id; - x - | Some v -> - (* If anyone was waiting for space, let the next one go. - [is_empty writers || length items = t.capacity - 1] *) - begin match Waiters.wake_one t.writers () with - | `Ok (* [length items = t.capacity] again *) - | `Queue_empty -> () (* [is_empty writers] *) - end; - Mutex.unlock t.mutex; - v - - let take_nonblocking t = - Mutex.lock t.mutex; - match Queue.take_opt t.items with - | None -> Mutex.unlock t.mutex; None (* There aren't any items. *) - | Some v -> - (* If anyone was waiting for space, let the next one go. - [is_empty writers || length items = t.capacity - 1] *) - begin match Waiters.wake_one t.writers () with - | `Ok (* [length items = t.capacity] again *) - | `Queue_empty -> () (* [is_empty writers] *) - end; - Mutex.unlock t.mutex; - Some v - - let length t = - Mutex.lock t.mutex; - let len = Queue.length t.items in - Mutex.unlock t.mutex; - len - - let dump f t = - Fmt.pf f "" (length t) t.capacity -end - -type 'a t = - | Sync of 'a Sync.t - | Locking of 'a Locking.t - -let create = function - | 0 -> Sync (Sync.create ()) - | capacity -> Locking (Locking.create capacity) - -let add t v = - match t with - | Sync x -> Sync.put x v - | Locking x -> Locking.add x v - -let take = function - | Sync x -> Sync.take x |> Result.get_ok (* todo: allow closing streams *) - | Locking x -> Locking.take x - -let take_nonblocking = function - | Locking x -> Locking.take_nonblocking x - | Sync x -> - match Sync.take_nonblocking x with - | Ok x -> Some x - | Error `Closed | Error `Would_block -> None - -let length = function - | Sync _ -> 0 - | Locking x -> Locking.length x - -let is_empty t = (length t = 0) - -let dump f = function - | Sync x -> Sync.dump f x - | Locking x -> Locking.dump f x +module Locking = struct + type 'a t = { + mutex : Mutex.t; + + id : Trace.id; + + capacity : int; (* [capacity > 0] *) + items : 'a Queue.t; + + (* Readers suspended because [items] is empty. *) + readers : 'a Waiters.t; + + (* Writers suspended because [items] is at capacity. *) + writers : unit Waiters.t; + } + + let with_mutex t f = + Mutex.lock t.mutex; + match f () with + | x -> Mutex.unlock t.mutex; x + | exception ex -> Mutex.unlock t.mutex; raise ex + + (* Invariants *) + let _validate t = + with_mutex t @@ fun () -> + assert (Queue.length t.items <= t.capacity); + assert (Waiters.is_empty t.readers || Queue.is_empty t.items); + assert (Waiters.is_empty t.writers || Queue.length t.items = t.capacity) + + let create capacity = + assert (capacity > 0); + let id = Trace.mint_id () in + Trace.create_obj id Stream; + { + mutex = Mutex.create (); + id; + capacity; + items = Queue.create (); + readers = Waiters.create (); + writers = Waiters.create (); + } + + let add t item = + Mutex.lock t.mutex; + match Waiters.wake_one t.readers item with + | `Ok -> Mutex.unlock t.mutex + | `Queue_empty -> + (* No-one is waiting for an item. Queue it. *) + if Queue.length t.items < t.capacity then ( + Queue.add item t.items; + Mutex.unlock t.mutex + ) else ( + (* The queue is full. Wait for our turn first. *) + Suspend.enter_unchecked "Stream.add" @@ fun ctx enqueue -> + Waiters.await_internal ~mutex:(Some t.mutex) t.writers ctx (fun r -> + (* This is called directly from [wake_one] and so we have the lock. + We're still running in [wake_one]'s domain here. *) + if Result.is_ok r then ( + (* We get here immediately when called by [take], after removing an item, + so there is space *) + Queue.add item t.items; + ); + enqueue r + ) + ) + + let take t = + Mutex.lock t.mutex; + match Queue.take_opt t.items with + | None -> + (* There aren't any items, so we need to wait for one. *) + let x = Waiters.await ~mutex:(Some t.mutex) "Stream.take" t.readers in + Trace.get t.id; + x + | Some v -> + (* If anyone was waiting for space, let the next one go. + [is_empty writers || length items = t.capacity - 1] *) + begin match Waiters.wake_one t.writers () with + | `Ok (* [length items = t.capacity] again *) + | `Queue_empty -> () (* [is_empty writers] *) + end; + Mutex.unlock t.mutex; + v + + let take_nonblocking t = + Mutex.lock t.mutex; + match Queue.take_opt t.items with + | None -> Mutex.unlock t.mutex; None (* There aren't any items. *) + | Some v -> + (* If anyone was waiting for space, let the next one go. + [is_empty writers || length items = t.capacity - 1] *) + begin match Waiters.wake_one t.writers () with + | `Ok (* [length items = t.capacity] again *) + | `Queue_empty -> () (* [is_empty writers] *) + end; + Mutex.unlock t.mutex; + Some v + + let length t = + Mutex.lock t.mutex; + let len = Queue.length t.items in + Mutex.unlock t.mutex; + len + + let dump f t = + Fmt.pf f "" (length t) t.capacity +end + +type 'a t = + | Sync of 'a Sync.t + | Locking of 'a Locking.t + +let create = function + | 0 -> Sync (Sync.create ()) + | capacity -> Locking (Locking.create capacity) + +let add t v = + match t with + | Sync x -> Sync.put x v + | Locking x -> Locking.add x v + +let take = function + | Sync x -> Sync.take x |> Result.get_ok (* todo: allow closing streams *) + | Locking x -> Locking.take x + +let take_nonblocking = function + | Locking x -> Locking.take_nonblocking x + | Sync x -> + match Sync.take_nonblocking x with + | Ok x -> Some x + | Error `Closed | Error `Would_block -> None + +let length = function + | Sync _ -> 0 + | Locking x -> Locking.length x + +let is_empty t = (length t = 0) + +let dump f = function + | Sync x -> Sync.dump f x + | Locking x -> Locking.dump f x diff --git a/lib_eio/stream.mli b/lib_eio/stream.mli index 6554cac1a..d92e5ab98 100644 --- a/lib_eio/stream.mli +++ b/lib_eio/stream.mli @@ -1,50 +1,50 @@ -(** Reading from an empty queue will wait until an item is available. - Writing to a full queue will wait until there is space. - - Example: - {[ - let t = Stream.create 100 in - Stream.add t 1; - Stream.add t 2; - assert (Stream.take t = 1); - assert (Stream.take t = 2) - ]} - - Streams are thread-safe and so can be shared between domains and used - to communicate between them. *) - -type 'a t -(** A queue of items of type ['a]. *) - -val create : int -> 'a t -(** [create capacity] is a new stream which can hold up to [capacity] items without blocking writers. - - - If [capacity = 0] then writes block until a reader is ready. - - If [capacity = 1] then this acts as a "mailbox". - - If [capacity = max_int] then the stream is effectively unbounded. *) - -val add : 'a t -> 'a -> unit -(** [add t item] adds [item] to [t]. - - If this would take [t] over capacity, it blocks until there is space. *) - -val take : 'a t -> 'a -(** [take t] takes the next item from the head of [t]. - - If no items are available, it waits until one becomes available. *) - -val take_nonblocking : 'a t -> 'a option -(** [take_nonblocking t] is like [Some (take t)] except that - it returns [None] if the stream is empty rather than waiting. - - Note that if another domain may add to the stream then a [None] - result may already be out-of-date by the time this returns. *) - -val length : 'a t -> int -(** [length t] returns the number of items currently in [t]. *) - -val is_empty : 'a t -> bool -(** [is_empty t] is [length t = 0]. *) - -val dump : 'a t Fmt.t -(** For debugging. *) +(** Reading from an empty queue will wait until an item is available. + Writing to a full queue will wait until there is space. + + Example: + {[ + let t = Stream.create 100 in + Stream.add t 1; + Stream.add t 2; + assert (Stream.take t = 1); + assert (Stream.take t = 2) + ]} + + Streams are thread-safe and so can be shared between domains and used + to communicate between them. *) + +type 'a t +(** A queue of items of type ['a]. *) + +val create : int -> 'a t +(** [create capacity] is a new stream which can hold up to [capacity] items without blocking writers. + + - If [capacity = 0] then writes block until a reader is ready. + - If [capacity = 1] then this acts as a "mailbox". + - If [capacity = max_int] then the stream is effectively unbounded. *) + +val add : 'a t -> 'a -> unit +(** [add t item] adds [item] to [t]. + + If this would take [t] over capacity, it blocks until there is space. *) + +val take : 'a t -> 'a +(** [take t] takes the next item from the head of [t]. + + If no items are available, it waits until one becomes available. *) + +val take_nonblocking : 'a t -> 'a option +(** [take_nonblocking t] is like [Some (take t)] except that + it returns [None] if the stream is empty rather than waiting. + + Note that if another domain may add to the stream then a [None] + result may already be out-of-date by the time this returns. *) + +val length : 'a t -> int +(** [length t] returns the number of items currently in [t]. *) + +val is_empty : 'a t -> bool +(** [is_empty t] is [length t = 0]. *) + +val dump : 'a t Fmt.t +(** For debugging. *) diff --git a/lib_eio/sync.ml b/lib_eio/sync.ml index 9b5bc4f09..1330f858f 100644 --- a/lib_eio/sync.ml +++ b/lib_eio/sync.ml @@ -1,552 +1,552 @@ -(* A lock-free synchronous channel with cancellation, using Cells. - - Producers and consumers are paired off and then the producer transfers its - value to the consumer. This is effectively a bounded queue with a capacity - of zero. - - Both producers and consumers can cancel while waiting. - - There is an atomic int ([balance]), plus two queues ([consumers] and - [producers]) made using Cells. When [balance] is positive, it is the number - of producers waiting with values that no one is yet responsible for - resuming. When negative, it is the (negative) number of waiting consumers - that no one is responsible for resuming. - - To put an item: - - 1. The producer increments [balance]. - 2. If it was negative, the producer resumes one waiting consumer on the [consumers] queue. - Otherwise, it suspends itself on the [producers] queue. - - To take an item: - - 1. The consumer decrements [balance]. - 2. If it was positive, the consumer resumes one waiting producer on the [producers] queue. - Otherwise, it suspends itself on the [consumers] queue. - - Therefore, we never try to resume on a queue unless another party has - started the process of suspending on it. - - The system will not become idle while a client is responsible for resuming - something. Therefore, when idle: - - - If [balance <= 0] then there are no waiting producers. - - If [balance >= 0] then there are no waiting consumers. - - So, we never have waiting consumers and producers at the same time. - - As usual with Cells, either party may get to the new cell first. Whichever party - arrives first writes a callback, which the other party will then call when they arrive. - - Note on terminology: - - - The "suspender" of a cell is the party that incremented the queue's suspend index, - and the "resumer" of a cell is the party that incremented the resume index. - - - Whether "suspending" or "resuming" a cell, you may still have to suspend - your fiber and resume it later. - - States - - There are four cell states: - - - [In_transition] indicates that the cell is still being initialised, or might be - getting cancelled. Either way, the suspending party is actively working to - change the cell's state. - - - [Item] indicates that the producer is ready to provide an item. - - - [Slot] indicates that the consumer is ready to receive an item. - - - [Finished] indicates that the cell is no longer being used (the value has - been consumed or the cell has finished being cancelled). - - The possible sequences of states on the [producers] queue are: - - In_transition -C> Slot -P> Finished (consumer arrives first) - `P> Item -C> Finished (producer arrives first) - `P> In_transition -P> Finished (producer cancels) - `C> Slot -P> Finished (cancellation interrupted) - - Only the producer can cancel here. For the [consumers] queue it's the - opposite - the consumer can cancel its [Slot]. - - Cancellation - - Note that there are two kinds of cancellation here: - - 1. A cancelled cell is not considered part of its queue. Anyone seeing one - (due to a race) will skip over it and use the next cell. - - 2. After a consumer and producer have been paired off (and the cell removed - from its queue), the consumer callback may reject the value. If this - happens, the producer must start all over again to find another consumer. - - Whenever a consumer sets its callback to reject values, it should then start - the process of cancelling its cell (if acting as a suspender) so that the - cell can be GC'd. - - A consumer can only cancel its cell when it's on the [consumers] queue. - If it's on [producers], it knows a wake up will be coming shortly anyway. - A consumer cancels its cell as follows: - - 1. The consumer sets its cell in [consumers] to [In_transition]. - 2. It increments [balance] (from a negative value). It is now committed to cancelling. - 3. It sets its cell to [Finished]. - - (1) will fail if the cell got resumed first. In that case the consumer just - rejects the cancellation attempt. - - (2) will fail if [balance >= 0]. In that case the consumer has not cancelled, - and is about to be resumed instead. It tries to return to the [Slot] state. - If that fails, the cell now contains an Item and the consumer takes it. - - (3) will fail if a producer arrived after the consumer committed to cancelling. - In that case, the consumer passes the Item on to the next consumer (there - must be another one, since both the consumer and producer incremented - [balance] from a negative value). - - Cancelling a producer is very similar to cancelling a consumer, just with the - [producers] queue and decrementing the balance from a positive value. - - Non-blocking take - - To perform a non-blocking take: - - 1. The consumer decrements [balance] from a positive number. - 2. The consumer takes the next resume cell from [producers]. - 3. The consumer takes the [Item] from the cell, setting it to [Finished]. - - (1) will fail if there are no unassigned items available. - Then the [take_nonblocking] returns [None], as there are no items waiting. - - (3) will fail if the producer is initialising or cancelling. In either case, - the consumer sets its cell to a request with a dummy callback that rejects - all values and continues immediately. - - Close - - The LSB of the balance atomic is used to indicate that the stream has been closed. - When closed, the balance is always zero and no new consumers or producers can be added. - The closing thread is responsible for cancelling all pre-existing users. - - The exchange - - Once a producer and consumer have been paired off (and so their cell is now Finished), - the producer's value is passed to the consumer's callback. If the consumer accepts it, - then both fibers are resumed. If not, the producer starts again (incrementing [balance] - again) and waits for another consumer. - - The above has not been formally verified (exercise for reader!). *) - -(* Import these directly because we copy this file for the dscheck tests. *) -module Fiber_context = Eio__core.Private.Fiber_context -module Suspend = Eio__core.Private.Suspend -module Cancel = Eio__core.Cancel - -type producer_result = - | Sent (* Consumer accepted item. *) - | Rejected (* Consumer rejected the item. Retry. *) - | Failed of exn (* Cancelled or closed. *) - -type 'a item = { - v : ('a, [`Closed]) result; - kp : producer_result -> unit; - cancel : [ - | `Resuming (* In the process of resuming, so can't cancel. *) - | `Suspended of (unit -> bool) (* Call this function to attempt to leave the queue. *) - | `Cancelled of exn (* Already cancelled. *) - ] Atomic.t; -} - -type 'a cell = - | In_transition - | Slot of (('a, [`Closed]) result -> bool) - | Item of 'a item - | Finished - -module Cell = struct - type 'a t = 'a cell - - let init = In_transition - - let segment_order = 2 - - let dump f = function - | In_transition -> Fmt.string f "In_transition" - | Slot _ -> Fmt.string f "Slot" - | Item _ -> Fmt.string f "Item" - | Finished -> Fmt.string f "Finished" -end - -module Q = Cells.Make(Cell) - -type update_result = - | Updated - | Update_refused - | Balance_closed - -module Balance : sig - type t - - val make : unit -> t - - val close : t -> (int, [> `Closed]) result - (* Mark as closed and return the previous state. *) - - val get : t -> (int, [> `Closed]) result - (** [get t] is the number of items available (if non-negative) or the - number of consumers waiting for an item. *) - - val fetch_and_add : t -> int -> (int, [> `Closed]) result - (** [fetch_and_add t diff] increases the value by [diff] and returns the old value. *) - - val incr_if_negative : t -> update_result - val decr_if_positive : t -> update_result - - val pp : t Fmt.t -end = struct - type t = int Atomic.t - - let closed = 1 - let counter x = x asr 1 - let is_closed x = (x land 1) <> 0 - - let value x = - if is_closed x then Error `Closed else Ok (counter x) - - let fetch_and_add x diff = - value (Atomic.fetch_and_add x (diff lsl 1)) - - let rec decr_if_positive t = - let x = Atomic.get t in - if is_closed x then Balance_closed - else if counter x > 0 then ( - if Atomic.compare_and_set t x (x - 2) then Updated - else decr_if_positive t - ) else Update_refused - - let rec incr_if_negative t = - let x = Atomic.get t in - if is_closed x then Balance_closed - else if counter x < 0 then ( - if Atomic.compare_and_set t x (x + 2) then Updated - else incr_if_negative t - ) else Update_refused - - let make () = Atomic.make 0 - - let close t = - value (Atomic.exchange t closed) - - let get t = value (Atomic.get t) - - let pp f t = - match get t with - | Ok x -> Fmt.int f x - | Error `Closed -> Fmt.string f "(closed)" -end - -type 'a t = { - balance : Balance.t; - consumers : 'a Q.t; - producers : 'a Q.t; -} - -type 'a loc = - | Short of 'a Cell.t Atomic.t (* Acting as resumer of cell *) - | Long of ('a Q.segment * 'a Cell.t Atomic.t) (* Acting as suspender of cell; can cancel *) - -let dump f t = - Fmt.pf f "@[Sync (balance=%a)@,@[Consumers:@,%a@]@,@[Producers:@,%a@]@]" - Balance.pp t.balance - Q.dump t.consumers - Q.dump t.producers - -(* Give [item] to consumer [kc]. [item]'s cell is now Finished. *) -let exchange item kc = - item.kp (if kc item.v then Sent else Rejected) - -(* Add [value] to [cell]. - If the cell is in transition, place [value] there and let the other party handle it later. - If the peer's value is already present, do the exchange. - If the peer cancelled the cell then try the next one on the given resume queue (if we're adding - to a suspend queue then it can't be cancelled, because the caller controls cancellation). - This is only used when our fiber is already suspended, - since we can't create [value] before we have the continuation. *) -let rec add_to_cell queue value cell = - match Atomic.get cell, value with - | Finished, _ -> add_to_cell queue value (Q.next_resume queue) (* Cancelled - skip *) - | (Slot kc as old), Item item - | (Item item as old), Slot kc -> - if Atomic.compare_and_set cell old Finished then exchange item kc - else add_to_cell queue value cell - | In_transition, _ -> - if Atomic.compare_and_set cell In_transition value then () - else add_to_cell queue value cell - | (Slot _ | Item _), _ -> assert false - -(* Cancelling *) - -(* Cancel [cell] on our suspend queue. - This function works for both consumers and producers, as we can tell from - the value what our role is (and if there isn't a value, we're finished anyway). - Neither party will try to cancel before writing its own value. - Returns [true] if the caller cancelled successfully, - or [false] if it must wait (as it's being resumed). *) -let cancel t (segment, cell) = - let cancel2 update_balance ~old = - if Atomic.compare_and_set cell old In_transition then ( - match update_balance t.balance with - | Updated -> - (* At this point, we are committed to cancelling. *) - begin match Atomic.exchange cell Finished with - | Finished -> assert false - | In_transition -> Q.cancel_cell segment - | Item request -> add_to_cell t.consumers (Item request) (Q.next_resume t.consumers) - | Slot kc -> add_to_cell t.producers (Slot kc) (Q.next_resume t.producers) - end; - true - | Update_refused | Balance_closed -> - (* We decided not to cancel. We know a resume is coming. *) - if Atomic.compare_and_set cell In_transition old then false - else ( - match old, Atomic.get cell with - | Slot kc, Item request - | Item request, Slot kc -> - Atomic.set cell Finished; - exchange request kc; - false - | _ -> assert false - ) - ) else false (* The peer resumed us first *) - in - match Atomic.get cell with - | Finished -> false (* The peer resumed us first *) - | Slot _ as old -> cancel2 Balance.incr_if_negative ~old (* We are a consumer *) - | Item _ as old -> cancel2 Balance.decr_if_positive ~old (* We are a producer *) - | In_transition -> - (* Either we're initialising the cell, in which case we haven't told the - application how to cancel this location yet, or we're already - cancelling, but cancelling twice isn't permitted. *) - assert false - -(* A producer can't cancel if it is resuming on the [consumers] queue, and will instead - just wait for the slot in that case, which will arrive soon. However, after getting - a slot the producer may be rejected and be asked to start again on the [producers] queue, - so we need to remember that we were cancelled to prevent that. It's also possible that - we're already restarting but haven't got around to updating [request.cancel] yet; we'll - notice the new [`Cancelled] state when we do. *) -let cancel_put request ex = - match Atomic.exchange request.cancel (`Cancelled ex) with - | `Cancelled _ -> failwith "Already cancelled!" - | `Resuming -> false (* Cancellation fails for now, but we remember we wanted to cancel. *) - | `Suspended cancel -> cancel () - -(* Putting. *) - -(* Like [add_to_cell], but we haven't created our value yet as we haven't suspended the fiber. *) -let rec producer_resume_cell t ~success ~in_transition cell = - match Atomic.get (cell : _ Cell.t Atomic.t) with - | Item _ -> assert false - | In_transition -> in_transition cell - | Finished -> producer_resume_cell t ~success ~in_transition (Q.next_resume t.consumers) - | Slot k as old -> - if Atomic.compare_and_set cell old Finished then success k - else producer_resume_cell t ~success ~in_transition cell - -(* This is essentially the main [put] function, but parameterised so it can be shared with - the rejoin-after-rejection case. *) -let producer_join (t : _ t) ~success ~suspend ~closed = - match Balance.fetch_and_add t.balance (+1) with - | Error `Closed -> closed () - | Ok old -> - if old < 0 then ( - let cell = Q.next_resume t.consumers in - producer_resume_cell t cell - ~success - ~in_transition:(fun cell -> suspend (Short cell)) - ) else ( - suspend (Long (Q.next_suspend t.producers)) - ) - -let put_closed_err = Invalid_argument "Stream closed" - -(* Called when a consumer took our value but then rejected it. - We start the put operation again, except that our fiber is already suspended - so no need to do that again. We're probably running in the consumer's domain - (unless the consumer provided their callback while we were cancelling). *) -let put_already_suspended t request = - producer_join t - ~success:(exchange request) - ~closed:(fun () -> request.kp (Failed put_closed_err)) - ~suspend:(fun loc -> - let Short cell | Long (_, cell) = loc in - add_to_cell t.consumers (Item request) cell; - let rec aux () = - match Atomic.get request.cancel, loc with - | (`Suspended _ | `Resuming as prev), Long loc -> - (* We might be suspended for a while. Update the cancel function with the new location. *) - let cancel_fn () = cancel t loc in - if not (Atomic.compare_and_set request.cancel prev (`Suspended cancel_fn)) then aux () - | `Cancelled ex, Long loc -> - (* We got cancelled after the peer removed our cell and before we updated the - cancel function with the new location, or we were cancelled while doing a - (non-cancellable) resume. Deal with it now. *) - if cancel t loc then request.kp (Failed ex); - (* else we got resumed first *) - | _, Short _ -> - (* We can't cancel while in the process of resuming a cell on the [consumers] queue. - We could set [cancel] to [`Resuming] here, but there's no need as trying to use the - old cancel function will find the old cell is cancelled and set [request.cancel] - to [`Cancelled]), as required. *) - () - in aux () - ) - -(* We tried to [put] and no slot was immediately available. - Suspend the fiber and use the continuation to finish initialising the cell. - Note that we may be suspending the fiber even when using the "resume" queue, - if the consumer is still in the process of writing its slot. *) -let put_suspend t v loc = - Suspend.enter_unchecked "Sync.put" @@ fun ctx enqueue -> - let cancel = - match loc with - | Short _ -> `Resuming (* Can't cancel this *) - | Long loc -> `Suspended (fun () -> cancel t loc) - in - let rec item = { - v = Ok v; - cancel = Atomic.make cancel; - kp = function - | Failed e -> enqueue (Error e) - | Sent -> enqueue (Ok ()) (* Success! *) - | Rejected -> put_already_suspended t item (* Consumer rejected value. Restart. *) - } in - let Short cell | Long (_, cell) = loc in - add_to_cell t.consumers (Item item) cell; - (* Set up the cancel handler in either case because we might change queues later: *) - match Fiber_context.get_error ctx with - | Some ex -> - if cancel_put item ex then enqueue (Error ex); - (* else being resumed *) - | None -> - Fiber_context.set_cancel_fn ctx (fun ex -> - if cancel_put item ex then enqueue (Error ex) - (* else being resumed *) - ) - -let rec put (t : _ t) v = - producer_join t - ~success:(fun kc -> if kc (Ok v) then () else put t v) - ~suspend:(put_suspend t v) - ~closed:(fun () -> raise put_closed_err) - -(* Taking. *) - -(* Mirror of [producer_resume_cell]. *) -let rec consumer_resume_cell t ~success ~in_transition cell = - match Atomic.get (cell : _ Cell.t Atomic.t) with - | Slot _ -> assert false - | In_transition -> in_transition cell - | Finished -> consumer_resume_cell t ~success ~in_transition (Q.next_resume t.producers) - | Item req as old -> - if Atomic.compare_and_set cell old Finished then success req - else consumer_resume_cell t ~success ~in_transition cell - -let take_suspend t loc = - Suspend.enter_unchecked "Sync.take" @@ fun ctx enqueue -> - let Short cell | Long (_, cell) = loc in - let kc v = enqueue (Ok v); true in - add_to_cell t.producers (Slot kc) cell; - match loc with - | Short _ -> () - | Long loc -> - match Fiber_context.get_error ctx with - | Some ex -> - if cancel t loc then enqueue (Error ex); - (* else being resumed *) - | None -> - Fiber_context.set_cancel_fn ctx (fun ex -> - if cancel t loc then enqueue (Error ex) - (* else being resumed *) - ) - -let take (t : _ t) = - match Balance.fetch_and_add t.balance (-1) with - | Error `Closed as e -> e - | Ok old -> - if old > 0 then ( - let cell = Q.next_resume t.producers in - consumer_resume_cell t cell - ~success:(fun item -> item.kp Sent; item.v) - ~in_transition:(fun cell -> take_suspend t (Short cell)) - ) else ( - take_suspend t (Long (Q.next_suspend t.consumers)) - ) - -let take t = - (take t - : (_, [ `Closed ]) result - :> (_, [> `Closed ]) result) - -let reject = Slot (fun _ -> false) - -let take_nonblocking (t : _ t) = - match Balance.decr_if_positive t.balance with - | Balance_closed -> Error `Closed - | Update_refused -> Error `Would_block (* No waiting producers for us *) - | Updated -> - let rec aux cell = - consumer_resume_cell t cell - ~success:(fun item -> - item.kp Sent; (* Always accept the item *) - (item.v :> (_, [`Closed | `Would_block]) result) - ) - ~in_transition:(fun cell -> - (* Our producer is still in the process of writing its [Item], but - we're non-blocking and can't wait. We're always acting as the - resumer, so we can't cancel the cell. Instead, we provide a - consumer callback that always rejects. - todo: could spin for a bit here first - the Item will probably arrive soon, - and that would avoid making the producer start again. *) - Domain.cpu_relax (); (* Brief wait to encourage producer to finish *) - if Atomic.compare_and_set cell In_transition reject then Error `Would_block - else aux cell - ) - in aux (Q.next_resume t.producers) - -let take_nonblocking t = - (take_nonblocking t - : (_, [ `Would_block | `Closed ]) result - :> (_, [> `Would_block | `Closed ]) result) - -(* Creation and status. *) - -let create () = - { - consumers = Q.make (); - producers = Q.make (); - balance = Balance.make (); - } - -let close t = - match Balance.close t.balance with - | Error `Closed -> () - | Ok old -> - if old > 0 then ( - (* Reject each waiting producer. They will try to restart and then discover the stream is closed. *) - for _ = 1 to old do - let cell = Q.next_resume t.producers in - add_to_cell t.consumers reject cell; - done - ) else ( - let reject_consumer = Item { v = Error `Closed; kp = ignore; cancel = Atomic.make `Resuming } in - (* Reject each waiting consumer. *) - for _ = 1 to -old do - let cell = Q.next_resume t.consumers in - add_to_cell t.consumers reject_consumer cell - done - ) - -let balance t = - Balance.get t.balance +(* A lock-free synchronous channel with cancellation, using Cells. + + Producers and consumers are paired off and then the producer transfers its + value to the consumer. This is effectively a bounded queue with a capacity + of zero. + + Both producers and consumers can cancel while waiting. + + There is an atomic int ([balance]), plus two queues ([consumers] and + [producers]) made using Cells. When [balance] is positive, it is the number + of producers waiting with values that no one is yet responsible for + resuming. When negative, it is the (negative) number of waiting consumers + that no one is responsible for resuming. + + To put an item: + + 1. The producer increments [balance]. + 2. If it was negative, the producer resumes one waiting consumer on the [consumers] queue. + Otherwise, it suspends itself on the [producers] queue. + + To take an item: + + 1. The consumer decrements [balance]. + 2. If it was positive, the consumer resumes one waiting producer on the [producers] queue. + Otherwise, it suspends itself on the [consumers] queue. + + Therefore, we never try to resume on a queue unless another party has + started the process of suspending on it. + + The system will not become idle while a client is responsible for resuming + something. Therefore, when idle: + + - If [balance <= 0] then there are no waiting producers. + - If [balance >= 0] then there are no waiting consumers. + - So, we never have waiting consumers and producers at the same time. + + As usual with Cells, either party may get to the new cell first. Whichever party + arrives first writes a callback, which the other party will then call when they arrive. + + Note on terminology: + + - The "suspender" of a cell is the party that incremented the queue's suspend index, + and the "resumer" of a cell is the party that incremented the resume index. + + - Whether "suspending" or "resuming" a cell, you may still have to suspend + your fiber and resume it later. + + States + + There are four cell states: + + - [In_transition] indicates that the cell is still being initialised, or might be + getting cancelled. Either way, the suspending party is actively working to + change the cell's state. + + - [Item] indicates that the producer is ready to provide an item. + + - [Slot] indicates that the consumer is ready to receive an item. + + - [Finished] indicates that the cell is no longer being used (the value has + been consumed or the cell has finished being cancelled). + + The possible sequences of states on the [producers] queue are: + + In_transition -C> Slot -P> Finished (consumer arrives first) + `P> Item -C> Finished (producer arrives first) + `P> In_transition -P> Finished (producer cancels) + `C> Slot -P> Finished (cancellation interrupted) + + Only the producer can cancel here. For the [consumers] queue it's the + opposite - the consumer can cancel its [Slot]. + + Cancellation + + Note that there are two kinds of cancellation here: + + 1. A cancelled cell is not considered part of its queue. Anyone seeing one + (due to a race) will skip over it and use the next cell. + + 2. After a consumer and producer have been paired off (and the cell removed + from its queue), the consumer callback may reject the value. If this + happens, the producer must start all over again to find another consumer. + + Whenever a consumer sets its callback to reject values, it should then start + the process of cancelling its cell (if acting as a suspender) so that the + cell can be GC'd. + + A consumer can only cancel its cell when it's on the [consumers] queue. + If it's on [producers], it knows a wake up will be coming shortly anyway. + A consumer cancels its cell as follows: + + 1. The consumer sets its cell in [consumers] to [In_transition]. + 2. It increments [balance] (from a negative value). It is now committed to cancelling. + 3. It sets its cell to [Finished]. + + (1) will fail if the cell got resumed first. In that case the consumer just + rejects the cancellation attempt. + + (2) will fail if [balance >= 0]. In that case the consumer has not cancelled, + and is about to be resumed instead. It tries to return to the [Slot] state. + If that fails, the cell now contains an Item and the consumer takes it. + + (3) will fail if a producer arrived after the consumer committed to cancelling. + In that case, the consumer passes the Item on to the next consumer (there + must be another one, since both the consumer and producer incremented + [balance] from a negative value). + + Cancelling a producer is very similar to cancelling a consumer, just with the + [producers] queue and decrementing the balance from a positive value. + + Non-blocking take + + To perform a non-blocking take: + + 1. The consumer decrements [balance] from a positive number. + 2. The consumer takes the next resume cell from [producers]. + 3. The consumer takes the [Item] from the cell, setting it to [Finished]. + + (1) will fail if there are no unassigned items available. + Then the [take_nonblocking] returns [None], as there are no items waiting. + + (3) will fail if the producer is initialising or cancelling. In either case, + the consumer sets its cell to a request with a dummy callback that rejects + all values and continues immediately. + + Close + + The LSB of the balance atomic is used to indicate that the stream has been closed. + When closed, the balance is always zero and no new consumers or producers can be added. + The closing thread is responsible for cancelling all pre-existing users. + + The exchange + + Once a producer and consumer have been paired off (and so their cell is now Finished), + the producer's value is passed to the consumer's callback. If the consumer accepts it, + then both fibers are resumed. If not, the producer starts again (incrementing [balance] + again) and waits for another consumer. + + The above has not been formally verified (exercise for reader!). *) + +(* Import these directly because we copy this file for the dscheck tests. *) +module Fiber_context = Eio__core.Private.Fiber_context +module Suspend = Eio__core.Private.Suspend +module Cancel = Eio__core.Cancel + +type producer_result = + | Sent (* Consumer accepted item. *) + | Rejected (* Consumer rejected the item. Retry. *) + | Failed of exn (* Cancelled or closed. *) + +type 'a item = { + v : ('a, [`Closed]) result; + kp : producer_result -> unit; + cancel : [ + | `Resuming (* In the process of resuming, so can't cancel. *) + | `Suspended of (unit -> bool) (* Call this function to attempt to leave the queue. *) + | `Cancelled of exn (* Already cancelled. *) + ] Atomic.t; +} + +type 'a cell = + | In_transition + | Slot of (('a, [`Closed]) result -> bool) + | Item of 'a item + | Finished + +module Cell = struct + type 'a t = 'a cell + + let init = In_transition + + let segment_order = 2 + + let dump f = function + | In_transition -> Fmt.string f "In_transition" + | Slot _ -> Fmt.string f "Slot" + | Item _ -> Fmt.string f "Item" + | Finished -> Fmt.string f "Finished" +end + +module Q = Cells.Make(Cell) + +type update_result = + | Updated + | Update_refused + | Balance_closed + +module Balance : sig + type t + + val make : unit -> t + + val close : t -> (int, [> `Closed]) result + (* Mark as closed and return the previous state. *) + + val get : t -> (int, [> `Closed]) result + (** [get t] is the number of items available (if non-negative) or the + number of consumers waiting for an item. *) + + val fetch_and_add : t -> int -> (int, [> `Closed]) result + (** [fetch_and_add t diff] increases the value by [diff] and returns the old value. *) + + val incr_if_negative : t -> update_result + val decr_if_positive : t -> update_result + + val pp : t Fmt.t +end = struct + type t = int Atomic.t + + let closed = 1 + let counter x = x asr 1 + let is_closed x = (x land 1) <> 0 + + let value x = + if is_closed x then Error `Closed else Ok (counter x) + + let fetch_and_add x diff = + value (Atomic.fetch_and_add x (diff lsl 1)) + + let rec decr_if_positive t = + let x = Atomic.get t in + if is_closed x then Balance_closed + else if counter x > 0 then ( + if Atomic.compare_and_set t x (x - 2) then Updated + else decr_if_positive t + ) else Update_refused + + let rec incr_if_negative t = + let x = Atomic.get t in + if is_closed x then Balance_closed + else if counter x < 0 then ( + if Atomic.compare_and_set t x (x + 2) then Updated + else incr_if_negative t + ) else Update_refused + + let make () = Atomic.make 0 + + let close t = + value (Atomic.exchange t closed) + + let get t = value (Atomic.get t) + + let pp f t = + match get t with + | Ok x -> Fmt.int f x + | Error `Closed -> Fmt.string f "(closed)" +end + +type 'a t = { + balance : Balance.t; + consumers : 'a Q.t; + producers : 'a Q.t; +} + +type 'a loc = + | Short of 'a Cell.t Atomic.t (* Acting as resumer of cell *) + | Long of ('a Q.segment * 'a Cell.t Atomic.t) (* Acting as suspender of cell; can cancel *) + +let dump f t = + Fmt.pf f "@[Sync (balance=%a)@,@[Consumers:@,%a@]@,@[Producers:@,%a@]@]" + Balance.pp t.balance + Q.dump t.consumers + Q.dump t.producers + +(* Give [item] to consumer [kc]. [item]'s cell is now Finished. *) +let exchange item kc = + item.kp (if kc item.v then Sent else Rejected) + +(* Add [value] to [cell]. + If the cell is in transition, place [value] there and let the other party handle it later. + If the peer's value is already present, do the exchange. + If the peer cancelled the cell then try the next one on the given resume queue (if we're adding + to a suspend queue then it can't be cancelled, because the caller controls cancellation). + This is only used when our fiber is already suspended, + since we can't create [value] before we have the continuation. *) +let rec add_to_cell queue value cell = + match Atomic.get cell, value with + | Finished, _ -> add_to_cell queue value (Q.next_resume queue) (* Cancelled - skip *) + | (Slot kc as old), Item item + | (Item item as old), Slot kc -> + if Atomic.compare_and_set cell old Finished then exchange item kc + else add_to_cell queue value cell + | In_transition, _ -> + if Atomic.compare_and_set cell In_transition value then () + else add_to_cell queue value cell + | (Slot _ | Item _), _ -> assert false + +(* Cancelling *) + +(* Cancel [cell] on our suspend queue. + This function works for both consumers and producers, as we can tell from + the value what our role is (and if there isn't a value, we're finished anyway). + Neither party will try to cancel before writing its own value. + Returns [true] if the caller cancelled successfully, + or [false] if it must wait (as it's being resumed). *) +let cancel t (segment, cell) = + let cancel2 update_balance ~old = + if Atomic.compare_and_set cell old In_transition then ( + match update_balance t.balance with + | Updated -> + (* At this point, we are committed to cancelling. *) + begin match Atomic.exchange cell Finished with + | Finished -> assert false + | In_transition -> Q.cancel_cell segment + | Item request -> add_to_cell t.consumers (Item request) (Q.next_resume t.consumers) + | Slot kc -> add_to_cell t.producers (Slot kc) (Q.next_resume t.producers) + end; + true + | Update_refused | Balance_closed -> + (* We decided not to cancel. We know a resume is coming. *) + if Atomic.compare_and_set cell In_transition old then false + else ( + match old, Atomic.get cell with + | Slot kc, Item request + | Item request, Slot kc -> + Atomic.set cell Finished; + exchange request kc; + false + | _ -> assert false + ) + ) else false (* The peer resumed us first *) + in + match Atomic.get cell with + | Finished -> false (* The peer resumed us first *) + | Slot _ as old -> cancel2 Balance.incr_if_negative ~old (* We are a consumer *) + | Item _ as old -> cancel2 Balance.decr_if_positive ~old (* We are a producer *) + | In_transition -> + (* Either we're initialising the cell, in which case we haven't told the + application how to cancel this location yet, or we're already + cancelling, but cancelling twice isn't permitted. *) + assert false + +(* A producer can't cancel if it is resuming on the [consumers] queue, and will instead + just wait for the slot in that case, which will arrive soon. However, after getting + a slot the producer may be rejected and be asked to start again on the [producers] queue, + so we need to remember that we were cancelled to prevent that. It's also possible that + we're already restarting but haven't got around to updating [request.cancel] yet; we'll + notice the new [`Cancelled] state when we do. *) +let cancel_put request ex = + match Atomic.exchange request.cancel (`Cancelled ex) with + | `Cancelled _ -> failwith "Already cancelled!" + | `Resuming -> false (* Cancellation fails for now, but we remember we wanted to cancel. *) + | `Suspended cancel -> cancel () + +(* Putting. *) + +(* Like [add_to_cell], but we haven't created our value yet as we haven't suspended the fiber. *) +let rec producer_resume_cell t ~success ~in_transition cell = + match Atomic.get (cell : _ Cell.t Atomic.t) with + | Item _ -> assert false + | In_transition -> in_transition cell + | Finished -> producer_resume_cell t ~success ~in_transition (Q.next_resume t.consumers) + | Slot k as old -> + if Atomic.compare_and_set cell old Finished then success k + else producer_resume_cell t ~success ~in_transition cell + +(* This is essentially the main [put] function, but parameterised so it can be shared with + the rejoin-after-rejection case. *) +let producer_join (t : _ t) ~success ~suspend ~closed = + match Balance.fetch_and_add t.balance (+1) with + | Error `Closed -> closed () + | Ok old -> + if old < 0 then ( + let cell = Q.next_resume t.consumers in + producer_resume_cell t cell + ~success + ~in_transition:(fun cell -> suspend (Short cell)) + ) else ( + suspend (Long (Q.next_suspend t.producers)) + ) + +let put_closed_err = Invalid_argument "Stream closed" + +(* Called when a consumer took our value but then rejected it. + We start the put operation again, except that our fiber is already suspended + so no need to do that again. We're probably running in the consumer's domain + (unless the consumer provided their callback while we were cancelling). *) +let put_already_suspended t request = + producer_join t + ~success:(exchange request) + ~closed:(fun () -> request.kp (Failed put_closed_err)) + ~suspend:(fun loc -> + let Short cell | Long (_, cell) = loc in + add_to_cell t.consumers (Item request) cell; + let rec aux () = + match Atomic.get request.cancel, loc with + | (`Suspended _ | `Resuming as prev), Long loc -> + (* We might be suspended for a while. Update the cancel function with the new location. *) + let cancel_fn () = cancel t loc in + if not (Atomic.compare_and_set request.cancel prev (`Suspended cancel_fn)) then aux () + | `Cancelled ex, Long loc -> + (* We got cancelled after the peer removed our cell and before we updated the + cancel function with the new location, or we were cancelled while doing a + (non-cancellable) resume. Deal with it now. *) + if cancel t loc then request.kp (Failed ex); + (* else we got resumed first *) + | _, Short _ -> + (* We can't cancel while in the process of resuming a cell on the [consumers] queue. + We could set [cancel] to [`Resuming] here, but there's no need as trying to use the + old cancel function will find the old cell is cancelled and set [request.cancel] + to [`Cancelled]), as required. *) + () + in aux () + ) + +(* We tried to [put] and no slot was immediately available. + Suspend the fiber and use the continuation to finish initialising the cell. + Note that we may be suspending the fiber even when using the "resume" queue, + if the consumer is still in the process of writing its slot. *) +let put_suspend t v loc = + Suspend.enter_unchecked "Sync.put" @@ fun ctx enqueue -> + let cancel = + match loc with + | Short _ -> `Resuming (* Can't cancel this *) + | Long loc -> `Suspended (fun () -> cancel t loc) + in + let rec item = { + v = Ok v; + cancel = Atomic.make cancel; + kp = function + | Failed e -> enqueue (Error e) + | Sent -> enqueue (Ok ()) (* Success! *) + | Rejected -> put_already_suspended t item (* Consumer rejected value. Restart. *) + } in + let Short cell | Long (_, cell) = loc in + add_to_cell t.consumers (Item item) cell; + (* Set up the cancel handler in either case because we might change queues later: *) + match Fiber_context.get_error ctx with + | Some ex -> + if cancel_put item ex then enqueue (Error ex); + (* else being resumed *) + | None -> + Fiber_context.set_cancel_fn ctx (fun ex -> + if cancel_put item ex then enqueue (Error ex) + (* else being resumed *) + ) + +let rec put (t : _ t) v = + producer_join t + ~success:(fun kc -> if kc (Ok v) then () else put t v) + ~suspend:(put_suspend t v) + ~closed:(fun () -> raise put_closed_err) + +(* Taking. *) + +(* Mirror of [producer_resume_cell]. *) +let rec consumer_resume_cell t ~success ~in_transition cell = + match Atomic.get (cell : _ Cell.t Atomic.t) with + | Slot _ -> assert false + | In_transition -> in_transition cell + | Finished -> consumer_resume_cell t ~success ~in_transition (Q.next_resume t.producers) + | Item req as old -> + if Atomic.compare_and_set cell old Finished then success req + else consumer_resume_cell t ~success ~in_transition cell + +let take_suspend t loc = + Suspend.enter_unchecked "Sync.take" @@ fun ctx enqueue -> + let Short cell | Long (_, cell) = loc in + let kc v = enqueue (Ok v); true in + add_to_cell t.producers (Slot kc) cell; + match loc with + | Short _ -> () + | Long loc -> + match Fiber_context.get_error ctx with + | Some ex -> + if cancel t loc then enqueue (Error ex); + (* else being resumed *) + | None -> + Fiber_context.set_cancel_fn ctx (fun ex -> + if cancel t loc then enqueue (Error ex) + (* else being resumed *) + ) + +let take (t : _ t) = + match Balance.fetch_and_add t.balance (-1) with + | Error `Closed as e -> e + | Ok old -> + if old > 0 then ( + let cell = Q.next_resume t.producers in + consumer_resume_cell t cell + ~success:(fun item -> item.kp Sent; item.v) + ~in_transition:(fun cell -> take_suspend t (Short cell)) + ) else ( + take_suspend t (Long (Q.next_suspend t.consumers)) + ) + +let take t = + (take t + : (_, [ `Closed ]) result + :> (_, [> `Closed ]) result) + +let reject = Slot (fun _ -> false) + +let take_nonblocking (t : _ t) = + match Balance.decr_if_positive t.balance with + | Balance_closed -> Error `Closed + | Update_refused -> Error `Would_block (* No waiting producers for us *) + | Updated -> + let rec aux cell = + consumer_resume_cell t cell + ~success:(fun item -> + item.kp Sent; (* Always accept the item *) + (item.v :> (_, [`Closed | `Would_block]) result) + ) + ~in_transition:(fun cell -> + (* Our producer is still in the process of writing its [Item], but + we're non-blocking and can't wait. We're always acting as the + resumer, so we can't cancel the cell. Instead, we provide a + consumer callback that always rejects. + todo: could spin for a bit here first - the Item will probably arrive soon, + and that would avoid making the producer start again. *) + Domain.cpu_relax (); (* Brief wait to encourage producer to finish *) + if Atomic.compare_and_set cell In_transition reject then Error `Would_block + else aux cell + ) + in aux (Q.next_resume t.producers) + +let take_nonblocking t = + (take_nonblocking t + : (_, [ `Would_block | `Closed ]) result + :> (_, [> `Would_block | `Closed ]) result) + +(* Creation and status. *) + +let create () = + { + consumers = Q.make (); + producers = Q.make (); + balance = Balance.make (); + } + +let close t = + match Balance.close t.balance with + | Error `Closed -> () + | Ok old -> + if old > 0 then ( + (* Reject each waiting producer. They will try to restart and then discover the stream is closed. *) + for _ = 1 to old do + let cell = Q.next_resume t.producers in + add_to_cell t.consumers reject cell; + done + ) else ( + let reject_consumer = Item { v = Error `Closed; kp = ignore; cancel = Atomic.make `Resuming } in + (* Reject each waiting consumer. *) + for _ = 1 to -old do + let cell = Q.next_resume t.consumers in + add_to_cell t.consumers reject_consumer cell + done + ) + +let balance t = + Balance.get t.balance diff --git a/lib_eio/sync.mli b/lib_eio/sync.mli index 072c8d30c..6650ca3a8 100644 --- a/lib_eio/sync.mli +++ b/lib_eio/sync.mli @@ -1,61 +1,61 @@ -(* A lock-free synchronous channel with cancellation, using Cells. - - Producers and consumers are paired off and then the producer transfers its - value to the consumer. This is effectively a bounded queue with a capacity - of zero. - - Both producers and consumers can cancel while waiting. *) - -type 'a t -(** A lock-free synchronous channel. *) - -val create : unit -> 'a t -(** [create ()] is a fresh channel with a balance of 0. *) - -val put : 'a t -> 'a -> unit -(** [put t x] gives [x] to a waiting consumer. - - If no consumer is available, it waits until one comes along and accepts [x]. - - Note: Producers are mostly handled fairly, in the order in which they arrive, - but consumers can cancel or reject values so this isn't guaranteed. - - @raise Invalid_argument if [t] was closed before [x] was added. *) - -val take : 'a t -> ('a, [> `Closed]) result -(** [take t] waits until a producer is available with an item and then returns it. - - Note: Consumers are mostly handled fairly, in the order in which they arrive, - but producers can cancel so this isn't guaranteed if [t] is shared between - domains. - - Returns [Error `Closed] if [t] was closed before an item was taken. *) - -val take_nonblocking : 'a t -> ('a, [> `Would_block | `Closed]) result -(** [take_nonblocking t] is like {!take}, but returns [Error `Would_block] if no producer is immediately available. - - Note: When [t] is shared between domains, it is possible that a producer may be assigned but still be - in the process of writing its value to [t]. In this case, [take_nonblocking] will cancel it, - causing the old producer to lose its place in the queue and have to rejoin at the end. - Since the producer reached the head of the queue while it was still joining, - the queue is presumably very short in this case anyway. *) - -val close : 'a t -> unit -(** [close t] prevents any further items from being added to [t]. - - Any consumers or producers that were waiting will receive an exception. - If [t] is already closed then this does nothing. *) - -val balance : 'a t -> (int, [> `Closed]) result -(** [balance t] is the number of waiting producers minus the number of waiting consumers. - - If the balance is non-negative then it is the number of waiting producers. - If non-positive, it is the number of waiting consumers. - There cannot be waiting producers and waiting consumers at the same time. - - If [t] is shared between domains then the value may already be out-of-date - by the time this function returns, so this is mostly useful for debugging - or reporting metrics. *) - -val dump : 'a t Fmt.t -(** [dump] formats the internal state of a channel, for testing and debugging. *) +(* A lock-free synchronous channel with cancellation, using Cells. + + Producers and consumers are paired off and then the producer transfers its + value to the consumer. This is effectively a bounded queue with a capacity + of zero. + + Both producers and consumers can cancel while waiting. *) + +type 'a t +(** A lock-free synchronous channel. *) + +val create : unit -> 'a t +(** [create ()] is a fresh channel with a balance of 0. *) + +val put : 'a t -> 'a -> unit +(** [put t x] gives [x] to a waiting consumer. + + If no consumer is available, it waits until one comes along and accepts [x]. + + Note: Producers are mostly handled fairly, in the order in which they arrive, + but consumers can cancel or reject values so this isn't guaranteed. + + @raise Invalid_argument if [t] was closed before [x] was added. *) + +val take : 'a t -> ('a, [> `Closed]) result +(** [take t] waits until a producer is available with an item and then returns it. + + Note: Consumers are mostly handled fairly, in the order in which they arrive, + but producers can cancel so this isn't guaranteed if [t] is shared between + domains. + + Returns [Error `Closed] if [t] was closed before an item was taken. *) + +val take_nonblocking : 'a t -> ('a, [> `Would_block | `Closed]) result +(** [take_nonblocking t] is like {!take}, but returns [Error `Would_block] if no producer is immediately available. + + Note: When [t] is shared between domains, it is possible that a producer may be assigned but still be + in the process of writing its value to [t]. In this case, [take_nonblocking] will cancel it, + causing the old producer to lose its place in the queue and have to rejoin at the end. + Since the producer reached the head of the queue while it was still joining, + the queue is presumably very short in this case anyway. *) + +val close : 'a t -> unit +(** [close t] prevents any further items from being added to [t]. + + Any consumers or producers that were waiting will receive an exception. + If [t] is already closed then this does nothing. *) + +val balance : 'a t -> (int, [> `Closed]) result +(** [balance t] is the number of waiting producers minus the number of waiting consumers. + + If the balance is non-negative then it is the number of waiting producers. + If non-positive, it is the number of waiting consumers. + There cannot be waiting producers and waiting consumers at the same time. + + If [t] is shared between domains then the value may already be out-of-date + by the time this function returns, so this is mostly useful for debugging + or reporting metrics. *) + +val dump : 'a t Fmt.t +(** [dump] formats the internal state of a channel, for testing and debugging. *) diff --git a/lib_eio/tests/broadcast.md b/lib_eio/tests/broadcast.md index 441382f0a..f506d4da3 100644 --- a/lib_eio/tests/broadcast.md +++ b/lib_eio/tests/broadcast.md @@ -1,163 +1,163 @@ -```ocaml -# #require "eio";; -``` -```ocaml -module T = Eio__core__Broadcast -let show t = Fmt.pr "%a@." T.dump t -let fiber name () = Fmt.pr "%s: woken@." name -``` - -Initially we have a single segment full of empty cells. -Both resume and suspend pointers point at the first cell: - -```ocaml -# let t : T.t = T.create ();; -val t : T.t = -# show t;; -Segment 0 (prev=None, pointers=2, cancelled=0): - Empty (suspend) (resume) - Empty - Empty - Empty -End -- : unit = () -``` - -## Waking an empty queue - -Broadcasting with no waiters does nothing: - -```ocaml -# T.resume_all t; show t;; -Segment 0 (prev=None, pointers=2, cancelled=0): - Empty (suspend) (resume) - Empty - Empty - Empty -End -- : unit = () -``` - -## Adding waiters - -Requesting a wake-up adds requests to the queue: -```ocaml -# T.suspend t (fiber "0");; -- : T.request option = Some - -# show t;; -Segment 0 (prev=None, pointers=2, cancelled=0): - Request (resume) - Empty (suspend) - Empty - Empty -End -- : unit = () -``` -The returned request is to allow us to cancel if desired. - -Filling the segment: -```ocaml -# let suspend name = T.suspend t (fiber name);; -val suspend : string -> T.request option = - -# for i = 1 to 3 do suspend (string_of_int i) |> Option.get |> ignore done;; -- : unit = () - -# show t;; -Segment 0 (prev=None, pointers=2, cancelled=0): - Request (resume) - Request - Request - Request -End (suspend) -- : unit = () -``` - -Allocating new segments: -```ocaml -# let reqs = List.init 5 (fun i -> suspend (string_of_int i) |> Option.get);; -val reqs : T.request list = [; ; ; ; ] - -# show t;; -Segment 0 (prev=None, pointers=1, cancelled=0): - Request (resume) - Request - Request - Request -Segment 1 (prev=Some 0, pointers=0, cancelled=0): - Request - Request - Request - Request -Segment 2 (prev=Some 1, pointers=1, cancelled=0): - Request - Empty (suspend) - Empty - Empty -End -- : unit = () -``` - -Cancelling all the cells in a segment removes the segment: -```ocaml -# List.iter (fun r -> assert (T.cancel r)) reqs; show t;; -Segment 0 (prev=None, pointers=1, cancelled=0): - Request (resume) - Request - Request - Request -End -Segment 2 (prev=Some 0, pointers=1, cancelled=1): - Cancelled - Empty (suspend) - Empty - Empty -End -- : unit = () -``` - -```ocaml -# suspend "last";; -- : T.request option = Some - -# T.resume_all t;; -0: woken -1: woken -2: woken -3: woken -last: woken -- : unit = () - -# show t;; -Segment 2 (prev=None, pointers=2, cancelled=1): - Cancelled - Resumed - Empty (suspend) (resume) - Empty -End -- : unit = () -``` - -Resume all, filling segment: - -```ocaml -# suspend "a";; -- : T.request option = Some -# suspend "b";; -- : T.request option = Some - -# T.resume_all t;; -a: woken -b: woken -- : unit = () - -# show t;; -Segment 2 (prev=None, pointers=2, cancelled=1): - Cancelled - Resumed - Resumed - Resumed -End (suspend) (resume) -- : unit = () -``` +```ocaml +# #require "eio";; +``` +```ocaml +module T = Eio__core__Broadcast +let show t = Fmt.pr "%a@." T.dump t +let fiber name () = Fmt.pr "%s: woken@." name +``` + +Initially we have a single segment full of empty cells. +Both resume and suspend pointers point at the first cell: + +```ocaml +# let t : T.t = T.create ();; +val t : T.t = +# show t;; +Segment 0 (prev=None, pointers=2, cancelled=0): + Empty (suspend) (resume) + Empty + Empty + Empty +End +- : unit = () +``` + +## Waking an empty queue + +Broadcasting with no waiters does nothing: + +```ocaml +# T.resume_all t; show t;; +Segment 0 (prev=None, pointers=2, cancelled=0): + Empty (suspend) (resume) + Empty + Empty + Empty +End +- : unit = () +``` + +## Adding waiters + +Requesting a wake-up adds requests to the queue: +```ocaml +# T.suspend t (fiber "0");; +- : T.request option = Some + +# show t;; +Segment 0 (prev=None, pointers=2, cancelled=0): + Request (resume) + Empty (suspend) + Empty + Empty +End +- : unit = () +``` +The returned request is to allow us to cancel if desired. + +Filling the segment: +```ocaml +# let suspend name = T.suspend t (fiber name);; +val suspend : string -> T.request option = + +# for i = 1 to 3 do suspend (string_of_int i) |> Option.get |> ignore done;; +- : unit = () + +# show t;; +Segment 0 (prev=None, pointers=2, cancelled=0): + Request (resume) + Request + Request + Request +End (suspend) +- : unit = () +``` + +Allocating new segments: +```ocaml +# let reqs = List.init 5 (fun i -> suspend (string_of_int i) |> Option.get);; +val reqs : T.request list = [; ; ; ; ] + +# show t;; +Segment 0 (prev=None, pointers=1, cancelled=0): + Request (resume) + Request + Request + Request +Segment 1 (prev=Some 0, pointers=0, cancelled=0): + Request + Request + Request + Request +Segment 2 (prev=Some 1, pointers=1, cancelled=0): + Request + Empty (suspend) + Empty + Empty +End +- : unit = () +``` + +Cancelling all the cells in a segment removes the segment: +```ocaml +# List.iter (fun r -> assert (T.cancel r)) reqs; show t;; +Segment 0 (prev=None, pointers=1, cancelled=0): + Request (resume) + Request + Request + Request +End +Segment 2 (prev=Some 0, pointers=1, cancelled=1): + Cancelled + Empty (suspend) + Empty + Empty +End +- : unit = () +``` + +```ocaml +# suspend "last";; +- : T.request option = Some + +# T.resume_all t;; +0: woken +1: woken +2: woken +3: woken +last: woken +- : unit = () + +# show t;; +Segment 2 (prev=None, pointers=2, cancelled=1): + Cancelled + Resumed + Empty (suspend) (resume) + Empty +End +- : unit = () +``` + +Resume all, filling segment: + +```ocaml +# suspend "a";; +- : T.request option = Some +# suspend "b";; +- : T.request option = Some + +# T.resume_all t;; +a: woken +b: woken +- : unit = () + +# show t;; +Segment 2 (prev=None, pointers=2, cancelled=1): + Cancelled + Resumed + Resumed + Resumed +End (suspend) (resume) +- : unit = () +``` diff --git a/lib_eio/tests/dscheck/atomic.ml b/lib_eio/tests/dscheck/atomic.ml index 4563b4a4f..af420a5c6 100644 --- a/lib_eio/tests/dscheck/atomic.ml +++ b/lib_eio/tests/dscheck/atomic.ml @@ -1 +1 @@ -include Dscheck.TracedAtomic +include Dscheck.TracedAtomic diff --git a/lib_eio/tests/dscheck/dune b/lib_eio/tests/dscheck/dune index 81610021f..4afb52c8f 100644 --- a/lib_eio/tests/dscheck/dune +++ b/lib_eio/tests/dscheck/dune @@ -1,42 +1,42 @@ -; We copy cells.ml here so we can build it using TracedAtomic instead of the default one. -(copy_files# (files ../../core/cells.ml)) -(copy_files# (files ../../sem_state.ml)) -(copy_files# (files ../../sync.ml)) -(copy_files# (files ../../unix/rcfd.ml)) -(copy_files# (files ../../condition.ml)) -(copy_files# (files ../../pool.ml)) -(copy_files# (files ../../core/broadcast.ml)) - -(executables - (names test_cells test_semaphore test_sync test_rcfd test_condition test_pool) - (libraries dscheck optint fmt eio)) - -(rule - (alias dscheck) - (package eio) - (action (run %{exe:test_rcfd.exe}))) - -(rule - (alias dscheck) - (package eio) - (action (run %{exe:test_cells.exe}))) - -(rule - (alias dscheck) - (package eio) - (action (run %{exe:test_sync.exe}))) - -(rule - (alias dscheck) - (package eio) - (action (run %{exe:test_semaphore.exe}))) - -(rule - (alias dscheck) - (package eio) - (action (run %{exe:test_condition.exe}))) - -(rule - (alias dscheck) - (package eio) - (action (run %{exe:test_pool.exe}))) +; We copy cells.ml here so we can build it using TracedAtomic instead of the default one. +(copy_files# (files ../../core/cells.ml)) +(copy_files# (files ../../sem_state.ml)) +(copy_files# (files ../../sync.ml)) +(copy_files# (files ../../unix/rcfd.ml)) +(copy_files# (files ../../condition.ml)) +(copy_files# (files ../../pool.ml)) +(copy_files# (files ../../core/broadcast.ml)) + +(executables + (names test_cells test_semaphore test_sync test_rcfd test_condition test_pool) + (libraries dscheck optint fmt eio)) + +(rule + (alias dscheck) + (package eio) + (action (run %{exe:test_rcfd.exe}))) + +(rule + (alias dscheck) + (package eio) + (action (run %{exe:test_cells.exe}))) + +(rule + (alias dscheck) + (package eio) + (action (run %{exe:test_sync.exe}))) + +(rule + (alias dscheck) + (package eio) + (action (run %{exe:test_semaphore.exe}))) + +(rule + (alias dscheck) + (package eio) + (action (run %{exe:test_condition.exe}))) + +(rule + (alias dscheck) + (package eio) + (action (run %{exe:test_pool.exe}))) diff --git a/lib_eio/tests/dscheck/eio_mutex.ml b/lib_eio/tests/dscheck/eio_mutex.ml index c6d1b804c..d2d6b284c 100644 --- a/lib_eio/tests/dscheck/eio_mutex.ml +++ b/lib_eio/tests/dscheck/eio_mutex.ml @@ -1,2 +1,2 @@ -let lock _ = assert false -let unlock _ = assert false +let lock _ = assert false +let unlock _ = assert false diff --git a/lib_eio/tests/dscheck/fake_sched.ml b/lib_eio/tests/dscheck/fake_sched.ml index 7e5a968d4..186e93ed0 100644 --- a/lib_eio/tests/dscheck/fake_sched.ml +++ b/lib_eio/tests/dscheck/fake_sched.ml @@ -1,21 +1,21 @@ -let cancel ctx = Eio.Cancel.cancel ctx (Failure "test cancellation") - -let run fn = - let module Fiber_context = Eio__core.Private.Fiber_context in - let continue_result k = function - | Ok x -> Effect.Deep.continue k x - | Error x -> Effect.Deep.discontinue k x - in - let fiber = lazy (Fiber_context.make_root ()) in - Effect.Deep.try_with fn () - { effc = fun (type a) (e : a Effect.t) : ((a, 'b) Effect.Deep.continuation -> 'b) option -> - match e with - | Eio.Private.Effects.Suspend fn -> - Some (fun cont -> - fn (Lazy.force fiber) (continue_result cont); - ) - | _ -> None - }; - if Lazy.is_val fiber then - Some (Fiber_context.cancellation_context (Lazy.force fiber)) - else None +let cancel ctx = Eio.Cancel.cancel ctx (Failure "test cancellation") + +let run fn = + let module Fiber_context = Eio__core.Private.Fiber_context in + let continue_result k = function + | Ok x -> Effect.Deep.continue k x + | Error x -> Effect.Deep.discontinue k x + in + let fiber = lazy (Fiber_context.make_root ()) in + Effect.Deep.try_with fn () + { effc = fun (type a) (e : a Effect.t) : ((a, 'b) Effect.Deep.continuation -> 'b) option -> + match e with + | Eio.Private.Effects.Suspend fn -> + Some (fun cont -> + fn (Lazy.force fiber) (continue_result cont); + ) + | _ -> None + }; + if Lazy.is_val fiber then + Some (Fiber_context.cancellation_context (Lazy.force fiber)) + else None diff --git a/lib_eio/tests/dscheck/fake_sched.mli b/lib_eio/tests/dscheck/fake_sched.mli index 7c125eabf..73b7ecba5 100644 --- a/lib_eio/tests/dscheck/fake_sched.mli +++ b/lib_eio/tests/dscheck/fake_sched.mli @@ -1,7 +1,7 @@ -val run : (unit -> unit) -> Eio.Cancel.t option -(** [run fn] runs [fn ()] in a new fiber and returns its context so it can be cancelled. - - Returns None if it never suspended. *) - -val cancel : Eio.Cancel.t -> unit -(** [cancel ctx] cancels the context with a suitable dummy exception. *) +val run : (unit -> unit) -> Eio.Cancel.t option +(** [run fn] runs [fn ()] in a new fiber and returns its context so it can be cancelled. + + Returns None if it never suspended. *) + +val cancel : Eio.Cancel.t -> unit +(** [cancel ctx] cancels the context with a suitable dummy exception. *) diff --git a/lib_eio/tests/dscheck/simple_cqs.ml b/lib_eio/tests/dscheck/simple_cqs.ml index bd2d99aa0..e5d0d8eb3 100644 --- a/lib_eio/tests/dscheck/simple_cqs.ml +++ b/lib_eio/tests/dscheck/simple_cqs.ml @@ -1,62 +1,62 @@ -(* A queue built on cells.ml using the "simple" cancellation mode, - where resuming a cancelled request does nothing instead of retrying. *) - -module Make(Config : sig val segment_order : int end) = struct - module Cell = struct - type _ t = - | Empty - | Value of int - | Waiting of (int -> unit) - | Cancelled - | Finished - - let init = Empty - - let segment_order = Config.segment_order - - let dump f = function - | Empty -> Fmt.string f "Empty" - | Value v -> Fmt.pf f "Value %d" v - | Waiting _ -> Fmt.string f "Waiting" - | Cancelled -> Fmt.string f "Cancelled" - | Finished -> Fmt.string f "Finished" - end - - module Cells = Cells.Make(Cell) - - let cancel (segment, cell) = - match Atomic.get cell with - | Cell.Waiting _ as prev -> - if Atomic.compare_and_set cell prev Cancelled then ( - Cells.cancel_cell segment; - true - ) else ( - false - ) - | Finished -> false - | _ -> assert false - - let resume t v = - let cell = Cells.next_resume t in - if not (Atomic.compare_and_set cell Cell.Empty (Value v)) then ( - match Atomic.get cell with - | Waiting w as prev -> - if Atomic.compare_and_set cell prev Finished then w v - (* else cancelled *) - | Cancelled -> () - | Empty | Value _ | Finished -> assert false - ) - - let suspend t k = - let segment, cell = Cells.next_suspend t in - if Atomic.compare_and_set cell Cell.Empty (Waiting k) then Some (segment, cell) - else ( - match Atomic.get cell with - | Value v -> Atomic.set cell Finished; k v; None - | Cancelled | Empty | Waiting _ | Finished -> assert false - ) - - let make = Cells.make - - let dump = Cells.dump -end +(* A queue built on cells.ml using the "simple" cancellation mode, + where resuming a cancelled request does nothing instead of retrying. *) + +module Make(Config : sig val segment_order : int end) = struct + module Cell = struct + type _ t = + | Empty + | Value of int + | Waiting of (int -> unit) + | Cancelled + | Finished + + let init = Empty + + let segment_order = Config.segment_order + + let dump f = function + | Empty -> Fmt.string f "Empty" + | Value v -> Fmt.pf f "Value %d" v + | Waiting _ -> Fmt.string f "Waiting" + | Cancelled -> Fmt.string f "Cancelled" + | Finished -> Fmt.string f "Finished" + end + + module Cells = Cells.Make(Cell) + + let cancel (segment, cell) = + match Atomic.get cell with + | Cell.Waiting _ as prev -> + if Atomic.compare_and_set cell prev Cancelled then ( + Cells.cancel_cell segment; + true + ) else ( + false + ) + | Finished -> false + | _ -> assert false + + let resume t v = + let cell = Cells.next_resume t in + if not (Atomic.compare_and_set cell Cell.Empty (Value v)) then ( + match Atomic.get cell with + | Waiting w as prev -> + if Atomic.compare_and_set cell prev Finished then w v + (* else cancelled *) + | Cancelled -> () + | Empty | Value _ | Finished -> assert false + ) + + let suspend t k = + let segment, cell = Cells.next_suspend t in + if Atomic.compare_and_set cell Cell.Empty (Waiting k) then Some (segment, cell) + else ( + match Atomic.get cell with + | Value v -> Atomic.set cell Finished; k v; None + | Cancelled | Empty | Waiting _ | Finished -> assert false + ) + + let make = Cells.make + + let dump = Cells.dump +end diff --git a/lib_eio/tests/dscheck/test_cells.ml b/lib_eio/tests/dscheck/test_cells.ml index a19b8618e..139f3ddb4 100644 --- a/lib_eio/tests/dscheck/test_cells.ml +++ b/lib_eio/tests/dscheck/test_cells.ml @@ -1,207 +1,207 @@ -let debug = false - -(* For each of [n_values], spawn one producer and one consumer. - If the consumer has to wait, it will also try to cancel. - The consumer increases the total if it gets a value; - the producer increments it if the cancellation succeeds instead. *) -let test_cells ~segment_order ~n_values () = - let module Cqs = Simple_cqs.Make(struct let segment_order = segment_order end) in - let expected_total = n_values in - let t = Cqs.make () in - let total = ref 0 in - for i = 1 to n_values do - Atomic.spawn (fun () -> - if debug then Fmt.epr "%d: wrote value@." i; - Cqs.resume t 1; - ); - Atomic.spawn (fun () -> - match - Cqs.suspend t (fun v -> - if debug then Fmt.epr "%d: resumed@." i; - total := !total + v - ) - with - | None -> () (* Already resumed *) - | Some request -> - if Cqs.cancel request then ( - if debug then Fmt.epr "%d: cancelled@." i; - total := !total + 1 - ) - ); - done; - Atomic.final - (fun () -> - if debug then ( - Format.eprintf "%a@." Cqs.dump t; - Format.eprintf "total=%d, expected_total=%d\n%!" !total expected_total; - ); - Cqs.Cells.validate t; - assert (!total = expected_total); - (* Printf.printf "total = %d\n%!" !total *) - ) - -(* An even simpler cell type with no payload. Just for testing removing whole cancelled segments. *) -module Unit_cells(Config : sig val segment_order : int end) = struct - module Cell = struct - type _ t = - | Empty (* A consumer is intending to collect a value in the future *) - | Value (* A value is waiting for its consumer *) - | Cancelled (* The consumer cancelled *) - - let init = Empty - - let segment_order = Config.segment_order - - let dump f = function - | Empty -> Fmt.string f "Empty" - | Value -> Fmt.string f "Value" - | Cancelled -> Fmt.string f "Cancelled" - end - module Cells = Cells.Make(Cell) - - type request = unit Cells.segment * unit Cell.t Atomic.t - - let cancel (segment, cell) = - if Atomic.compare_and_set cell Cell.Empty Cancelled then ( - Cells.cancel_cell segment; - true - ) else false (* Already at [Value]; cancellation fails. *) - - (* Provide a value. Returns [false] if already [Cancelled]. *) - let resume t = - let cell = Cells.next_resume t in - Atomic.compare_and_set cell Empty Value - - (* We reuse the [Empty] state to mean [Waiting]. *) - let suspend t : request = Cells.next_suspend t - - let resume_all t = - Cells.resume_all t - - let make = Cells.make - let dump f t = Atomic.check (fun () -> Cells.dump f t; true) - let validate t = Atomic.check (fun () -> Cells.validate t; true) -end - -(* A producer writes [n_items] to the queue (retrying if the cell gets cancelled first). - A consumer reads [n_items] from the queue (cancelling and retrying once if it can). - At the end, the consumer and resumer are at the same position. - This tests what happens if a whole segment gets cancelled and the producer therefore skips it. - [test_cells] is too slow to test this. *) -let test_skip_segments ~segment_order ~n_items () = - let module Cells = Unit_cells(struct let segment_order = segment_order end) in - if debug then print_endline "== start =="; - let t = Cells.make () in - Atomic.spawn (fun () -> - for _ = 1 to n_items do - let rec loop ~may_cancel = - if debug then print_endline "suspend"; - let request = Cells.suspend t in - if may_cancel && Cells.cancel request then ( - if debug then print_endline "cancelled"; - loop ~may_cancel:false - ) - in - loop ~may_cancel:true - done - ); - Atomic.spawn (fun () -> - for _ = 1 to n_items do - if debug then print_endline "resume"; - while not (Cells.resume t) do () done - done - ); - Atomic.final - (fun () -> - if debug then Fmt.pr "%a@." Cells.dump t; - Cells.Cells.validate t; - assert (Cells.Cells.Position.index t.suspend = - Cells.Cells.Position.index t.resume); - ) - -(* Create a list of [n_internal + 2] segments and cancel all the internal ones. - Ensure the list is valid afterwards. - This is simpler than [test_skip_segments], so we can test longer sequences - of cancellations. *) -let test_cancel_only ~n_internal () = - let module Cells = Unit_cells(struct let segment_order = 0 end) in - let t = Cells.make () in - ignore (Cells.suspend t : Cells.request); - let internals = Array.init n_internal (fun _ -> Cells.suspend t) in - ignore (Cells.suspend t : Cells.request); - let in_progress = ref 0 in - for i = 0 to n_internal - 1 do - Atomic.spawn (fun () -> - incr in_progress; - assert (Cells.cancel internals.(i)); - decr in_progress; - if !in_progress = 0 then Cells.validate t - ) - done; - Atomic.final - (fun () -> - assert (Cells.resume t); - assert (Cells.resume t); - if debug then Fmt.pr "%a@." Cells.dump t; - Cells.validate t; - assert (Cells.Cells.Position.index t.suspend = - Cells.Cells.Position.index t.resume); - ) - -(* Create [n] requests. Then try to cancel them in parallel with doing a resume_all. - Check the number of resumed requests is plausible (at least as many as there - were requests that hadn't started cancelling, and no more than those that hadn't - finished cancelling. *) -let test_broadcast ~segment_order ~n () = - let messages = ref [] in - let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in - if debug then log "== start =="; - let module Cells = Unit_cells(struct let segment_order = segment_order end) in - let t = Cells.make () in - let requests = Array.init n (fun _ -> Cells.suspend t) in - let min_requests = Atomic.make n in - let max_requests = Atomic.make n in - for i = 0 to n - 1 do - Atomic.spawn (fun () -> - Atomic.decr min_requests; - if debug then log "Cancelling request"; - if Cells.cancel requests.(i) then ( - Atomic.decr max_requests; - if debug then log "Cancelled request"; - ) - ) - done; - Atomic.spawn (fun () -> - if debug then log "Broadcasting"; - let max_expected = Atomic.get max_requests in - let wakes = ref 0 in - Cells.resume_all t (fun cell -> - match Atomic.get cell with - | Empty -> incr wakes - | Cancelled -> () - | Value -> assert false - ); - let min_expected = Atomic.get min_requests in - let wakes = !wakes in - if debug then log "Broadcast done: wakes=%d (expected=%d-%d)" wakes min_expected max_expected; - assert (min_expected <= wakes && wakes <= max_expected) - ); - Atomic.final (fun () -> - if debug then ( - List.iter print_string (List.rev !messages) - ) - ) - -(* These tests take about 10s on my machine, with https://github.com/ocaml-multicore/dscheck/pull/3 - However, that PR is not reliable at finding all interleavings. *) -let () = - print_endline "Test broadcast:"; - Atomic.trace (test_broadcast ~segment_order:1 ~n:3); - print_endline "Test cancelling segments:"; - Atomic.trace (test_cancel_only ~n_internal:3); - print_endline "Test cancelling segments while suspending and resuming:"; - Atomic.trace (test_skip_segments ~segment_order:1 ~n_items:3); - print_endline "Test with 1 cell per segment:"; - Atomic.trace (test_cells ~segment_order:0 ~n_values:2); - print_endline "Test with 2 cells per segment:"; - Atomic.trace (test_cells ~segment_order:1 ~n_values:2) +let debug = false + +(* For each of [n_values], spawn one producer and one consumer. + If the consumer has to wait, it will also try to cancel. + The consumer increases the total if it gets a value; + the producer increments it if the cancellation succeeds instead. *) +let test_cells ~segment_order ~n_values () = + let module Cqs = Simple_cqs.Make(struct let segment_order = segment_order end) in + let expected_total = n_values in + let t = Cqs.make () in + let total = ref 0 in + for i = 1 to n_values do + Atomic.spawn (fun () -> + if debug then Fmt.epr "%d: wrote value@." i; + Cqs.resume t 1; + ); + Atomic.spawn (fun () -> + match + Cqs.suspend t (fun v -> + if debug then Fmt.epr "%d: resumed@." i; + total := !total + v + ) + with + | None -> () (* Already resumed *) + | Some request -> + if Cqs.cancel request then ( + if debug then Fmt.epr "%d: cancelled@." i; + total := !total + 1 + ) + ); + done; + Atomic.final + (fun () -> + if debug then ( + Format.eprintf "%a@." Cqs.dump t; + Format.eprintf "total=%d, expected_total=%d\n%!" !total expected_total; + ); + Cqs.Cells.validate t; + assert (!total = expected_total); + (* Printf.printf "total = %d\n%!" !total *) + ) + +(* An even simpler cell type with no payload. Just for testing removing whole cancelled segments. *) +module Unit_cells(Config : sig val segment_order : int end) = struct + module Cell = struct + type _ t = + | Empty (* A consumer is intending to collect a value in the future *) + | Value (* A value is waiting for its consumer *) + | Cancelled (* The consumer cancelled *) + + let init = Empty + + let segment_order = Config.segment_order + + let dump f = function + | Empty -> Fmt.string f "Empty" + | Value -> Fmt.string f "Value" + | Cancelled -> Fmt.string f "Cancelled" + end + module Cells = Cells.Make(Cell) + + type request = unit Cells.segment * unit Cell.t Atomic.t + + let cancel (segment, cell) = + if Atomic.compare_and_set cell Cell.Empty Cancelled then ( + Cells.cancel_cell segment; + true + ) else false (* Already at [Value]; cancellation fails. *) + + (* Provide a value. Returns [false] if already [Cancelled]. *) + let resume t = + let cell = Cells.next_resume t in + Atomic.compare_and_set cell Empty Value + + (* We reuse the [Empty] state to mean [Waiting]. *) + let suspend t : request = Cells.next_suspend t + + let resume_all t = + Cells.resume_all t + + let make = Cells.make + let dump f t = Atomic.check (fun () -> Cells.dump f t; true) + let validate t = Atomic.check (fun () -> Cells.validate t; true) +end + +(* A producer writes [n_items] to the queue (retrying if the cell gets cancelled first). + A consumer reads [n_items] from the queue (cancelling and retrying once if it can). + At the end, the consumer and resumer are at the same position. + This tests what happens if a whole segment gets cancelled and the producer therefore skips it. + [test_cells] is too slow to test this. *) +let test_skip_segments ~segment_order ~n_items () = + let module Cells = Unit_cells(struct let segment_order = segment_order end) in + if debug then print_endline "== start =="; + let t = Cells.make () in + Atomic.spawn (fun () -> + for _ = 1 to n_items do + let rec loop ~may_cancel = + if debug then print_endline "suspend"; + let request = Cells.suspend t in + if may_cancel && Cells.cancel request then ( + if debug then print_endline "cancelled"; + loop ~may_cancel:false + ) + in + loop ~may_cancel:true + done + ); + Atomic.spawn (fun () -> + for _ = 1 to n_items do + if debug then print_endline "resume"; + while not (Cells.resume t) do () done + done + ); + Atomic.final + (fun () -> + if debug then Fmt.pr "%a@." Cells.dump t; + Cells.Cells.validate t; + assert (Cells.Cells.Position.index t.suspend = + Cells.Cells.Position.index t.resume); + ) + +(* Create a list of [n_internal + 2] segments and cancel all the internal ones. + Ensure the list is valid afterwards. + This is simpler than [test_skip_segments], so we can test longer sequences + of cancellations. *) +let test_cancel_only ~n_internal () = + let module Cells = Unit_cells(struct let segment_order = 0 end) in + let t = Cells.make () in + ignore (Cells.suspend t : Cells.request); + let internals = Array.init n_internal (fun _ -> Cells.suspend t) in + ignore (Cells.suspend t : Cells.request); + let in_progress = ref 0 in + for i = 0 to n_internal - 1 do + Atomic.spawn (fun () -> + incr in_progress; + assert (Cells.cancel internals.(i)); + decr in_progress; + if !in_progress = 0 then Cells.validate t + ) + done; + Atomic.final + (fun () -> + assert (Cells.resume t); + assert (Cells.resume t); + if debug then Fmt.pr "%a@." Cells.dump t; + Cells.validate t; + assert (Cells.Cells.Position.index t.suspend = + Cells.Cells.Position.index t.resume); + ) + +(* Create [n] requests. Then try to cancel them in parallel with doing a resume_all. + Check the number of resumed requests is plausible (at least as many as there + were requests that hadn't started cancelling, and no more than those that hadn't + finished cancelling. *) +let test_broadcast ~segment_order ~n () = + let messages = ref [] in + let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in + if debug then log "== start =="; + let module Cells = Unit_cells(struct let segment_order = segment_order end) in + let t = Cells.make () in + let requests = Array.init n (fun _ -> Cells.suspend t) in + let min_requests = Atomic.make n in + let max_requests = Atomic.make n in + for i = 0 to n - 1 do + Atomic.spawn (fun () -> + Atomic.decr min_requests; + if debug then log "Cancelling request"; + if Cells.cancel requests.(i) then ( + Atomic.decr max_requests; + if debug then log "Cancelled request"; + ) + ) + done; + Atomic.spawn (fun () -> + if debug then log "Broadcasting"; + let max_expected = Atomic.get max_requests in + let wakes = ref 0 in + Cells.resume_all t (fun cell -> + match Atomic.get cell with + | Empty -> incr wakes + | Cancelled -> () + | Value -> assert false + ); + let min_expected = Atomic.get min_requests in + let wakes = !wakes in + if debug then log "Broadcast done: wakes=%d (expected=%d-%d)" wakes min_expected max_expected; + assert (min_expected <= wakes && wakes <= max_expected) + ); + Atomic.final (fun () -> + if debug then ( + List.iter print_string (List.rev !messages) + ) + ) + +(* These tests take about 10s on my machine, with https://github.com/ocaml-multicore/dscheck/pull/3 + However, that PR is not reliable at finding all interleavings. *) +let () = + print_endline "Test broadcast:"; + Atomic.trace (test_broadcast ~segment_order:1 ~n:3); + print_endline "Test cancelling segments:"; + Atomic.trace (test_cancel_only ~n_internal:3); + print_endline "Test cancelling segments while suspending and resuming:"; + Atomic.trace (test_skip_segments ~segment_order:1 ~n_items:3); + print_endline "Test with 1 cell per segment:"; + Atomic.trace (test_cells ~segment_order:0 ~n_values:2); + print_endline "Test with 2 cells per segment:"; + Atomic.trace (test_cells ~segment_order:1 ~n_values:2) diff --git a/lib_eio/tests/dscheck/test_condition.ml b/lib_eio/tests/dscheck/test_condition.ml index ac9726bd0..ac9541ea8 100644 --- a/lib_eio/tests/dscheck/test_condition.ml +++ b/lib_eio/tests/dscheck/test_condition.ml @@ -1,46 +1,46 @@ -let debug = false - -exception Abort - -module T = Condition - -(* [prod] threads increment a counter and notify a condition. - A consumer watches the condition and waits until it has seen - all of them. We check that the client always sees the final value. - If [cancel] is set, we also try to cancel the client and accept - that as success too. *) -let test ~prod ~cancel () = - let t = T.create () in - let sent = Atomic.make 0 in - for _ = 1 to prod do - Atomic.spawn (fun () -> - Atomic.incr sent; - T.broadcast t - ) - done; - let finished = ref false in - Atomic.spawn (fun () -> - let ctx = - Fake_sched.run @@ fun () -> - try - T.loop_no_mutex t (fun () -> - if Atomic.get sent = prod && not cancel then Some () - else None - ); - finished := true - with T.Cancel.Cancelled Abort -> - finished := true - in - if cancel then - Option.iter (fun c -> T.Cancel.cancel c Abort) ctx - ); - Atomic.final (fun () -> - Atomic.check (fun () -> !finished); - if debug then ( - Fmt.pr "%a@." Broadcast.dump t; - ); - ) - -let () = - Atomic.trace (test ~prod:2 ~cancel:false); - Atomic.trace (test ~prod:2 ~cancel:true) +let debug = false + +exception Abort + +module T = Condition + +(* [prod] threads increment a counter and notify a condition. + A consumer watches the condition and waits until it has seen + all of them. We check that the client always sees the final value. + If [cancel] is set, we also try to cancel the client and accept + that as success too. *) +let test ~prod ~cancel () = + let t = T.create () in + let sent = Atomic.make 0 in + for _ = 1 to prod do + Atomic.spawn (fun () -> + Atomic.incr sent; + T.broadcast t + ) + done; + let finished = ref false in + Atomic.spawn (fun () -> + let ctx = + Fake_sched.run @@ fun () -> + try + T.loop_no_mutex t (fun () -> + if Atomic.get sent = prod && not cancel then Some () + else None + ); + finished := true + with T.Cancel.Cancelled Abort -> + finished := true + in + if cancel then + Option.iter (fun c -> T.Cancel.cancel c Abort) ctx + ); + Atomic.final (fun () -> + Atomic.check (fun () -> !finished); + if debug then ( + Fmt.pr "%a@." Broadcast.dump t; + ); + ) + +let () = + Atomic.trace (test ~prod:2 ~cancel:false); + Atomic.trace (test ~prod:2 ~cancel:true) diff --git a/lib_eio/tests/dscheck/test_pool.ml b/lib_eio/tests/dscheck/test_pool.ml index 12a42d21d..44675d747 100644 --- a/lib_eio/tests/dscheck/test_pool.ml +++ b/lib_eio/tests/dscheck/test_pool.ml @@ -1,34 +1,34 @@ -module T = Pool -module Cancel = Eio__core.Cancel - -exception Abort - -(* [clients] threads try to use a pool of size [n]. - If [cancel] is set, they also try to cancel, and accept - that as success too. *) -let test ~n ~clients ~cancel () = - let t = T.create n (fun () -> ()) in - let used = Atomic.make 0 in - let finished = ref 0 in - for _ = 1 to clients do - Atomic.spawn (fun () -> - let ctx = - Fake_sched.run @@ fun () -> - try - T.use t (fun () -> Atomic.incr used); - incr finished; - with Cancel.Cancelled Abort -> - incr finished; - in - if cancel then - Option.iter (fun c -> Cancel.cancel c Abort) ctx - ) - done; - Atomic.final (fun () -> - if not cancel then Atomic.check (fun () -> Atomic.get used = clients); - Atomic.check (fun () -> !finished = clients); - ) - -let () = - Atomic.trace (test ~n:1 ~clients:2 ~cancel:false); - Atomic.trace (test ~n:1 ~clients:2 ~cancel:true) +module T = Pool +module Cancel = Eio__core.Cancel + +exception Abort + +(* [clients] threads try to use a pool of size [n]. + If [cancel] is set, they also try to cancel, and accept + that as success too. *) +let test ~n ~clients ~cancel () = + let t = T.create n (fun () -> ()) in + let used = Atomic.make 0 in + let finished = ref 0 in + for _ = 1 to clients do + Atomic.spawn (fun () -> + let ctx = + Fake_sched.run @@ fun () -> + try + T.use t (fun () -> Atomic.incr used); + incr finished; + with Cancel.Cancelled Abort -> + incr finished; + in + if cancel then + Option.iter (fun c -> Cancel.cancel c Abort) ctx + ) + done; + Atomic.final (fun () -> + if not cancel then Atomic.check (fun () -> Atomic.get used = clients); + Atomic.check (fun () -> !finished = clients); + ) + +let () = + Atomic.trace (test ~n:1 ~clients:2 ~cancel:false); + Atomic.trace (test ~n:1 ~clients:2 ~cancel:true) diff --git a/lib_eio/tests/dscheck/test_rcfd.ml b/lib_eio/tests/dscheck/test_rcfd.ml index c7a4843d5..419f6451f 100644 --- a/lib_eio/tests/dscheck/test_rcfd.ml +++ b/lib_eio/tests/dscheck/test_rcfd.ml @@ -1,39 +1,39 @@ -let debug = false - -module T = Rcfd - -let test ~n_users ~n_closers () = - let messages = ref [] in - let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in - if debug then log "== start =="; - let wrapped_fd = Unix.make () in - let t = T.make wrapped_fd in - let n_closed = ref 0 in - for _ = 1 to n_users do - Atomic.spawn (fun () -> - T.use t ~if_closed:ignore (fun fd -> - log "Using FD"; - assert (Atomic.get fd = `Open); - log "Releasing FD"; - ) - ) - done; - for _ = 1 to n_closers do - Atomic.spawn (fun () -> - log "Closing FD"; - if T.close t then ( - log "Closed FD"; - incr n_closed - ) else ( - log "FD already closed"; - ) - ) - done; - Atomic.final (fun () -> - if debug then List.iter print_string (List.rev !messages); - assert (!n_closed = 1); - assert (Atomic.get wrapped_fd = `Closed); - ) - -let () = - Atomic.trace (test ~n_users:2 ~n_closers:2); +let debug = false + +module T = Rcfd + +let test ~n_users ~n_closers () = + let messages = ref [] in + let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in + if debug then log "== start =="; + let wrapped_fd = Unix.make () in + let t = T.make wrapped_fd in + let n_closed = ref 0 in + for _ = 1 to n_users do + Atomic.spawn (fun () -> + T.use t ~if_closed:ignore (fun fd -> + log "Using FD"; + assert (Atomic.get fd = `Open); + log "Releasing FD"; + ) + ) + done; + for _ = 1 to n_closers do + Atomic.spawn (fun () -> + log "Closing FD"; + if T.close t then ( + log "Closed FD"; + incr n_closed + ) else ( + log "FD already closed"; + ) + ) + done; + Atomic.final (fun () -> + if debug then List.iter print_string (List.rev !messages); + assert (!n_closed = 1); + assert (Atomic.get wrapped_fd = `Closed); + ) + +let () = + Atomic.trace (test ~n_users:2 ~n_closers:2); diff --git a/lib_eio/tests/dscheck/test_semaphore.ml b/lib_eio/tests/dscheck/test_semaphore.ml index 7ea049f4d..838a54d8e 100644 --- a/lib_eio/tests/dscheck/test_semaphore.ml +++ b/lib_eio/tests/dscheck/test_semaphore.ml @@ -1,49 +1,49 @@ -let debug = false - -module T = Sem_state - -let test ~capacity ~users () = - let messages = ref [] in - let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in - if debug then log "== start =="; - let t = T.create capacity in - let running = Atomic.make 0 in - let acquire fn = - if T.acquire t then (fn (); None) - else T.suspend t fn - in - for i = 1 to users do - Atomic.spawn (fun () -> - match - acquire (fun () -> - if debug then log "%d: got resource" i; - Atomic.incr running; - Atomic.decr running; - if debug then log "%d: released resource" i; - T.release t - ) - with - | None -> () - | Some request -> - if T.cancel request then ( - if debug then log "%d: cancelled request" i; - ) - ) - done; - Atomic.every (fun () -> assert (Atomic.get running <= capacity)); - Atomic.final (fun () -> - if debug then ( - List.iter print_string (List.rev !messages); - Fmt.pr "%a@." T.dump t; - ); - assert (Atomic.get t.state = capacity); - (* Do a dummy non-cancelled operation to ensure the pointers end up together: *) - T.resume t; - assert (T.suspend t ignore = None); - assert (T.Cells.Position.index t.cells.suspend = - T.Cells.Position.index t.cells.resume); - ) - -let () = - Atomic.trace (test ~capacity:1 ~users:3); - Atomic.trace (test ~capacity:2 ~users:3) +let debug = false + +module T = Sem_state + +let test ~capacity ~users () = + let messages = ref [] in + let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in + if debug then log "== start =="; + let t = T.create capacity in + let running = Atomic.make 0 in + let acquire fn = + if T.acquire t then (fn (); None) + else T.suspend t fn + in + for i = 1 to users do + Atomic.spawn (fun () -> + match + acquire (fun () -> + if debug then log "%d: got resource" i; + Atomic.incr running; + Atomic.decr running; + if debug then log "%d: released resource" i; + T.release t + ) + with + | None -> () + | Some request -> + if T.cancel request then ( + if debug then log "%d: cancelled request" i; + ) + ) + done; + Atomic.every (fun () -> assert (Atomic.get running <= capacity)); + Atomic.final (fun () -> + if debug then ( + List.iter print_string (List.rev !messages); + Fmt.pr "%a@." T.dump t; + ); + assert (Atomic.get t.state = capacity); + (* Do a dummy non-cancelled operation to ensure the pointers end up together: *) + T.resume t; + assert (T.suspend t ignore = None); + assert (T.Cells.Position.index t.cells.suspend = + T.Cells.Position.index t.cells.resume); + ) + +let () = + Atomic.trace (test ~capacity:1 ~users:3); + Atomic.trace (test ~capacity:2 ~users:3) diff --git a/lib_eio/tests/dscheck/test_sync.ml b/lib_eio/tests/dscheck/test_sync.ml index 6d0c053f3..0ffc06c23 100644 --- a/lib_eio/tests/dscheck/test_sync.ml +++ b/lib_eio/tests/dscheck/test_sync.ml @@ -1,154 +1,154 @@ -let debug = false - -module T = Sync - -(* Create a synchronous channel. [prod] producers write values to it and [cons] consumers take values. - Both producers and consumers try to cancel if they can. - [take_nonblocking] additional consumers also perform a single non-blocking take. - At the end, we check that: - - We received the expected values. - - No processes are still queued up (since everything tries to cancel before finishing). - *) -let test ~prod ~cons ~take_nonblocking () = - let messages = ref [] in - let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in - if debug then log "== start =="; - let t = T.create () in - let finished_producers = ref 0 in - let expected_total = ref 0 in - let received = ref 0 in - let cancelled_consumers = ref 0 in - let cancelled_producers = ref 0 in - let run_consumer l = - Fake_sched.run - (fun () -> - match T.take t with - | Error `Closed -> assert false - | Ok v -> - if debug then log "c%d: Recv %d" l v; - received := !received + v - | exception Eio__core.Cancel.Cancelled _ -> - if debug then log "c%d: Cancelled" l; - incr cancelled_consumers - ) - |> Option.iter (fun ctx -> - if debug then log "c%d: Suspended" l; - Fake_sched.cancel ctx; - ) - in - let run_producer v = - Fake_sched.run - (fun () -> - match T.put t v with - | () -> - if debug then log "p%d: Sent" v; - expected_total := !expected_total + v; - incr finished_producers - | exception Eio__core.Cancel.Cancelled _ -> - if debug then log "p%d: Cancelled" v; - incr finished_producers; - incr cancelled_producers - ) - |> Option.iter (fun ctx -> - if debug then log "p%d: Suspended sending" v; - Fake_sched.cancel ctx - ) - in - for i = 1 to prod do - Atomic.spawn (fun () -> run_producer i) - done; - for i = 1 to cons do - Atomic.spawn (fun () -> run_consumer i) - done; - for i = 1 to take_nonblocking do - Atomic.spawn (fun () -> - match T.take_nonblocking t with - | Error `Closed -> assert false - | Error `Would_block -> - if debug then log "nb%d: found nothing" i; - incr cancelled_consumers; - | Ok v -> - if debug then log "nb%d: took %d" i v; - received := !received + v - ) - done; - Atomic.final (fun () -> - if debug then ( - List.iter print_string (List.rev !messages); - Fmt.pr "%a@." T.dump t; - Fmt.pr "Received total = %d/%d (%d/%d cancelled consumers)@." - !received !expected_total - !cancelled_consumers (cons + take_nonblocking); - Fmt.pr "Finished producers = %d/%d (incl %d cancelled)@." - !finished_producers prod - !cancelled_producers; - ); - assert (!finished_producers = prod); - (* Everyone finishes by trying to cancel (if they didn't succeed immediately), - so there shouldn't be any balance at the end. *) - assert (T.balance t = Ok 0); - assert (!received = !expected_total); - ) - -(* A producer puts "A" and then closes the stream. - Two consumers try to read. One gets the "A", the other gets end-of-stream. *) -let test_close () = - let t = T.create () in - let got = ref [] in - Atomic.spawn - (fun () -> - let _ : Sync.Cancel.t option = Fake_sched.run (fun () -> T.put t "A"; T.close t) in - () - ); - for _ = 1 to 2 do - Atomic.spawn - (fun () -> - let _ : Sync.Cancel.t option = Fake_sched.run (fun () -> - let msg = T.take t |> Result.value ~default:"end-of-stream" in - got := msg :: !got - ) - in - () - ); - done; - Atomic.final (fun () -> - let results = List.sort String.compare !got in - if debug then ( - Fmt.pr "%a@." T.dump t; - Fmt.pr "%a@." Fmt.(Dump.list string) results; - ); - assert (results = ["A"; "end-of-stream"]); - assert (T.balance t = Error `Closed); - ) - -(* A producer tries to add an item (but never succeeds, as there are no consumers). - At some point, the stream is closed and the operation aborts. *) -let test_close2 () = - let t = T.create () in - let result = ref "Waiting" in - Atomic.spawn - (fun () -> - let _ : Sync.Cancel.t option = Fake_sched.run (fun () -> - match T.put t "A" with - | () -> failwith "Shouldn't succeed with no consumer!" - | exception (Invalid_argument msg) -> result := msg - ) in - () - ); - Atomic.spawn (fun () -> T.close t); - Atomic.final (fun () -> - if debug then ( - Fmt.pr "%a@." T.dump t; - Fmt.pr "%s@." !result; - ); - match !result with - | "Stream closed" -> () - | x -> failwith x - ) - -let () = - Atomic.trace (test ~prod:1 ~cons:1 ~take_nonblocking:1); - Atomic.trace (test ~prod:2 ~cons:1 ~take_nonblocking:0); - Atomic.trace (test ~prod:1 ~cons:2 ~take_nonblocking:0); - Atomic.trace test_close; - Atomic.trace test_close2; +let debug = false + +module T = Sync + +(* Create a synchronous channel. [prod] producers write values to it and [cons] consumers take values. + Both producers and consumers try to cancel if they can. + [take_nonblocking] additional consumers also perform a single non-blocking take. + At the end, we check that: + - We received the expected values. + - No processes are still queued up (since everything tries to cancel before finishing). + *) +let test ~prod ~cons ~take_nonblocking () = + let messages = ref [] in + let log fmt = (fmt ^^ "@.") |> Format.kasprintf @@ fun msg -> messages := msg :: !messages in + if debug then log "== start =="; + let t = T.create () in + let finished_producers = ref 0 in + let expected_total = ref 0 in + let received = ref 0 in + let cancelled_consumers = ref 0 in + let cancelled_producers = ref 0 in + let run_consumer l = + Fake_sched.run + (fun () -> + match T.take t with + | Error `Closed -> assert false + | Ok v -> + if debug then log "c%d: Recv %d" l v; + received := !received + v + | exception Eio__core.Cancel.Cancelled _ -> + if debug then log "c%d: Cancelled" l; + incr cancelled_consumers + ) + |> Option.iter (fun ctx -> + if debug then log "c%d: Suspended" l; + Fake_sched.cancel ctx; + ) + in + let run_producer v = + Fake_sched.run + (fun () -> + match T.put t v with + | () -> + if debug then log "p%d: Sent" v; + expected_total := !expected_total + v; + incr finished_producers + | exception Eio__core.Cancel.Cancelled _ -> + if debug then log "p%d: Cancelled" v; + incr finished_producers; + incr cancelled_producers + ) + |> Option.iter (fun ctx -> + if debug then log "p%d: Suspended sending" v; + Fake_sched.cancel ctx + ) + in + for i = 1 to prod do + Atomic.spawn (fun () -> run_producer i) + done; + for i = 1 to cons do + Atomic.spawn (fun () -> run_consumer i) + done; + for i = 1 to take_nonblocking do + Atomic.spawn (fun () -> + match T.take_nonblocking t with + | Error `Closed -> assert false + | Error `Would_block -> + if debug then log "nb%d: found nothing" i; + incr cancelled_consumers; + | Ok v -> + if debug then log "nb%d: took %d" i v; + received := !received + v + ) + done; + Atomic.final (fun () -> + if debug then ( + List.iter print_string (List.rev !messages); + Fmt.pr "%a@." T.dump t; + Fmt.pr "Received total = %d/%d (%d/%d cancelled consumers)@." + !received !expected_total + !cancelled_consumers (cons + take_nonblocking); + Fmt.pr "Finished producers = %d/%d (incl %d cancelled)@." + !finished_producers prod + !cancelled_producers; + ); + assert (!finished_producers = prod); + (* Everyone finishes by trying to cancel (if they didn't succeed immediately), + so there shouldn't be any balance at the end. *) + assert (T.balance t = Ok 0); + assert (!received = !expected_total); + ) + +(* A producer puts "A" and then closes the stream. + Two consumers try to read. One gets the "A", the other gets end-of-stream. *) +let test_close () = + let t = T.create () in + let got = ref [] in + Atomic.spawn + (fun () -> + let _ : Sync.Cancel.t option = Fake_sched.run (fun () -> T.put t "A"; T.close t) in + () + ); + for _ = 1 to 2 do + Atomic.spawn + (fun () -> + let _ : Sync.Cancel.t option = Fake_sched.run (fun () -> + let msg = T.take t |> Result.value ~default:"end-of-stream" in + got := msg :: !got + ) + in + () + ); + done; + Atomic.final (fun () -> + let results = List.sort String.compare !got in + if debug then ( + Fmt.pr "%a@." T.dump t; + Fmt.pr "%a@." Fmt.(Dump.list string) results; + ); + assert (results = ["A"; "end-of-stream"]); + assert (T.balance t = Error `Closed); + ) + +(* A producer tries to add an item (but never succeeds, as there are no consumers). + At some point, the stream is closed and the operation aborts. *) +let test_close2 () = + let t = T.create () in + let result = ref "Waiting" in + Atomic.spawn + (fun () -> + let _ : Sync.Cancel.t option = Fake_sched.run (fun () -> + match T.put t "A" with + | () -> failwith "Shouldn't succeed with no consumer!" + | exception (Invalid_argument msg) -> result := msg + ) in + () + ); + Atomic.spawn (fun () -> T.close t); + Atomic.final (fun () -> + if debug then ( + Fmt.pr "%a@." T.dump t; + Fmt.pr "%s@." !result; + ); + match !result with + | "Stream closed" -> () + | x -> failwith x + ) + +let () = + Atomic.trace (test ~prod:1 ~cons:1 ~take_nonblocking:1); + Atomic.trace (test ~prod:2 ~cons:1 ~take_nonblocking:0); + Atomic.trace (test ~prod:1 ~cons:2 ~take_nonblocking:0); + Atomic.trace test_close; + Atomic.trace test_close2; diff --git a/lib_eio/tests/dscheck/unix.ml b/lib_eio/tests/dscheck/unix.ml index dc5d29f55..14d318b40 100644 --- a/lib_eio/tests/dscheck/unix.ml +++ b/lib_eio/tests/dscheck/unix.ml @@ -1,7 +1,7 @@ -type file_descr = [`Open | `Closed] Atomic.t - -let make () = Atomic.make `Open - -let close t = - if not (Atomic.compare_and_set t `Open `Closed) then - failwith "Already closed!" +type file_descr = [`Open | `Closed] Atomic.t + +let make () = Atomic.make `Open + +let close t = + if not (Atomic.compare_and_set t `Open `Closed) then + failwith "Already closed!" diff --git a/lib_eio/tests/dune b/lib_eio/tests/dune index 217338572..5d6050f97 100644 --- a/lib_eio/tests/dune +++ b/lib_eio/tests/dune @@ -1,7 +1,7 @@ -(mdx - (package eio) - (enabled_if (<> %{os_type} "Win32")) - (deps - (package eio) - (file ./dscheck/fake_sched.ml) - (file ./dscheck/fake_sched.mli))) +(mdx + (package eio) + (enabled_if (<> %{os_type} "Win32")) + (deps + (package eio) + (file ./dscheck/fake_sched.ml) + (file ./dscheck/fake_sched.mli))) diff --git a/lib_eio/tests/semaphore.md b/lib_eio/tests/semaphore.md index 19d708fe5..7db3db25e 100644 --- a/lib_eio/tests/semaphore.md +++ b/lib_eio/tests/semaphore.md @@ -1,210 +1,210 @@ -```ocaml -# #require "eio";; -``` -```ocaml -module T = Eio__Sem_state -let show t = Fmt.pr "%a@." T.dump t - -let acquire t label = - if T.acquire t then ( - Fmt.pr "%s: Acquired@." label; - None - ) else ( - T.suspend t (fun () -> Fmt.pr "%s: Acquired@." label) - ) -``` - -Initially we have a single segment full of empty cells. -Both resume and suspend pointers point at the first cell: - -```ocaml -# let t : T.t = T.create 1;; -val t : T.t = {T.state = ; cells = } -# show t;; -Semaphore (state=1) -Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition -End -- : unit = () -``` - -The first user can take the lock just by decrementing the state counter: - -```ocaml -# acquire t "a";; -a: Acquired -- : T.request option = None - -# show t;; -Semaphore (state=0) -Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition -End -- : unit = () -``` - -However, a second user must wait: - -```ocaml -# acquire t "b";;; -- : T.request option = -Some ({T.state = ; cells = }, , ) - -# show t;; -Semaphore (state=-1) -Segment 0 (prev=None, pointers=2, cancelled=0): - Request (resume) - In_transition (suspend) - In_transition - In_transition -End -- : unit = () -``` - -Same for a third user: - -```ocaml -# acquire t "c";;; -- : T.request option = -Some ({T.state = ; cells = }, , ) - -# show t;; -Semaphore (state=-2) -Segment 0 (prev=None, pointers=2, cancelled=0): - Request (resume) - Request - In_transition (suspend) - In_transition -End -- : unit = () -``` - -When the first user releases it, the second one runs: - -```ocaml -# T.release t;; -b: Acquired -- : unit = () - -# show t;; -Semaphore (state=-1) -Segment 0 (prev=None, pointers=2, cancelled=0): - Finished - Request (resume) - In_transition (suspend) - In_transition -End -- : unit = () -``` - -When that finishes, the third one runs: - -```ocaml -# T.release t;; -c: Acquired -- : unit = () -``` - -The final release, with no waiters, just increments the state counter: - -```ocaml -# T.release t;; -- : unit = () - -# show t;; -Semaphore (state=1) -Segment 0 (prev=None, pointers=2, cancelled=0): - Finished - Finished - In_transition (suspend) (resume) - In_transition -End -- : unit = () -``` - -## Cancellation - -"b" and "c" have to wait, as "a" has the resource: - -```ocaml -# let t : T.t = T.create 1;; -val t : T.t = {T.state = ; cells = } - -# acquire t "a";; -a: Acquired -- : T.request option = None - -# let b = acquire t "b" |> Option.get;; -val b : T.request = ({T.state = ; cells = }, , ) - -# let c = acquire t "c" |> Option.get;; -val c : T.request = ({T.state = ; cells = }, , ) - -# show t;; -Semaphore (state=-2) -Segment 0 (prev=None, pointers=2, cancelled=0): - Request (resume) - Request - In_transition (suspend) - In_transition -End -- : unit = () -``` - -Cancelling "b" increments the state counter and its request simply becomes Finished: - -```ocaml -# T.cancel b;; -- : bool = true - -# show t;; -Semaphore (state=-1) -Segment 0 (prev=None, pointers=2, cancelled=1): - Finished (resume) - Request - In_transition (suspend) - In_transition -End -- : unit = () -``` - -When "a" releases it, "c" is resumed: - -```ocaml -# T.release t;; -c: Acquired -- : unit = () - -# show t;; -Semaphore (state=0) -Segment 0 (prev=None, pointers=2, cancelled=1): - Finished - Finished - In_transition (suspend) (resume) - In_transition -End -- : unit = () -``` - -Finally, finishing "c" restores the state to 1: - -```ocaml -# T.release t;; -- : unit = () - -# show t;; -Semaphore (state=1) -Segment 0 (prev=None, pointers=2, cancelled=1): - Finished - Finished - In_transition (suspend) (resume) - In_transition -End -- : unit = () -``` +```ocaml +# #require "eio";; +``` +```ocaml +module T = Eio__Sem_state +let show t = Fmt.pr "%a@." T.dump t + +let acquire t label = + if T.acquire t then ( + Fmt.pr "%s: Acquired@." label; + None + ) else ( + T.suspend t (fun () -> Fmt.pr "%s: Acquired@." label) + ) +``` + +Initially we have a single segment full of empty cells. +Both resume and suspend pointers point at the first cell: + +```ocaml +# let t : T.t = T.create 1;; +val t : T.t = {T.state = ; cells = } +# show t;; +Semaphore (state=1) +Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition +End +- : unit = () +``` + +The first user can take the lock just by decrementing the state counter: + +```ocaml +# acquire t "a";; +a: Acquired +- : T.request option = None + +# show t;; +Semaphore (state=0) +Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition +End +- : unit = () +``` + +However, a second user must wait: + +```ocaml +# acquire t "b";;; +- : T.request option = +Some ({T.state = ; cells = }, , ) + +# show t;; +Semaphore (state=-1) +Segment 0 (prev=None, pointers=2, cancelled=0): + Request (resume) + In_transition (suspend) + In_transition + In_transition +End +- : unit = () +``` + +Same for a third user: + +```ocaml +# acquire t "c";;; +- : T.request option = +Some ({T.state = ; cells = }, , ) + +# show t;; +Semaphore (state=-2) +Segment 0 (prev=None, pointers=2, cancelled=0): + Request (resume) + Request + In_transition (suspend) + In_transition +End +- : unit = () +``` + +When the first user releases it, the second one runs: + +```ocaml +# T.release t;; +b: Acquired +- : unit = () + +# show t;; +Semaphore (state=-1) +Segment 0 (prev=None, pointers=2, cancelled=0): + Finished + Request (resume) + In_transition (suspend) + In_transition +End +- : unit = () +``` + +When that finishes, the third one runs: + +```ocaml +# T.release t;; +c: Acquired +- : unit = () +``` + +The final release, with no waiters, just increments the state counter: + +```ocaml +# T.release t;; +- : unit = () + +# show t;; +Semaphore (state=1) +Segment 0 (prev=None, pointers=2, cancelled=0): + Finished + Finished + In_transition (suspend) (resume) + In_transition +End +- : unit = () +``` + +## Cancellation + +"b" and "c" have to wait, as "a" has the resource: + +```ocaml +# let t : T.t = T.create 1;; +val t : T.t = {T.state = ; cells = } + +# acquire t "a";; +a: Acquired +- : T.request option = None + +# let b = acquire t "b" |> Option.get;; +val b : T.request = ({T.state = ; cells = }, , ) + +# let c = acquire t "c" |> Option.get;; +val c : T.request = ({T.state = ; cells = }, , ) + +# show t;; +Semaphore (state=-2) +Segment 0 (prev=None, pointers=2, cancelled=0): + Request (resume) + Request + In_transition (suspend) + In_transition +End +- : unit = () +``` + +Cancelling "b" increments the state counter and its request simply becomes Finished: + +```ocaml +# T.cancel b;; +- : bool = true + +# show t;; +Semaphore (state=-1) +Segment 0 (prev=None, pointers=2, cancelled=1): + Finished (resume) + Request + In_transition (suspend) + In_transition +End +- : unit = () +``` + +When "a" releases it, "c" is resumed: + +```ocaml +# T.release t;; +c: Acquired +- : unit = () + +# show t;; +Semaphore (state=0) +Segment 0 (prev=None, pointers=2, cancelled=1): + Finished + Finished + In_transition (suspend) (resume) + In_transition +End +- : unit = () +``` + +Finally, finishing "c" restores the state to 1: + +```ocaml +# T.release t;; +- : unit = () + +# show t;; +Semaphore (state=1) +Segment 0 (prev=None, pointers=2, cancelled=1): + Finished + Finished + In_transition (suspend) (resume) + In_transition +End +- : unit = () +``` diff --git a/lib_eio/tests/sync.md b/lib_eio/tests/sync.md index e8e9729c1..2eac226de 100644 --- a/lib_eio/tests/sync.md +++ b/lib_eio/tests/sync.md @@ -1,397 +1,397 @@ -```ocaml -# #require "eio";; -# #mod_use "dscheck/fake_sched.ml";; -module Fake_sched : - sig - val cancel : Eio.Cancel.t -> unit - val run : (unit -> unit) -> Eio.Cancel.t option - end -``` -```ocaml -module T = Eio__Sync -module Fiber_context = Eio.Private.Fiber_context - -let show t = Fmt.pr "%a@." T.dump t - -let put t v = - Fake_sched.run - (fun () -> - match T.put t v with - | () -> Fmt.pr "Sent %s@." v - | exception (Eio.Cancel.Cancelled _) -> Fmt.pr "Send of %s was cancelled@." v - | exception (Invalid_argument msg) -> Fmt.pr "Error adding %s: %s@." v msg - ) - |> Option.map (fun ctx -> - Fmt.pr "Waiting for a consumer for %s@." v; - ctx - ) - -let take t label = - Fake_sched.run - (fun () -> - match T.take t with - | Error `Closed -> Fmt.pr "%s: Stream was closed@." label - | Ok v -> Fmt.pr "%s: Took %s@." label v - | exception (Eio.Cancel.Cancelled _) -> Fmt.pr "%s: Take cancelled@." label - ) - |> Option.map (fun ctx -> - Fmt.pr "%s: Waiting for producer@." label; - ctx - ) -``` - -Initially there are no consumers or producers: - -```ocaml -# let t : string T.t = T.create ();; -val t : string T.t = -# show t;; -Sync (balance=0) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End -- : unit = () -``` - -Adding one consumer makes the balance go negative: - -```ocaml -# take t "cons1";; -cons1: Waiting for producer -- : Eio.Cancel.t option = Some - -# show t;; -Sync (balance=-1) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Slot (resume) - In_transition (suspend) - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End -- : unit = () -``` - -Sending a value wakes it: - -```ocaml -# put t "A";; -cons1: Took A -Sent A -- : Eio.Cancel.t option = None - -# show t;; -Sync (balance=0) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Finished - In_transition (suspend) (resume) - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End -- : unit = () -``` - -Trying to send a second value waits on the producers queue, setting the balance to 1: - -```ocaml -# put t "B";; -Waiting for a consumer for B -- : Eio.Cancel.t option = Some - -# show t;; -Sync (balance=1) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Finished - In_transition (suspend) (resume) - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Item (resume) - In_transition (suspend) - In_transition - In_transition - End -- : unit = () -``` - -Sending a third value must also wait: -```ocaml -# put t "C";; -Waiting for a consumer for C -- : Eio.Cancel.t option = Some - -# show t;; -Sync (balance=2) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Finished - In_transition (suspend) (resume) - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Item (resume) - Item - In_transition (suspend) - In_transition - End -- : unit = () -``` - -The next consumer reads the first value and wakes the first producer: -```ocaml -# take t "cons2";; -Sent B -cons2: Took B -- : Eio.Cancel.t option = None - -# show t;; -Sync (balance=1) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Finished - In_transition (suspend) (resume) - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Finished - Item (resume) - In_transition (suspend) - In_transition - End -- : unit = () -``` - -Finally, we collect the last value: -```ocaml -# take t "cons3";; -Sent C -cons3: Took C -- : Eio.Cancel.t option = None -``` - -## Cancellation - -Cancelling a consumer restores the balance: -```ocaml -# let t : string T.t = T.create ();; -val t : string T.t = -# let request = take t "cons1" |> Option.get;; -cons1: Waiting for producer -val request : Eio.Cancel.t = - -# show t;; -Sync (balance=-1) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Slot (resume) - In_transition (suspend) - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End -- : unit = () -``` - -```ocaml -# Fake_sched.cancel request;; -cons1: Take cancelled -- : unit = () - -# show t;; -Sync (balance=0) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=1): - Finished (resume) - In_transition (suspend) - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End -- : unit = () -``` - -Cancelling a producer restores the balance count: - -```ocaml -# let t : string T.t = T.create ();; -val t : string T.t = -# let a = put t "A" |> Option.get;; -Waiting for a consumer for A -val a : Eio.Cancel.t = -# put t "B" |> Option.get;; -Waiting for a consumer for B -- : Eio.Cancel.t = - -# show t;; -Sync (balance=2) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Item (resume) - Item - In_transition (suspend) - In_transition - End -- : unit = () - -# Fake_sched.cancel a;; -Send of A was cancelled -- : unit = () - -# show t;; -Sync (balance=1) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=1): - Finished (resume) - Item - In_transition (suspend) - In_transition - End -- : unit = () -``` - -The next consumer sees the second value: - -```ocaml -# take t "cons4";; -Sent B -cons4: Took B -- : Eio.Cancel.t option = None - -# show t;; -Sync (balance=0) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=1): - Finished - Finished - In_transition (suspend) (resume) - In_transition - End -- : unit = () -``` - -## Closing - -Closing cancels any waiting producers: - -```ocaml -# let t : string T.t = T.create ();; -val t : string T.t = - -# put t "A" |> Option.get;; -Waiting for a consumer for A -- : Eio.Cancel.t = - -# T.close t;; -Error adding A: Stream closed -- : unit = () - -# show t;; -Sync (balance=(closed)) - Consumers: - Segment 0 (prev=None, pointers=2, cancelled=0): - In_transition (suspend) (resume) - In_transition - In_transition - In_transition - End - Producers: - Segment 0 (prev=None, pointers=2, cancelled=0): - Finished - In_transition (suspend) (resume) - In_transition - In_transition - End -- : unit = () - -# put t "B";; -Error adding B: Stream closed -- : Eio.Cancel.t option = None -``` - -Closing cancels any waiting consumers: - -```ocaml -# let t : string T.t = T.create ();; -val t : string T.t = - -# take t "A";; -A: Waiting for producer -- : Eio.Cancel.t option = Some - -# T.close t;; -A: Stream was closed -- : unit = () - -# take t "B";; -B: Stream was closed -- : Eio.Cancel.t option = None - -# T.take_nonblocking t;; -- : (string, [> `Closed | `Would_block ]) result = Error `Closed -``` +```ocaml +# #require "eio";; +# #mod_use "dscheck/fake_sched.ml";; +module Fake_sched : + sig + val cancel : Eio.Cancel.t -> unit + val run : (unit -> unit) -> Eio.Cancel.t option + end +``` +```ocaml +module T = Eio__Sync +module Fiber_context = Eio.Private.Fiber_context + +let show t = Fmt.pr "%a@." T.dump t + +let put t v = + Fake_sched.run + (fun () -> + match T.put t v with + | () -> Fmt.pr "Sent %s@." v + | exception (Eio.Cancel.Cancelled _) -> Fmt.pr "Send of %s was cancelled@." v + | exception (Invalid_argument msg) -> Fmt.pr "Error adding %s: %s@." v msg + ) + |> Option.map (fun ctx -> + Fmt.pr "Waiting for a consumer for %s@." v; + ctx + ) + +let take t label = + Fake_sched.run + (fun () -> + match T.take t with + | Error `Closed -> Fmt.pr "%s: Stream was closed@." label + | Ok v -> Fmt.pr "%s: Took %s@." label v + | exception (Eio.Cancel.Cancelled _) -> Fmt.pr "%s: Take cancelled@." label + ) + |> Option.map (fun ctx -> + Fmt.pr "%s: Waiting for producer@." label; + ctx + ) +``` + +Initially there are no consumers or producers: + +```ocaml +# let t : string T.t = T.create ();; +val t : string T.t = +# show t;; +Sync (balance=0) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End +- : unit = () +``` + +Adding one consumer makes the balance go negative: + +```ocaml +# take t "cons1";; +cons1: Waiting for producer +- : Eio.Cancel.t option = Some + +# show t;; +Sync (balance=-1) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Slot (resume) + In_transition (suspend) + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End +- : unit = () +``` + +Sending a value wakes it: + +```ocaml +# put t "A";; +cons1: Took A +Sent A +- : Eio.Cancel.t option = None + +# show t;; +Sync (balance=0) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Finished + In_transition (suspend) (resume) + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End +- : unit = () +``` + +Trying to send a second value waits on the producers queue, setting the balance to 1: + +```ocaml +# put t "B";; +Waiting for a consumer for B +- : Eio.Cancel.t option = Some + +# show t;; +Sync (balance=1) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Finished + In_transition (suspend) (resume) + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Item (resume) + In_transition (suspend) + In_transition + In_transition + End +- : unit = () +``` + +Sending a third value must also wait: +```ocaml +# put t "C";; +Waiting for a consumer for C +- : Eio.Cancel.t option = Some + +# show t;; +Sync (balance=2) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Finished + In_transition (suspend) (resume) + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Item (resume) + Item + In_transition (suspend) + In_transition + End +- : unit = () +``` + +The next consumer reads the first value and wakes the first producer: +```ocaml +# take t "cons2";; +Sent B +cons2: Took B +- : Eio.Cancel.t option = None + +# show t;; +Sync (balance=1) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Finished + In_transition (suspend) (resume) + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Finished + Item (resume) + In_transition (suspend) + In_transition + End +- : unit = () +``` + +Finally, we collect the last value: +```ocaml +# take t "cons3";; +Sent C +cons3: Took C +- : Eio.Cancel.t option = None +``` + +## Cancellation + +Cancelling a consumer restores the balance: +```ocaml +# let t : string T.t = T.create ();; +val t : string T.t = +# let request = take t "cons1" |> Option.get;; +cons1: Waiting for producer +val request : Eio.Cancel.t = + +# show t;; +Sync (balance=-1) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Slot (resume) + In_transition (suspend) + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End +- : unit = () +``` + +```ocaml +# Fake_sched.cancel request;; +cons1: Take cancelled +- : unit = () + +# show t;; +Sync (balance=0) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=1): + Finished (resume) + In_transition (suspend) + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End +- : unit = () +``` + +Cancelling a producer restores the balance count: + +```ocaml +# let t : string T.t = T.create ();; +val t : string T.t = +# let a = put t "A" |> Option.get;; +Waiting for a consumer for A +val a : Eio.Cancel.t = +# put t "B" |> Option.get;; +Waiting for a consumer for B +- : Eio.Cancel.t = + +# show t;; +Sync (balance=2) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Item (resume) + Item + In_transition (suspend) + In_transition + End +- : unit = () + +# Fake_sched.cancel a;; +Send of A was cancelled +- : unit = () + +# show t;; +Sync (balance=1) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=1): + Finished (resume) + Item + In_transition (suspend) + In_transition + End +- : unit = () +``` + +The next consumer sees the second value: + +```ocaml +# take t "cons4";; +Sent B +cons4: Took B +- : Eio.Cancel.t option = None + +# show t;; +Sync (balance=0) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=1): + Finished + Finished + In_transition (suspend) (resume) + In_transition + End +- : unit = () +``` + +## Closing + +Closing cancels any waiting producers: + +```ocaml +# let t : string T.t = T.create ();; +val t : string T.t = + +# put t "A" |> Option.get;; +Waiting for a consumer for A +- : Eio.Cancel.t = + +# T.close t;; +Error adding A: Stream closed +- : unit = () + +# show t;; +Sync (balance=(closed)) + Consumers: + Segment 0 (prev=None, pointers=2, cancelled=0): + In_transition (suspend) (resume) + In_transition + In_transition + In_transition + End + Producers: + Segment 0 (prev=None, pointers=2, cancelled=0): + Finished + In_transition (suspend) (resume) + In_transition + In_transition + End +- : unit = () + +# put t "B";; +Error adding B: Stream closed +- : Eio.Cancel.t option = None +``` + +Closing cancels any waiting consumers: + +```ocaml +# let t : string T.t = T.create ();; +val t : string T.t = + +# take t "A";; +A: Waiting for producer +- : Eio.Cancel.t option = Some + +# T.close t;; +A: Stream was closed +- : unit = () + +# take t "B";; +B: Stream was closed +- : Eio.Cancel.t option = None + +# T.take_nonblocking t;; +- : (string, [> `Closed | `Would_block ]) result = Error `Closed +``` diff --git a/lib_eio/tests/trace.md b/lib_eio/tests/trace.md index 16f18f72b..28c51b626 100644 --- a/lib_eio/tests/trace.md +++ b/lib_eio/tests/trace.md @@ -1,50 +1,50 @@ -# Test unique ID generation - - -```ocaml -# #require "eio";; -# for _ = 1 to 5 do - Printf.printf "%d\n%!" (Eio.Private.Trace.mint_id () :> int) - done;; -1 -2 -3 -4 -5 -- : unit = () -``` - -A new domain gets a new chunk: - -```ocaml -# Domain.join @@ Domain.spawn - (fun () -> - for _ = 1 to 5 do - Printf.printf "%d\n%!" (Eio.Private.Trace.mint_id () :> int) - done);; -1024 -1025 -1026 -1027 -1028 -- : unit = () -``` - -When the original domain exhausts its chunk, it jumps to the next free chunk: - -```ocaml -# for _ = 1 to 1024 - 9 do - Eio.Private.Trace.mint_id () |> ignore - done;; -- : unit = () - -# for _ = 1 to 5 do - Printf.printf "%d\n%!" (Eio.Private.Trace.mint_id () :> int) - done;; -1021 -1022 -1023 -2048 -2049 -- : unit = () -``` +# Test unique ID generation + + +```ocaml +# #require "eio";; +# for _ = 1 to 5 do + Printf.printf "%d\n%!" (Eio.Private.Trace.mint_id () :> int) + done;; +1 +2 +3 +4 +5 +- : unit = () +``` + +A new domain gets a new chunk: + +```ocaml +# Domain.join @@ Domain.spawn + (fun () -> + for _ = 1 to 5 do + Printf.printf "%d\n%!" (Eio.Private.Trace.mint_id () :> int) + done);; +1024 +1025 +1026 +1027 +1028 +- : unit = () +``` + +When the original domain exhausts its chunk, it jumps to the next free chunk: + +```ocaml +# for _ = 1 to 1024 - 9 do + Eio.Private.Trace.mint_id () |> ignore + done;; +- : unit = () + +# for _ = 1 to 5 do + Printf.printf "%d\n%!" (Eio.Private.Trace.mint_id () :> int) + done;; +1021 +1022 +1023 +2048 +2049 +- : unit = () +``` diff --git a/lib_eio/time.ml b/lib_eio/time.ml index 9761e67dd..9d34afdde 100644 --- a/lib_eio/time.ml +++ b/lib_eio/time.ml @@ -1,108 +1,108 @@ -open Std - -exception Timeout - -type 'a clock_ty = [`Clock of 'a] -type 'a clock_base = 'a r constraint 'a = [> _ clock_ty] - -module Pi = struct - module type CLOCK = sig - type t - type time - val now : t -> time - val sleep_until : t -> time -> unit - end - - type (_, _, _) Resource.pi += - | Clock : ('t, (module CLOCK with type t = 't and type time = 'time), [> 'time clock_ty]) Resource.pi - - let clock (type t time) (module X : CLOCK with type t = t and type time = time) = - Resource.handler [ H (Clock, (module X)) ] -end - -type 'a clock = ([> float clock_ty] as 'a) r - -let now (type time) (t : [> time clock_ty] r) = - let Resource.T (t, ops) = t in - let module X = (val (Resource.get ops Pi.Clock)) in - X.now t - -let sleep_until (type time) (t : [> time clock_ty] r) time = - let Resource.T (t, ops) = t in - let module X = (val (Resource.get ops Pi.Clock)) in - X.sleep_until t time - -let sleep t d = sleep_until t (now t +. d) - -module Mono = struct - type ty = Mtime.t clock_ty - type 'a t = ([> ty] as 'a) r - - let now = now - let sleep_until = sleep_until - - let sleep_span t span = - match Mtime.add_span (now t) span with - | Some time -> sleep_until t time - | None -> Fiber.await_cancel () - - (* Converting floats via int64 is tricky when things overflow or go negative. - Since we don't need to wait for more than 100 years, limit it to this: *) - let too_many_ns = 0x8000000000000000. - - let span_of_s s = - if s >= 0.0 then ( - let ns = s *. 1e9 in - if ns >= too_many_ns then Mtime.Span.max_span - else Mtime.Span.of_uint64_ns (Int64.of_float ns) - ) else Mtime.Span.zero (* Also happens for NaN and negative infinity *) - - let sleep t s = - sleep_span t (span_of_s s) -end - -let with_timeout t d = Fiber.first (fun () -> sleep t d; Error `Timeout) -let with_timeout_exn t d = Fiber.first (fun () -> sleep t d; raise Timeout) - -module Timeout = struct - type t = - | Timeout of Mono.ty r * Mtime.Span.t - | Unlimited - - let none = Unlimited - let v clock time = Timeout ((clock :> Mono.ty r), time) - - let seconds clock time = - v clock (Mono.span_of_s time) - - let run t fn = - match t with - | Unlimited -> fn () - | Timeout (clock, d) -> - Fiber.first (fun () -> Mono.sleep_span clock d; Error `Timeout) fn - - let run_exn t fn = - match t with - | Unlimited -> fn () - | Timeout (clock, d) -> - Fiber.first (fun () -> Mono.sleep_span clock d; raise Timeout) fn - - let sleep t = - match t with - | Unlimited -> Fiber.await_cancel () - | Timeout (clock, d) -> Mono.sleep_span clock d - - let pp_duration f d = - if d >= 0.001 && d < 0.1 then - Fmt.pf f "%.2gms" (d *. 1000.) - else if d < 120. then - Fmt.pf f "%.2gs" d - else - Fmt.pf f "%.2gm" (d /. 60.) - - let pp f = function - | Unlimited -> Fmt.string f "(no timeout)" - | Timeout (_clock, d) -> - let d = Mtime.Span.to_float_ns d /. 1e9 in - pp_duration f d -end +open Std + +exception Timeout + +type 'a clock_ty = [`Clock of 'a] +type 'a clock_base = 'a r constraint 'a = [> _ clock_ty] + +module Pi = struct + module type CLOCK = sig + type t + type time + val now : t -> time + val sleep_until : t -> time -> unit + end + + type (_, _, _) Resource.pi += + | Clock : ('t, (module CLOCK with type t = 't and type time = 'time), [> 'time clock_ty]) Resource.pi + + let clock (type t time) (module X : CLOCK with type t = t and type time = time) = + Resource.handler [ H (Clock, (module X)) ] +end + +type 'a clock = ([> float clock_ty] as 'a) r + +let now (type time) (t : [> time clock_ty] r) = + let Resource.T (t, ops) = t in + let module X = (val (Resource.get ops Pi.Clock)) in + X.now t + +let sleep_until (type time) (t : [> time clock_ty] r) time = + let Resource.T (t, ops) = t in + let module X = (val (Resource.get ops Pi.Clock)) in + X.sleep_until t time + +let sleep t d = sleep_until t (now t +. d) + +module Mono = struct + type ty = Mtime.t clock_ty + type 'a t = ([> ty] as 'a) r + + let now = now + let sleep_until = sleep_until + + let sleep_span t span = + match Mtime.add_span (now t) span with + | Some time -> sleep_until t time + | None -> Fiber.await_cancel () + + (* Converting floats via int64 is tricky when things overflow or go negative. + Since we don't need to wait for more than 100 years, limit it to this: *) + let too_many_ns = 0x8000000000000000. + + let span_of_s s = + if s >= 0.0 then ( + let ns = s *. 1e9 in + if ns >= too_many_ns then Mtime.Span.max_span + else Mtime.Span.of_uint64_ns (Int64.of_float ns) + ) else Mtime.Span.zero (* Also happens for NaN and negative infinity *) + + let sleep t s = + sleep_span t (span_of_s s) +end + +let with_timeout t d = Fiber.first (fun () -> sleep t d; Error `Timeout) +let with_timeout_exn t d = Fiber.first (fun () -> sleep t d; raise Timeout) + +module Timeout = struct + type t = + | Timeout of Mono.ty r * Mtime.Span.t + | Unlimited + + let none = Unlimited + let v clock time = Timeout ((clock :> Mono.ty r), time) + + let seconds clock time = + v clock (Mono.span_of_s time) + + let run t fn = + match t with + | Unlimited -> fn () + | Timeout (clock, d) -> + Fiber.first (fun () -> Mono.sleep_span clock d; Error `Timeout) fn + + let run_exn t fn = + match t with + | Unlimited -> fn () + | Timeout (clock, d) -> + Fiber.first (fun () -> Mono.sleep_span clock d; raise Timeout) fn + + let sleep t = + match t with + | Unlimited -> Fiber.await_cancel () + | Timeout (clock, d) -> Mono.sleep_span clock d + + let pp_duration f d = + if d >= 0.001 && d < 0.1 then + Fmt.pf f "%.2gms" (d *. 1000.) + else if d < 120. then + Fmt.pf f "%.2gs" d + else + Fmt.pf f "%.2gm" (d /. 60.) + + let pp f = function + | Unlimited -> Fmt.string f "(no timeout)" + | Timeout (_clock, d) -> + let d = Mtime.Span.to_float_ns d /. 1e9 in + pp_duration f d +end diff --git a/lib_eio/time.mli b/lib_eio/time.mli index c418e6279..8b0490ae7 100644 --- a/lib_eio/time.mli +++ b/lib_eio/time.mli @@ -1,97 +1,97 @@ -open Std - -type 'a clock_ty = [`Clock of 'a] -type 'a clock_base = 'a r constraint 'a = [> _ clock_ty] - -type 'a clock = ([> float clock_ty] as 'a) r - -val now : _ clock -> float -(** [now t] is the current time since 00:00:00 GMT, Jan. 1, 1970 - in seconds - according to [t]. *) - -val sleep_until : _ clock -> float -> unit -(** [sleep_until t time] waits until the given time is reached. *) - -val sleep : _ clock -> float -> unit -(** [sleep t d] waits for [d] seconds. *) - -(** Monotonic clocks. *) -module Mono : sig - (** Monotonic clocks are unaffected by corrections to the real-time clock, - and so are a better choice for timeouts or measuring intervals, - where the absolute time doesn't matter. - - A monotonic clock may or may not include time while the computer is suspended. *) - - type ty = Mtime.t clock_ty - type 'a t = ([> ty] as 'a) r - - val now : _ t -> Mtime.t - (** [now t] is the current time according to [t]. *) - - val sleep_until : _ t -> Mtime.t -> unit - (** [sleep_until t time] waits until [time] before returning. *) - - val sleep : _ t -> float -> unit - (** [sleep t d] waits for [d] seconds. *) - - val sleep_span : _ t -> Mtime.span -> unit - (** [sleep_span t d] waits for duration [d]. *) -end - -(** {2 Timeouts} *) - -exception Timeout - -val with_timeout : _ clock -> float -> (unit -> ('a, 'e) result) -> ('a, [> `Timeout] as 'e) result -(** [with_timeout clock d fn] runs [fn ()] but cancels it after [d] seconds. *) - -val with_timeout_exn : _ clock -> float -> (unit -> 'a) -> 'a -(** [with_timeout_exn clock d fn] runs [fn ()] but cancels it after [d] seconds, - raising exception {!exception-Timeout}. *) - -(** Timeout values. *) -module Timeout : sig - type t - - val v : _ Mono.t -> Mtime.Span.t -> t - (** [v clock duration] is a timeout of [duration], as measured by [clock]. - Internally, this is just the tuple [(clock, duration)]. *) - - val seconds : _ Mono.t -> float -> t - (** [seconds clock duration] is a timeout of [duration] seconds, as measured by [clock]. *) - - val none : t - (** [none] is an infinite timeout. *) - - val run : t -> (unit -> ('a, 'e) result) -> ('a, [> `Timeout] as 'e) result - (** [run t fn] runs [fn ()] but cancels it if it takes longer than allowed by timeout [t]. *) - - val run_exn : t -> (unit -> 'a) -> 'a - (** [run_exn t fn] runs [fn ()] but cancels it if it takes longer than allowed by timeout [t], - raising exception {!exception-Timeout}. *) - - val sleep : t -> unit - (** [sleep t] sleeps for [t]'s duration. *) - - val pp : t Fmt.t - (** [pp] formats a timeout as a duration (e.g. "5s"). - This is intended for use in error messages and logging and is rounded. *) -end - -module Pi : sig - module type CLOCK = sig - type t - type time - - val now : t -> time - val sleep_until : t -> time -> unit - end - - type (_, _, _) Resource.pi += - Clock : ('t, (module CLOCK with type t = 't and type time = 'time), - [> 'time clock_ty ]) Resource.pi - - val clock : - (module CLOCK with type t = 't and type time = 'time) -> - ('t, [> 'time clock_ty]) Resource.handler -end +open Std + +type 'a clock_ty = [`Clock of 'a] +type 'a clock_base = 'a r constraint 'a = [> _ clock_ty] + +type 'a clock = ([> float clock_ty] as 'a) r + +val now : _ clock -> float +(** [now t] is the current time since 00:00:00 GMT, Jan. 1, 1970 - in seconds - according to [t]. *) + +val sleep_until : _ clock -> float -> unit +(** [sleep_until t time] waits until the given time is reached. *) + +val sleep : _ clock -> float -> unit +(** [sleep t d] waits for [d] seconds. *) + +(** Monotonic clocks. *) +module Mono : sig + (** Monotonic clocks are unaffected by corrections to the real-time clock, + and so are a better choice for timeouts or measuring intervals, + where the absolute time doesn't matter. + + A monotonic clock may or may not include time while the computer is suspended. *) + + type ty = Mtime.t clock_ty + type 'a t = ([> ty] as 'a) r + + val now : _ t -> Mtime.t + (** [now t] is the current time according to [t]. *) + + val sleep_until : _ t -> Mtime.t -> unit + (** [sleep_until t time] waits until [time] before returning. *) + + val sleep : _ t -> float -> unit + (** [sleep t d] waits for [d] seconds. *) + + val sleep_span : _ t -> Mtime.span -> unit + (** [sleep_span t d] waits for duration [d]. *) +end + +(** {2 Timeouts} *) + +exception Timeout + +val with_timeout : _ clock -> float -> (unit -> ('a, 'e) result) -> ('a, [> `Timeout] as 'e) result +(** [with_timeout clock d fn] runs [fn ()] but cancels it after [d] seconds. *) + +val with_timeout_exn : _ clock -> float -> (unit -> 'a) -> 'a +(** [with_timeout_exn clock d fn] runs [fn ()] but cancels it after [d] seconds, + raising exception {!exception-Timeout}. *) + +(** Timeout values. *) +module Timeout : sig + type t + + val v : _ Mono.t -> Mtime.Span.t -> t + (** [v clock duration] is a timeout of [duration], as measured by [clock]. + Internally, this is just the tuple [(clock, duration)]. *) + + val seconds : _ Mono.t -> float -> t + (** [seconds clock duration] is a timeout of [duration] seconds, as measured by [clock]. *) + + val none : t + (** [none] is an infinite timeout. *) + + val run : t -> (unit -> ('a, 'e) result) -> ('a, [> `Timeout] as 'e) result + (** [run t fn] runs [fn ()] but cancels it if it takes longer than allowed by timeout [t]. *) + + val run_exn : t -> (unit -> 'a) -> 'a + (** [run_exn t fn] runs [fn ()] but cancels it if it takes longer than allowed by timeout [t], + raising exception {!exception-Timeout}. *) + + val sleep : t -> unit + (** [sleep t] sleeps for [t]'s duration. *) + + val pp : t Fmt.t + (** [pp] formats a timeout as a duration (e.g. "5s"). + This is intended for use in error messages and logging and is rounded. *) +end + +module Pi : sig + module type CLOCK = sig + type t + type time + + val now : t -> time + val sleep_until : t -> time -> unit + end + + type (_, _, _) Resource.pi += + Clock : ('t, (module CLOCK with type t = 't and type time = 'time), + [> 'time clock_ty ]) Resource.pi + + val clock : + (module CLOCK with type t = 't and type time = 'time) -> + ('t, [> 'time clock_ty]) Resource.handler +end diff --git a/lib_eio/unix/cap.c b/lib_eio/unix/cap.c index cae6b6468..bade80447 100644 --- a/lib_eio/unix/cap.c +++ b/lib_eio/unix/cap.c @@ -1,27 +1,27 @@ -#include "primitives.h" - -#include -#include - -#ifdef __FreeBSD__ -# define HAVE_CAPSICUM -#endif - -#ifdef HAVE_CAPSICUM -# include -#endif - -#include -#include - -CAMLprim value eio_unix_cap_enter(value v_unit) { -#ifdef HAVE_CAPSICUM - int r = cap_enter(); - if (r == -1 && errno != ENOSYS) - caml_uerror("cap_enter", Nothing); - - return Val_bool(r == 0); -#else - return Val_bool(0); -#endif -} +#include "primitives.h" + +#include +#include + +#ifdef __FreeBSD__ +# define HAVE_CAPSICUM +#endif + +#ifdef HAVE_CAPSICUM +# include +#endif + +#include +#include + +CAMLprim value eio_unix_cap_enter(value v_unit) { +#ifdef HAVE_CAPSICUM + int r = cap_enter(); + if (r == -1 && errno != ENOSYS) + caml_uerror("cap_enter", Nothing); + + return Val_bool(r == 0); +#else + return Val_bool(0); +#endif +} diff --git a/lib_eio/unix/cap.ml b/lib_eio/unix/cap.ml index fbb7841f0..6cce6ab2e 100644 --- a/lib_eio/unix/cap.ml +++ b/lib_eio/unix/cap.ml @@ -1,5 +1,5 @@ -external eio_cap_enter : unit -> bool = "eio_unix_cap_enter" - -let enter () = - if eio_cap_enter () then Ok () - else Error `Not_supported +external eio_cap_enter : unit -> bool = "eio_unix_cap_enter" + +let enter () = + if eio_cap_enter () then Ok () + else Error `Not_supported diff --git a/lib_eio/unix/cap.mli b/lib_eio/unix/cap.mli index fd256c437..9f261ae3f 100644 --- a/lib_eio/unix/cap.mli +++ b/lib_eio/unix/cap.mli @@ -1,11 +1,11 @@ -val enter : unit -> (unit, [`Not_supported]) result -(** Call {{:https://man.freebsd.org/cgi/man.cgi?query=cap_enter}cap_enter}. - - Once in capability mode, access to global name spaces, such as file system - or IPC name spaces, is prevented by the operating system. A program can call - this after opening any directories, files or network sockets that it will need, - to prevent accidental access to other resources. - - The standard environment directories {!Eio.Stdenv.fs} and {!Eio.Stdenv.cwd} cannot - be used after calling this, but directories opened from them via {!Eio.Path.with_open_dir} - will continue to work. *) +val enter : unit -> (unit, [`Not_supported]) result +(** Call {{:https://man.freebsd.org/cgi/man.cgi?query=cap_enter}cap_enter}. + + Once in capability mode, access to global name spaces, such as file system + or IPC name spaces, is prevented by the operating system. A program can call + this after opening any directories, files or network sockets that it will need, + to prevent accidental access to other resources. + + The standard environment directories {!Eio.Stdenv.fs} and {!Eio.Stdenv.cwd} cannot + be used after calling this, but directories opened from them via {!Eio.Path.with_open_dir} + will continue to work. *) diff --git a/lib_eio/unix/dune b/lib_eio/unix/dune index d067e815c..b089a37d7 100644 --- a/lib_eio/unix/dune +++ b/lib_eio/unix/dune @@ -1,25 +1,25 @@ -(library - (name eio_unix) - (public_name eio.unix) - (foreign_stubs - (language c) - (include_dirs include) - (names fork_action stubs cap)) - (libraries eio eio.utils unix threads mtime.clock.os)) - -(rule - (enabled_if %{bin-available:lintcstubs_arity_cmt}) - (action - (with-stdout-to - primitives.h.new - (run %{bin:lintcstubs_arity_cmt} - %{dep:.eio_unix.objs/byte/eio_unix__Fd.cmt} - %{dep:.eio_unix.objs/byte/eio_unix__Private.cmt} - %{dep:.eio_unix.objs/byte/eio_unix__Cap.cmt} - %{dep:.eio_unix.objs/byte/eio_unix__Fork_action.cmt})))) - -(rule - (enabled_if %{bin-available:lintcstubs_arity_cmt}) - (alias runtest) - (action - (diff primitives.h primitives.h.new))) +(library + (name eio_unix) + (public_name eio.unix) + (foreign_stubs + (language c) + (include_dirs include) + (names fork_action stubs cap)) + (libraries eio eio.utils unix threads mtime.clock.os)) + +(rule + (enabled_if %{bin-available:lintcstubs_arity_cmt}) + (action + (with-stdout-to + primitives.h.new + (run %{bin:lintcstubs_arity_cmt} + %{dep:.eio_unix.objs/byte/eio_unix__Fd.cmt} + %{dep:.eio_unix.objs/byte/eio_unix__Private.cmt} + %{dep:.eio_unix.objs/byte/eio_unix__Cap.cmt} + %{dep:.eio_unix.objs/byte/eio_unix__Fork_action.cmt})))) + +(rule + (enabled_if %{bin-available:lintcstubs_arity_cmt}) + (alias runtest) + (action + (diff primitives.h primitives.h.new))) diff --git a/lib_eio/unix/eio_unix.ml b/lib_eio/unix/eio_unix.ml index 14f818193..32b2efaf5 100644 --- a/lib_eio/unix/eio_unix.ml +++ b/lib_eio/unix/eio_unix.ml @@ -1,50 +1,50 @@ -[@@@alert "-unstable"] - -open Eio.Std - -module Fd = Fd -module Resource = Resource -module Private = Private - -include Types - -let await_readable = Private.await_readable -let await_writable = Private.await_writable -let pipe = Private.pipe - -type Eio.Exn.Backend.t += Unix_error of Unix.error * string * string -let () = - Eio.Exn.Backend.register_pp (fun f -> function - | Unix_error (code, name, arg) -> Fmt.pf f "Unix_error (%s, %S, %S)" (Unix.error_message code) name arg; true - | _ -> false - ) - -let sleep d = - Eio.Time.Mono.sleep (Effect.perform Private.Get_monotonic_clock) d - -let run_in_systhread = Thread_pool.run_in_systhread - -module Ipaddr = Net.Ipaddr - -module Process = Process -module Net = Net -module Cap = Cap -module Pi = Pi - -module Stdenv = struct - type base = < - stdin : source_ty r; - stdout : sink_ty r; - stderr : sink_ty r; - net : [`Unix | `Generic] Eio.Net.ty r; - domain_mgr : Eio.Domain_manager.ty r; - process_mgr : Process.mgr_ty r; - clock : float Eio.Time.clock_ty r; - mono_clock : Eio.Time.Mono.ty r; - fs : Eio.Fs.dir_ty Eio.Path.t; - cwd : Eio.Fs.dir_ty Eio.Path.t; - secure_random : Eio.Flow.source_ty r; - debug : Eio.Debug.t; - backend_id: string; - > -end +[@@@alert "-unstable"] + +open Eio.Std + +module Fd = Fd +module Resource = Resource +module Private = Private + +include Types + +let await_readable = Private.await_readable +let await_writable = Private.await_writable +let pipe = Private.pipe + +type Eio.Exn.Backend.t += Unix_error of Unix.error * string * string +let () = + Eio.Exn.Backend.register_pp (fun f -> function + | Unix_error (code, name, arg) -> Fmt.pf f "Unix_error (%s, %S, %S)" (Unix.error_message code) name arg; true + | _ -> false + ) + +let sleep d = + Eio.Time.Mono.sleep (Effect.perform Private.Get_monotonic_clock) d + +let run_in_systhread = Thread_pool.run_in_systhread + +module Ipaddr = Net.Ipaddr + +module Process = Process +module Net = Net +module Cap = Cap +module Pi = Pi + +module Stdenv = struct + type base = < + stdin : source_ty r; + stdout : sink_ty r; + stderr : sink_ty r; + net : [`Unix | `Generic] Eio.Net.ty r; + domain_mgr : Eio.Domain_manager.ty r; + process_mgr : Process.mgr_ty r; + clock : float Eio.Time.clock_ty r; + mono_clock : Eio.Time.Mono.ty r; + fs : Eio.Fs.dir_ty Eio.Path.t; + cwd : Eio.Fs.dir_ty Eio.Path.t; + secure_random : Eio.Flow.source_ty r; + debug : Eio.Debug.t; + backend_id: string; + > +end diff --git a/lib_eio/unix/eio_unix.mli b/lib_eio/unix/eio_unix.mli index 774ba5f6b..ca3e413d5 100644 --- a/lib_eio/unix/eio_unix.mli +++ b/lib_eio/unix/eio_unix.mli @@ -1,112 +1,112 @@ -(** Extension of {!Eio} for integration with OCaml's [Unix] module. - - Note that OCaml's [Unix] module is not safe, and therefore care must be taken when using these functions. - For example, it is possible to leak file descriptors this way, or to use them after they've been closed, - allowing one module to corrupt a file belonging to an unrelated module. *) - -[@@@alert "-unstable"] - -open Eio.Std - -type Eio.Exn.Backend.t += Unix_error of Unix.error * string * string -(** Wrapper for embedding {!Unix.Unix_error} errors. *) - -module Fd = Fd -(** A safe wrapper for {!Unix.file_descr}. *) - -(** Eio resources backed by an OS file descriptor. *) -module Resource : sig - type 'a t = ([> `Unix_fd] as 'a) Eio.Resource.t - (** Resources that have FDs are tagged with [`Unix_fd]. *) - - type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi - - val fd : _ t -> Fd.t - (** [fd t] returns the FD being wrapped by a resource. *) - - val fd_opt : _ Eio.Resource.t -> Fd.t option - (** [fd_opt t] returns the FD being wrapped by a generic resource, if any. - - This just probes [t] using {!extension-FD}. *) -end - -module Net = Net -(** Extended network API with support for file descriptors. *) - -type source_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.source_ty] -type sink_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.sink_ty] -type 'a source = ([> source_ty] as 'a) r -type 'a sink = ([> sink_ty] as 'a) r - -val await_readable : Unix.file_descr -> unit -(** [await_readable fd] blocks until [fd] is readable (or has an error). *) - -val await_writable : Unix.file_descr -> unit -(** [await_writable fd] blocks until [fd] is writable (or has an error). *) - -val sleep : float -> unit -(** [sleep d] sleeps for [d] seconds, allowing other fibers to run. - This is can be useful for debugging (e.g. to introduce delays to trigger a race condition) - without having to plumb {!Eio.Stdenv.mono_clock} through your code. - It can also be used in programs that don't care about tracking determinism. *) - -val run_in_systhread : ?label:string -> (unit -> 'a) -> 'a -(** [run_in_systhread fn] runs the function [fn] using a pool of system threads ({! Thread.t}). - - This pool creates a new system thread if all threads are busy, it does not wait. - [run_in_systhread] allows blocking calls to be made non-blocking. - - @param label The operation name to use in trace output. *) - -val pipe : Switch.t -> source_ty r * sink_ty r -(** [pipe sw] returns a connected pair of flows [src] and [sink]. Data written to [sink] - can be read from [src]. - Note that, like all FDs created by Eio, they are both marked as close-on-exec by default. *) - -module Process = Process -(** Spawning child processes with extra control. *) - -module Cap = Cap -(** Capsicum security. *) - -(** The set of resources provided to a process on a Unix-compatible system. *) -module Stdenv : sig - type base = < - stdin : source_ty r; - stdout : sink_ty r; - stderr : sink_ty r; - net : [`Unix | `Generic] Eio.Net.ty r; - domain_mgr : Eio.Domain_manager.ty r; - process_mgr : Process.mgr_ty r; - clock : float Eio.Time.clock_ty r; - mono_clock : Eio.Time.Mono.ty r; - fs : Eio.Fs.dir_ty Eio.Path.t; - cwd : Eio.Fs.dir_ty Eio.Path.t; - secure_random : Eio.Flow.source_ty r; - debug : Eio.Debug.t; - backend_id : string; - > - (** The common set of features provided by all traditional operating systems (BSDs, Linux, Mac, Windows). - - You can use the functions in {!Eio.Stdenv} to access these fields if you prefer. *) -end - -(** API for Eio backends only. *) -module Private : sig - type _ Effect.t += - | Await_readable : Unix.file_descr -> unit Effect.t (** See {!await_readable} *) - | Await_writable : Unix.file_descr -> unit Effect.t (** See {!await_writable} *) - | Get_monotonic_clock : Eio.Time.Mono.ty r Effect.t - | Pipe : Eio.Switch.t -> (source_ty r * sink_ty r) Effect.t (** See {!pipe} *) - - module Rcfd = Rcfd - - module Fork_action = Fork_action - - module Thread_pool = Thread_pool - - val read_link : Fd.t option -> string -> string - val read_link_unix : Unix.file_descr option -> string -> string -end - -module Pi = Pi +(** Extension of {!Eio} for integration with OCaml's [Unix] module. + + Note that OCaml's [Unix] module is not safe, and therefore care must be taken when using these functions. + For example, it is possible to leak file descriptors this way, or to use them after they've been closed, + allowing one module to corrupt a file belonging to an unrelated module. *) + +[@@@alert "-unstable"] + +open Eio.Std + +type Eio.Exn.Backend.t += Unix_error of Unix.error * string * string +(** Wrapper for embedding {!Unix.Unix_error} errors. *) + +module Fd = Fd +(** A safe wrapper for {!Unix.file_descr}. *) + +(** Eio resources backed by an OS file descriptor. *) +module Resource : sig + type 'a t = ([> `Unix_fd] as 'a) Eio.Resource.t + (** Resources that have FDs are tagged with [`Unix_fd]. *) + + type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi + + val fd : _ t -> Fd.t + (** [fd t] returns the FD being wrapped by a resource. *) + + val fd_opt : _ Eio.Resource.t -> Fd.t option + (** [fd_opt t] returns the FD being wrapped by a generic resource, if any. + + This just probes [t] using {!extension-FD}. *) +end + +module Net = Net +(** Extended network API with support for file descriptors. *) + +type source_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.source_ty] +type sink_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.sink_ty] +type 'a source = ([> source_ty] as 'a) r +type 'a sink = ([> sink_ty] as 'a) r + +val await_readable : Unix.file_descr -> unit +(** [await_readable fd] blocks until [fd] is readable (or has an error). *) + +val await_writable : Unix.file_descr -> unit +(** [await_writable fd] blocks until [fd] is writable (or has an error). *) + +val sleep : float -> unit +(** [sleep d] sleeps for [d] seconds, allowing other fibers to run. + This is can be useful for debugging (e.g. to introduce delays to trigger a race condition) + without having to plumb {!Eio.Stdenv.mono_clock} through your code. + It can also be used in programs that don't care about tracking determinism. *) + +val run_in_systhread : ?label:string -> (unit -> 'a) -> 'a +(** [run_in_systhread fn] runs the function [fn] using a pool of system threads ({! Thread.t}). + + This pool creates a new system thread if all threads are busy, it does not wait. + [run_in_systhread] allows blocking calls to be made non-blocking. + + @param label The operation name to use in trace output. *) + +val pipe : Switch.t -> source_ty r * sink_ty r +(** [pipe sw] returns a connected pair of flows [src] and [sink]. Data written to [sink] + can be read from [src]. + Note that, like all FDs created by Eio, they are both marked as close-on-exec by default. *) + +module Process = Process +(** Spawning child processes with extra control. *) + +module Cap = Cap +(** Capsicum security. *) + +(** The set of resources provided to a process on a Unix-compatible system. *) +module Stdenv : sig + type base = < + stdin : source_ty r; + stdout : sink_ty r; + stderr : sink_ty r; + net : [`Unix | `Generic] Eio.Net.ty r; + domain_mgr : Eio.Domain_manager.ty r; + process_mgr : Process.mgr_ty r; + clock : float Eio.Time.clock_ty r; + mono_clock : Eio.Time.Mono.ty r; + fs : Eio.Fs.dir_ty Eio.Path.t; + cwd : Eio.Fs.dir_ty Eio.Path.t; + secure_random : Eio.Flow.source_ty r; + debug : Eio.Debug.t; + backend_id : string; + > + (** The common set of features provided by all traditional operating systems (BSDs, Linux, Mac, Windows). + + You can use the functions in {!Eio.Stdenv} to access these fields if you prefer. *) +end + +(** API for Eio backends only. *) +module Private : sig + type _ Effect.t += + | Await_readable : Unix.file_descr -> unit Effect.t (** See {!await_readable} *) + | Await_writable : Unix.file_descr -> unit Effect.t (** See {!await_writable} *) + | Get_monotonic_clock : Eio.Time.Mono.ty r Effect.t + | Pipe : Eio.Switch.t -> (source_ty r * sink_ty r) Effect.t (** See {!pipe} *) + + module Rcfd = Rcfd + + module Fork_action = Fork_action + + module Thread_pool = Thread_pool + + val read_link : Fd.t option -> string -> string + val read_link_unix : Unix.file_descr option -> string -> string +end + +module Pi = Pi diff --git a/lib_eio/unix/fd.ml b/lib_eio/unix/fd.ml index 56c9bd5c7..fa80457c0 100644 --- a/lib_eio/unix/fd.ml +++ b/lib_eio/unix/fd.ml @@ -1,99 +1,99 @@ -open Eio.Std - -type tristate = No | Yes | Unknown - -(* Note: [blocking] and [seekable] are not atomic, - but it doesn't matter if we query twice in rare cases. *) -type t = { - fd : Rcfd.t; - mutable blocking : tristate; - mutable seekable : tristate; - close_unix : bool; (* Whether closing this also closes the underlying FD. *) - mutable release_hook : Eio.Switch.hook; (* Use this on close to remove switch's [on_release] hook. *) -} - -let err_closed op = Invalid_argument (op ^ ": file descriptor used after calling close!") - -let use t f ~if_closed = Rcfd.use t.fd f ~if_closed - -let use_exn op t f = - Rcfd.use t.fd f ~if_closed:(fun () -> raise (err_closed op)) - -let close t = - Switch.remove_hook t.release_hook; - if t.close_unix then ( - ignore (Rcfd.close t.fd : bool) - ) else ( - ignore (Rcfd.remove t.fd : Unix.file_descr option) - ) - -let remove t = - Switch.remove_hook t.release_hook; - Rcfd.remove t.fd - -let tristate_of_bool_opt = function - | None -> Unknown - | Some true -> Yes - | Some false -> No - -let of_unix_no_hook ?(close_unix=true) ?blocking ?seekable fd = - let seekable = tristate_of_bool_opt seekable in - let blocking = tristate_of_bool_opt blocking in - { fd = Rcfd.make fd; blocking; seekable; close_unix; release_hook = Switch.null_hook } - -let of_unix ~sw ?blocking ?seekable ~close_unix fd = - let t = of_unix_no_hook ?blocking ?seekable ~close_unix fd in - t.release_hook <- Switch.on_release_cancellable sw (fun () -> close t); - t - -let of_unix_list ~sw fds = - match Switch.get_error sw with - | Some e -> List.iter Unix.close fds; raise e - | None -> List.map (of_unix ~sw ~close_unix:true) fds - -external eio_is_blocking : Unix.file_descr -> bool = "eio_unix_is_blocking" - -let is_blocking t = - match t.blocking with - | No -> false - | Yes -> true - | Unknown -> - use t ~if_closed:(Fun.const false) @@ fun fd -> - let blocking = eio_is_blocking fd in - t.blocking <- if blocking then Yes else No; - blocking - -let is_seekable t = - match t.seekable with - | No -> false - | Yes -> true - | Unknown -> - use t ~if_closed:(Fun.const false) @@ fun fd -> - let seekable = - match Unix.lseek fd 0 Unix.SEEK_CUR with - | (_ : int) -> true - | exception Unix.Unix_error (Unix.ESPIPE, "lseek", "") -> false - in - t.seekable <- if seekable then Yes else No; - seekable - -let is_open t = Rcfd.is_open t.fd - -let rec use_exn_list op xs k = - match xs with - | [] -> k [] - | x :: xs -> - use_exn op x @@ fun x -> - use_exn_list op xs @@ fun xs -> - k (x :: xs) - -let use_exn_opt op x f = - match x with - | None -> f None - | Some x -> use_exn op x (fun x -> f (Some x)) - -let stdin = of_unix_no_hook Unix.stdin -let stdout = of_unix_no_hook Unix.stdout -let stderr= of_unix_no_hook Unix.stderr - -let pp f t = Rcfd.pp f t.fd +open Eio.Std + +type tristate = No | Yes | Unknown + +(* Note: [blocking] and [seekable] are not atomic, + but it doesn't matter if we query twice in rare cases. *) +type t = { + fd : Rcfd.t; + mutable blocking : tristate; + mutable seekable : tristate; + close_unix : bool; (* Whether closing this also closes the underlying FD. *) + mutable release_hook : Eio.Switch.hook; (* Use this on close to remove switch's [on_release] hook. *) +} + +let err_closed op = Invalid_argument (op ^ ": file descriptor used after calling close!") + +let use t f ~if_closed = Rcfd.use t.fd f ~if_closed + +let use_exn op t f = + Rcfd.use t.fd f ~if_closed:(fun () -> raise (err_closed op)) + +let close t = + Switch.remove_hook t.release_hook; + if t.close_unix then ( + ignore (Rcfd.close t.fd : bool) + ) else ( + ignore (Rcfd.remove t.fd : Unix.file_descr option) + ) + +let remove t = + Switch.remove_hook t.release_hook; + Rcfd.remove t.fd + +let tristate_of_bool_opt = function + | None -> Unknown + | Some true -> Yes + | Some false -> No + +let of_unix_no_hook ?(close_unix=true) ?blocking ?seekable fd = + let seekable = tristate_of_bool_opt seekable in + let blocking = tristate_of_bool_opt blocking in + { fd = Rcfd.make fd; blocking; seekable; close_unix; release_hook = Switch.null_hook } + +let of_unix ~sw ?blocking ?seekable ~close_unix fd = + let t = of_unix_no_hook ?blocking ?seekable ~close_unix fd in + t.release_hook <- Switch.on_release_cancellable sw (fun () -> close t); + t + +let of_unix_list ~sw fds = + match Switch.get_error sw with + | Some e -> List.iter Unix.close fds; raise e + | None -> List.map (of_unix ~sw ~close_unix:true) fds + +external eio_is_blocking : Unix.file_descr -> bool = "eio_unix_is_blocking" + +let is_blocking t = + match t.blocking with + | No -> false + | Yes -> true + | Unknown -> + use t ~if_closed:(Fun.const false) @@ fun fd -> + let blocking = eio_is_blocking fd in + t.blocking <- if blocking then Yes else No; + blocking + +let is_seekable t = + match t.seekable with + | No -> false + | Yes -> true + | Unknown -> + use t ~if_closed:(Fun.const false) @@ fun fd -> + let seekable = + match Unix.lseek fd 0 Unix.SEEK_CUR with + | (_ : int) -> true + | exception Unix.Unix_error (Unix.ESPIPE, "lseek", "") -> false + in + t.seekable <- if seekable then Yes else No; + seekable + +let is_open t = Rcfd.is_open t.fd + +let rec use_exn_list op xs k = + match xs with + | [] -> k [] + | x :: xs -> + use_exn op x @@ fun x -> + use_exn_list op xs @@ fun xs -> + k (x :: xs) + +let use_exn_opt op x f = + match x with + | None -> f None + | Some x -> use_exn op x (fun x -> f (Some x)) + +let stdin = of_unix_no_hook Unix.stdin +let stdout = of_unix_no_hook Unix.stdout +let stderr= of_unix_no_hook Unix.stderr + +let pp f t = Rcfd.pp f t.fd diff --git a/lib_eio/unix/fd.mli b/lib_eio/unix/fd.mli index f12e6c03e..b683405ba 100644 --- a/lib_eio/unix/fd.mli +++ b/lib_eio/unix/fd.mli @@ -1,88 +1,88 @@ -open Eio.Std - -type t -(** A wrapper around a {!Unix.file_descr}. *) - -(** {2 Creation} *) - -val of_unix : sw:Switch.t -> ?blocking:bool -> ?seekable:bool -> close_unix:bool -> Unix.file_descr -> t -(** [of_unix ~sw ~close_unix fd] wraps [fd]. - - @param sw Close [fd] automatically when [sw] is finished. - @param blocking Indicates whether [fd] is in blocking mode. - If not given, [fd] is probed for its blocking state if needed. - @param seekable The value to be returned by {!is_seekable}. Defaults to probing if needed. - @param close_unix Whether {!close} also closes [fd] (this should normally be [true]). *) - -val of_unix_list : sw:Switch.t -> Unix.file_descr list -> t list -(** [of_unix_list ~sw fds] is like [List.map (of_unix ~sw ~close_unix:true) fds], - except that if [sw] is off then it closes all the FDs. *) - -(** {2 Using FDs} *) - -val use : t -> (Unix.file_descr -> 'a) -> if_closed:(unit -> 'a) -> 'a -(** [use t fn ~if_closed] calls [fn wrapped_fd], ensuring that [wrapped_fd] will not be closed - before [fn] returns. - - If [t] is already closed, it returns [if_closed ()] instead. *) - -val use_exn : string -> t -> (Unix.file_descr -> 'a) -> 'a -(** [use_exn op t fn] calls [fn wrapped_fd], ensuring that [wrapped_fd] will not be closed - before [fn] returns. - - If [t] is already closed, it raises an exception, using [op] as the name of the failing operation. *) - -val use_exn_list : string -> t list -> (Unix.file_descr list -> 'a) -> 'a -(** [use_exn_list op fds fn] calls {!use_exn} on each FD in [fds], calling [fn wrapped_fds] on the results. *) - -val use_exn_opt : string -> t option -> (Unix.file_descr option -> 'a) -> 'a -(** [use_exn_opt op fd fn] is like {!use_exn}, but if [fd = None] then it just calls [fn None]. *) - -(** {2 Closing} *) - -val close : t -> unit -(** [close t] marks [t] as closed, so that {!use} can no longer be used to start new operations. - - The wrapped FD will be closed once all current users of the FD have finished (unless [close_unix = false]). - - Has no effect if [t] is already closed. *) - -val remove : t -> Unix.file_descr option -(** [remove t] marks [t] as closed, so that {!use} can no longer be used to start new operations. - - It then waits for all current users of the wrapped FD to finish using it, and then returns the FD. - - This operation suspends the calling fiber and so must run from an Eio fiber. - It does not allow itself to be cancelled, - since it takes ownership of the FD and that would be leaked if it aborted. - - Returns [None] if [t] is closed by another fiber first. *) - -val is_open : t -> bool -(** [is_open t] returns [true] until [t] has been marked as closing, after which it returns [false]. - - This is mostly useful inside the callback of {!use}, to test whether - another fiber has started closing [t] (in which case you may decide to stop early). *) - -(** {2 Flags} *) - -val is_blocking : t -> bool -(** [is_blocking t] returns the value of [blocking] passed to {!of_unix}. - - If not known, it first probes for it (and if the FD is already closed, returns [false]). *) - -val is_seekable : t -> bool -(** [is_seekable t] returns the value of [seekable] passed to {!of_unix}. - - If not known, it first probes for it (and if the FD is already closed, returns [false]). *) - -(** {2 Standard FDs} *) - -val stdin : t -val stdout : t -val stderr : t - -(** {2 Printing} *) - -val pp : t Fmt.t -(** Displays the FD number. *) +open Eio.Std + +type t +(** A wrapper around a {!Unix.file_descr}. *) + +(** {2 Creation} *) + +val of_unix : sw:Switch.t -> ?blocking:bool -> ?seekable:bool -> close_unix:bool -> Unix.file_descr -> t +(** [of_unix ~sw ~close_unix fd] wraps [fd]. + + @param sw Close [fd] automatically when [sw] is finished. + @param blocking Indicates whether [fd] is in blocking mode. + If not given, [fd] is probed for its blocking state if needed. + @param seekable The value to be returned by {!is_seekable}. Defaults to probing if needed. + @param close_unix Whether {!close} also closes [fd] (this should normally be [true]). *) + +val of_unix_list : sw:Switch.t -> Unix.file_descr list -> t list +(** [of_unix_list ~sw fds] is like [List.map (of_unix ~sw ~close_unix:true) fds], + except that if [sw] is off then it closes all the FDs. *) + +(** {2 Using FDs} *) + +val use : t -> (Unix.file_descr -> 'a) -> if_closed:(unit -> 'a) -> 'a +(** [use t fn ~if_closed] calls [fn wrapped_fd], ensuring that [wrapped_fd] will not be closed + before [fn] returns. + + If [t] is already closed, it returns [if_closed ()] instead. *) + +val use_exn : string -> t -> (Unix.file_descr -> 'a) -> 'a +(** [use_exn op t fn] calls [fn wrapped_fd], ensuring that [wrapped_fd] will not be closed + before [fn] returns. + + If [t] is already closed, it raises an exception, using [op] as the name of the failing operation. *) + +val use_exn_list : string -> t list -> (Unix.file_descr list -> 'a) -> 'a +(** [use_exn_list op fds fn] calls {!use_exn} on each FD in [fds], calling [fn wrapped_fds] on the results. *) + +val use_exn_opt : string -> t option -> (Unix.file_descr option -> 'a) -> 'a +(** [use_exn_opt op fd fn] is like {!use_exn}, but if [fd = None] then it just calls [fn None]. *) + +(** {2 Closing} *) + +val close : t -> unit +(** [close t] marks [t] as closed, so that {!use} can no longer be used to start new operations. + + The wrapped FD will be closed once all current users of the FD have finished (unless [close_unix = false]). + + Has no effect if [t] is already closed. *) + +val remove : t -> Unix.file_descr option +(** [remove t] marks [t] as closed, so that {!use} can no longer be used to start new operations. + + It then waits for all current users of the wrapped FD to finish using it, and then returns the FD. + + This operation suspends the calling fiber and so must run from an Eio fiber. + It does not allow itself to be cancelled, + since it takes ownership of the FD and that would be leaked if it aborted. + + Returns [None] if [t] is closed by another fiber first. *) + +val is_open : t -> bool +(** [is_open t] returns [true] until [t] has been marked as closing, after which it returns [false]. + + This is mostly useful inside the callback of {!use}, to test whether + another fiber has started closing [t] (in which case you may decide to stop early). *) + +(** {2 Flags} *) + +val is_blocking : t -> bool +(** [is_blocking t] returns the value of [blocking] passed to {!of_unix}. + + If not known, it first probes for it (and if the FD is already closed, returns [false]). *) + +val is_seekable : t -> bool +(** [is_seekable t] returns the value of [seekable] passed to {!of_unix}. + + If not known, it first probes for it (and if the FD is already closed, returns [false]). *) + +(** {2 Standard FDs} *) + +val stdin : t +val stdout : t +val stderr : t + +(** {2 Printing} *) + +val pp : t Fmt.t +(** Displays the FD number. *) diff --git a/lib_eio/unix/fork_action.c b/lib_eio/unix/fork_action.c index 170b0c299..54acc7b5d 100644 --- a/lib_eio/unix/fork_action.c +++ b/lib_eio/unix/fork_action.c @@ -1,239 +1,239 @@ -/* Note: fork actions MUST NOT allocate (either on the OCaml heap or with C malloc). - * This is because e.g. we might have forked while another thread in the parent had a lock. - * In the child, we inherit a copy of the locked mutex, but no corresponding thread to - * release it. - */ - -#include "primitives.h" - -#include -#include -#include -#include -#include - -#include -#include -#include -#include -#include - -#include "fork_action.h" - -#ifndef _WIN32 -void eio_unix_run_fork_actions(int errors, value v_actions) { - int old_flags = fcntl(errors, F_GETFL, 0); - fcntl(errors, F_SETFL, old_flags & ~O_NONBLOCK); - while (Is_block(v_actions)) { - value v_action = Field(v_actions, 0); - fork_fn *action = (fork_fn *) Nativeint_val(Field(v_action, 0)); - action(errors, v_action); - v_actions = Field(v_actions, 1); - } - _exit(1); -} -#endif - -static void try_write_all(int fd, char *buf) { - int len = strlen(buf); - while (len > 0) { - int wrote = write(fd, buf, len); - - if (wrote <= 0) - return; - - buf += wrote; - len -= wrote; - } -} - -void eio_unix_fork_error(int fd, char *fn, char *buf) { - try_write_all(fd, fn); - try_write_all(fd, ": "); - try_write_all(fd, buf); -} - -#define String_array_val(v) *((char ***)Data_custom_val(v)) - -static void finalize_string_array(value v) { - free(String_array_val(v)); - String_array_val(v) = NULL; -} - -static struct custom_operations string_array_ops = { - "string.array", - finalize_string_array, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default, - custom_compare_ext_default, - custom_fixed_length_default -}; - -CAMLprim value eio_unix_make_string_array(value v_len) { - CAMLparam0(); - CAMLlocal1(v_str_array); - int n = Int_val(v_len); - uintnat total; - - if (caml_umul_overflow(sizeof(char *), n + 1, &total)) - caml_raise_out_of_memory(); - - v_str_array = caml_alloc_custom_mem(&string_array_ops, sizeof(char ***), total); - - char **c = calloc(sizeof(char *), n + 1); - String_array_val(v_str_array) = c; - if (!c) - caml_raise_out_of_memory(); - - CAMLreturn(v_str_array); -} - -static void fill_string_array(char **c, value v_ocaml_array) { - int n = Wosize_val(v_ocaml_array); - - for (int i = 0; i < n; i++) { - c[i] = (char *) String_val(Field(v_ocaml_array, i)); - } - - c[n] = NULL; -} - -static void action_execve(int errors, value v_config) { - value v_exe = Field(v_config, 1); - char **argv = String_array_val(Field(v_config, 2)); - char **envp = String_array_val(Field(v_config, 4)); - - fill_string_array(argv, Field(v_config, 3)); - fill_string_array(envp, Field(v_config, 5)); - - execve(String_val(v_exe), argv, envp); - eio_unix_fork_error(errors, "execve", strerror(errno)); - _exit(1); -} - -CAMLprim value eio_unix_fork_execve(value v_unit) { - return Val_fork_fn(action_execve); -} - -static void action_fchdir(int errors, value v_config) { - #ifdef _WIN32 - eio_unix_fork_error(errors, "action_fchdir", "Unsupported operation on windows"); - #else - value v_fd = Field(v_config, 1); - int r; - r = fchdir(Int_val(v_fd)); - if (r != 0) { - eio_unix_fork_error(errors, "fchdir", strerror(errno)); - _exit(1); - } - #endif -} - -CAMLprim value eio_unix_fork_fchdir(value v_unit) { - return Val_fork_fn(action_fchdir); -} - -static void action_chdir(int errors, value v_config) { - value v_path = Field(v_config, 1); - int r; - r = chdir(String_val(v_path)); - if (r != 0) { - eio_unix_fork_error(errors, "chdir", strerror(errno)); - _exit(1); - } -} - -CAMLprim value eio_unix_fork_chdir(value v_unit) { - return Val_fork_fn(action_chdir); -} - -static void set_blocking(int errors, int fd, int blocking) { - #ifdef _WIN32 - eio_unix_fork_error(errors, "set_blocking", "Unsupported operation on windows"); - #else - int r = fcntl(fd, F_GETFL, 0); - if (r != -1) { - int flags = blocking - ? r & ~O_NONBLOCK - : r | O_NONBLOCK; - if (r != flags) { - r = fcntl(fd, F_SETFL, flags); - } - } - if (r == -1) { - eio_unix_fork_error(errors, "fcntl", strerror(errno)); - _exit(1); - } - #endif -} - -static void set_cloexec(int errors, int fd, int cloexec) { - #ifdef _WIN32 - eio_unix_fork_error(errors, "set_cloexec", "Unsupported operation on windows"); - #else - int r = fcntl(fd, F_GETFD, 0); - if (r != -1) { - int flags = cloexec - ? r | FD_CLOEXEC - : r & ~FD_CLOEXEC; - if (r != flags) { - r = fcntl(fd, F_SETFD, flags); - } - } - if (r == -1) { - eio_unix_fork_error(errors, "fcntl", strerror(errno)); - _exit(1); - } - #endif -} - -static void action_dups(int errors, value v_config) { - value v_plan = Field(v_config, 1); - value v_blocking = Field(v_config, 2); - int tmp = -1; - while (Is_block(v_plan)) { - value v_dup = Field(v_plan, 0); - int src = Int_val(Field(v_dup, 0)); - int dst = Int_val(Field(v_dup, 1)); - if (src == -1) src = tmp; - if (dst == -1) { - // Dup to a temporary FD - if (tmp == -1) { - tmp = dup(src); - if (tmp < 0) { - eio_unix_fork_error(errors, "dup-tmp", strerror(errno)); - _exit(1); - } - } else { - int r = dup2(src, tmp); - if (r < 0) { - eio_unix_fork_error(errors, "dup2-tmp", strerror(errno)); - _exit(1); - } - } - set_cloexec(errors, tmp, 1); - } else if (src == dst) { - set_cloexec(errors, dst, 0); - } else { - int r = dup2(src, dst); - if (r < 0) { - eio_unix_fork_error(errors, "dup2", strerror(errno)); - _exit(1); - } - } - v_plan = Field(v_plan, 1); - } - while (Is_block(v_blocking)) { - value v_flags = Field(v_blocking, 0); - int fd = Int_val(Field(v_flags, 0)); - int blocking = Bool_val(Field(v_flags, 1)); - set_blocking(errors, fd, blocking); - v_blocking = Field(v_blocking, 1); - } -} - -CAMLprim value eio_unix_fork_dups(value v_unit) { - return Val_fork_fn(action_dups); -} +/* Note: fork actions MUST NOT allocate (either on the OCaml heap or with C malloc). + * This is because e.g. we might have forked while another thread in the parent had a lock. + * In the child, we inherit a copy of the locked mutex, but no corresponding thread to + * release it. + */ + +#include "primitives.h" + +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include + +#include "fork_action.h" + +#ifndef _WIN32 +void eio_unix_run_fork_actions(int errors, value v_actions) { + int old_flags = fcntl(errors, F_GETFL, 0); + fcntl(errors, F_SETFL, old_flags & ~O_NONBLOCK); + while (Is_block(v_actions)) { + value v_action = Field(v_actions, 0); + fork_fn *action = (fork_fn *) Nativeint_val(Field(v_action, 0)); + action(errors, v_action); + v_actions = Field(v_actions, 1); + } + _exit(1); +} +#endif + +static void try_write_all(int fd, char *buf) { + int len = strlen(buf); + while (len > 0) { + int wrote = write(fd, buf, len); + + if (wrote <= 0) + return; + + buf += wrote; + len -= wrote; + } +} + +void eio_unix_fork_error(int fd, char *fn, char *buf) { + try_write_all(fd, fn); + try_write_all(fd, ": "); + try_write_all(fd, buf); +} + +#define String_array_val(v) *((char ***)Data_custom_val(v)) + +static void finalize_string_array(value v) { + free(String_array_val(v)); + String_array_val(v) = NULL; +} + +static struct custom_operations string_array_ops = { + "string.array", + finalize_string_array, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default, + custom_compare_ext_default, + custom_fixed_length_default +}; + +CAMLprim value eio_unix_make_string_array(value v_len) { + CAMLparam0(); + CAMLlocal1(v_str_array); + int n = Int_val(v_len); + uintnat total; + + if (caml_umul_overflow(sizeof(char *), n + 1, &total)) + caml_raise_out_of_memory(); + + v_str_array = caml_alloc_custom_mem(&string_array_ops, sizeof(char ***), total); + + char **c = calloc(sizeof(char *), n + 1); + String_array_val(v_str_array) = c; + if (!c) + caml_raise_out_of_memory(); + + CAMLreturn(v_str_array); +} + +static void fill_string_array(char **c, value v_ocaml_array) { + int n = Wosize_val(v_ocaml_array); + + for (int i = 0; i < n; i++) { + c[i] = (char *) String_val(Field(v_ocaml_array, i)); + } + + c[n] = NULL; +} + +static void action_execve(int errors, value v_config) { + value v_exe = Field(v_config, 1); + char **argv = String_array_val(Field(v_config, 2)); + char **envp = String_array_val(Field(v_config, 4)); + + fill_string_array(argv, Field(v_config, 3)); + fill_string_array(envp, Field(v_config, 5)); + + execve(String_val(v_exe), argv, envp); + eio_unix_fork_error(errors, "execve", strerror(errno)); + _exit(1); +} + +CAMLprim value eio_unix_fork_execve(value v_unit) { + return Val_fork_fn(action_execve); +} + +static void action_fchdir(int errors, value v_config) { + #ifdef _WIN32 + eio_unix_fork_error(errors, "action_fchdir", "Unsupported operation on windows"); + #else + value v_fd = Field(v_config, 1); + int r; + r = fchdir(Int_val(v_fd)); + if (r != 0) { + eio_unix_fork_error(errors, "fchdir", strerror(errno)); + _exit(1); + } + #endif +} + +CAMLprim value eio_unix_fork_fchdir(value v_unit) { + return Val_fork_fn(action_fchdir); +} + +static void action_chdir(int errors, value v_config) { + value v_path = Field(v_config, 1); + int r; + r = chdir(String_val(v_path)); + if (r != 0) { + eio_unix_fork_error(errors, "chdir", strerror(errno)); + _exit(1); + } +} + +CAMLprim value eio_unix_fork_chdir(value v_unit) { + return Val_fork_fn(action_chdir); +} + +static void set_blocking(int errors, int fd, int blocking) { + #ifdef _WIN32 + eio_unix_fork_error(errors, "set_blocking", "Unsupported operation on windows"); + #else + int r = fcntl(fd, F_GETFL, 0); + if (r != -1) { + int flags = blocking + ? r & ~O_NONBLOCK + : r | O_NONBLOCK; + if (r != flags) { + r = fcntl(fd, F_SETFL, flags); + } + } + if (r == -1) { + eio_unix_fork_error(errors, "fcntl", strerror(errno)); + _exit(1); + } + #endif +} + +static void set_cloexec(int errors, int fd, int cloexec) { + #ifdef _WIN32 + eio_unix_fork_error(errors, "set_cloexec", "Unsupported operation on windows"); + #else + int r = fcntl(fd, F_GETFD, 0); + if (r != -1) { + int flags = cloexec + ? r | FD_CLOEXEC + : r & ~FD_CLOEXEC; + if (r != flags) { + r = fcntl(fd, F_SETFD, flags); + } + } + if (r == -1) { + eio_unix_fork_error(errors, "fcntl", strerror(errno)); + _exit(1); + } + #endif +} + +static void action_dups(int errors, value v_config) { + value v_plan = Field(v_config, 1); + value v_blocking = Field(v_config, 2); + int tmp = -1; + while (Is_block(v_plan)) { + value v_dup = Field(v_plan, 0); + int src = Int_val(Field(v_dup, 0)); + int dst = Int_val(Field(v_dup, 1)); + if (src == -1) src = tmp; + if (dst == -1) { + // Dup to a temporary FD + if (tmp == -1) { + tmp = dup(src); + if (tmp < 0) { + eio_unix_fork_error(errors, "dup-tmp", strerror(errno)); + _exit(1); + } + } else { + int r = dup2(src, tmp); + if (r < 0) { + eio_unix_fork_error(errors, "dup2-tmp", strerror(errno)); + _exit(1); + } + } + set_cloexec(errors, tmp, 1); + } else if (src == dst) { + set_cloexec(errors, dst, 0); + } else { + int r = dup2(src, dst); + if (r < 0) { + eio_unix_fork_error(errors, "dup2", strerror(errno)); + _exit(1); + } + } + v_plan = Field(v_plan, 1); + } + while (Is_block(v_blocking)) { + value v_flags = Field(v_blocking, 0); + int fd = Int_val(Field(v_flags, 0)); + int blocking = Bool_val(Field(v_flags, 1)); + set_blocking(errors, fd, blocking); + v_blocking = Field(v_blocking, 1); + } +} + +CAMLprim value eio_unix_fork_dups(value v_unit) { + return Val_fork_fn(action_dups); +} diff --git a/lib_eio/unix/fork_action.ml b/lib_eio/unix/fork_action.ml index c04413630..6d2225c02 100644 --- a/lib_eio/unix/fork_action.ml +++ b/lib_eio/unix/fork_action.ml @@ -1,70 +1,70 @@ -type c_action = Obj.t - -type t = { run : 'a. ((c_action -> 'a) -> 'a) } [@@unboxed] - -(* A [fork_fn] is a C function that can be executed after forking. It cannot call OCaml code or - run the OCaml GC. It is passed a [Unix.file_descr] for errors and a pointer - to a [c_action]. On success it should write nothing to the error stream and - return 0. On error, it should write a message to the error FD and return a - non-zero value for the exit status (e.g. 1). *) -type fork_fn - -let rec with_actions actions fn = - match actions with - | [] -> fn [] - | { run } :: xs -> - run @@ fun c_action -> - with_actions xs @@ fun c_actions -> - fn (c_action :: c_actions) - -type c_array -external make_string_array : int -> c_array = "eio_unix_make_string_array" -external action_execve : unit -> fork_fn = "eio_unix_fork_execve" -let action_execve = action_execve () -let execve path ~argv ~env = - let argv_c_array = make_string_array (Array.length argv) in - let env_c_array = make_string_array (Array.length env) in - { run = fun k -> k (Obj.repr (action_execve, path, argv_c_array, argv, env_c_array, env)) } - -external action_chdir : unit -> fork_fn = "eio_unix_fork_chdir" -let action_chdir = action_chdir () -let chdir path = { run = fun k -> k (Obj.repr (action_chdir, path)) } - -external action_fchdir : unit -> fork_fn = "eio_unix_fork_fchdir" -let action_fchdir = action_fchdir () -let fchdir fd = { - run = fun k -> - Fd.use_exn "fchdir" fd @@ fun fd -> - k (Obj.repr (action_fchdir, fd)) } - -let int_of_fd : Unix.file_descr -> int = Obj.magic - -type action = Inherit_fds.action = { src : int; dst : int } - -let rec with_fds mapping k = - match mapping with - | [] -> k [] - | (dst, src, _) :: xs -> - Fd.use_exn "inherit_fds" src @@ fun src -> - with_fds xs @@ fun xs -> - k ((dst, int_of_fd src) :: xs) - -type blocking = [ - | `Blocking - | `Nonblocking - | `Preserve_blocking -] - -external action_dups : unit -> fork_fn = "eio_unix_fork_dups" -let action_dups = action_dups () -let inherit_fds m = - let blocking = m |> List.filter_map (fun (dst, _, flags) -> - match flags with - | `Blocking -> Some (dst, true) - | `Nonblocking -> Some (dst, false) - | `Preserve_blocking -> None - ) - in - with_fds m @@ fun m -> - let plan : action list = Inherit_fds.plan m in - { run = fun k -> k (Obj.repr (action_dups, plan, blocking)) } +type c_action = Obj.t + +type t = { run : 'a. ((c_action -> 'a) -> 'a) } [@@unboxed] + +(* A [fork_fn] is a C function that can be executed after forking. It cannot call OCaml code or + run the OCaml GC. It is passed a [Unix.file_descr] for errors and a pointer + to a [c_action]. On success it should write nothing to the error stream and + return 0. On error, it should write a message to the error FD and return a + non-zero value for the exit status (e.g. 1). *) +type fork_fn + +let rec with_actions actions fn = + match actions with + | [] -> fn [] + | { run } :: xs -> + run @@ fun c_action -> + with_actions xs @@ fun c_actions -> + fn (c_action :: c_actions) + +type c_array +external make_string_array : int -> c_array = "eio_unix_make_string_array" +external action_execve : unit -> fork_fn = "eio_unix_fork_execve" +let action_execve = action_execve () +let execve path ~argv ~env = + let argv_c_array = make_string_array (Array.length argv) in + let env_c_array = make_string_array (Array.length env) in + { run = fun k -> k (Obj.repr (action_execve, path, argv_c_array, argv, env_c_array, env)) } + +external action_chdir : unit -> fork_fn = "eio_unix_fork_chdir" +let action_chdir = action_chdir () +let chdir path = { run = fun k -> k (Obj.repr (action_chdir, path)) } + +external action_fchdir : unit -> fork_fn = "eio_unix_fork_fchdir" +let action_fchdir = action_fchdir () +let fchdir fd = { + run = fun k -> + Fd.use_exn "fchdir" fd @@ fun fd -> + k (Obj.repr (action_fchdir, fd)) } + +let int_of_fd : Unix.file_descr -> int = Obj.magic + +type action = Inherit_fds.action = { src : int; dst : int } + +let rec with_fds mapping k = + match mapping with + | [] -> k [] + | (dst, src, _) :: xs -> + Fd.use_exn "inherit_fds" src @@ fun src -> + with_fds xs @@ fun xs -> + k ((dst, int_of_fd src) :: xs) + +type blocking = [ + | `Blocking + | `Nonblocking + | `Preserve_blocking +] + +external action_dups : unit -> fork_fn = "eio_unix_fork_dups" +let action_dups = action_dups () +let inherit_fds m = + let blocking = m |> List.filter_map (fun (dst, _, flags) -> + match flags with + | `Blocking -> Some (dst, true) + | `Nonblocking -> Some (dst, false) + | `Preserve_blocking -> None + ) + in + with_fds m @@ fun m -> + let plan : action list = Inherit_fds.plan m in + { run = fun k -> k (Obj.repr (action_dups, plan, blocking)) } diff --git a/lib_eio/unix/fork_action.mli b/lib_eio/unix/fork_action.mli index fc9357d4a..c7371f6e7 100644 --- a/lib_eio/unix/fork_action.mli +++ b/lib_eio/unix/fork_action.mli @@ -1,60 +1,60 @@ -(** Actions to perform after forking a child process. - - To spawn a child executable on Unix, the parent forks a copy of itself, - then has the child copy set up the environment for the new program and - execute it. - - However, we cannot run any OCaml code in the forked child process. This is - because `fork` only duplicates its own domain. To the child, it appears - that all other domains have stopped responding and if it tries to e.g. - perform a GC then the child process will hang. - - Therefore, the fork call and all child actions need to be written in C. - This module provides some support code for doing that. - Individual backends will wrap these actions with higher-level APIs and - can also add their own platform-specific actions. - - @canonical Eio_unix.Private.Fork_action *) - -type fork_fn -(** A C function, as defined in "include/fork_action.h". *) - -type c_action = Obj.t -(** An action to be performed in a child process after forking. - This must be a tuple whose first field is a [fork_fn]. *) - -type t = { run : 'a. ((c_action -> 'a) -> 'a) } [@@unboxed] -(** An action that calls [run k] in the parent process to create the C action. - [run] passes the action to [k], which forks the child and runs it. When [k] - returns, [run] can free any resources used. *) - -val with_actions : t list -> (c_action list -> 'a) -> 'a - -(** {2 Actions} *) - -val execve : string -> argv:string array -> env:string array -> t -(** See [execve(2)]. - - This replaces the current executable, - so it only makes sense as the last action to be performed. *) - -val chdir : string -> t -(** [chdir path] changes directory to [path]. *) - -val fchdir : Fd.t -> t -(** [fchdir fd] changes directory to [fd]. *) - -type blocking = [ - | `Blocking (** Clear the [O_NONBLOCK] flag in the child process. *) - | `Nonblocking (** Set the [O_NONBLOCK] flag in the child process. *) - | `Preserve_blocking (** Don't change the blocking mode of the FD. *) -] - -val inherit_fds : (int * Fd.t * [< blocking]) list -> t -(** [inherit_fds mapping] marks file descriptors as not close-on-exec and renumbers them. - - For each (fd, src, flags) in [mapping], we use [dup2] to duplicate [src] as [fd]. - If there are cycles in [mapping], a temporary FD is used to break the cycle. - A mapping from an FD to itself simply clears the close-on-exec flag. - - After this, the new FDs may also be set as blocking or non-blocking, depending on [flags]. *) +(** Actions to perform after forking a child process. + + To spawn a child executable on Unix, the parent forks a copy of itself, + then has the child copy set up the environment for the new program and + execute it. + + However, we cannot run any OCaml code in the forked child process. This is + because `fork` only duplicates its own domain. To the child, it appears + that all other domains have stopped responding and if it tries to e.g. + perform a GC then the child process will hang. + + Therefore, the fork call and all child actions need to be written in C. + This module provides some support code for doing that. + Individual backends will wrap these actions with higher-level APIs and + can also add their own platform-specific actions. + + @canonical Eio_unix.Private.Fork_action *) + +type fork_fn +(** A C function, as defined in "include/fork_action.h". *) + +type c_action = Obj.t +(** An action to be performed in a child process after forking. + This must be a tuple whose first field is a [fork_fn]. *) + +type t = { run : 'a. ((c_action -> 'a) -> 'a) } [@@unboxed] +(** An action that calls [run k] in the parent process to create the C action. + [run] passes the action to [k], which forks the child and runs it. When [k] + returns, [run] can free any resources used. *) + +val with_actions : t list -> (c_action list -> 'a) -> 'a + +(** {2 Actions} *) + +val execve : string -> argv:string array -> env:string array -> t +(** See [execve(2)]. + + This replaces the current executable, + so it only makes sense as the last action to be performed. *) + +val chdir : string -> t +(** [chdir path] changes directory to [path]. *) + +val fchdir : Fd.t -> t +(** [fchdir fd] changes directory to [fd]. *) + +type blocking = [ + | `Blocking (** Clear the [O_NONBLOCK] flag in the child process. *) + | `Nonblocking (** Set the [O_NONBLOCK] flag in the child process. *) + | `Preserve_blocking (** Don't change the blocking mode of the FD. *) +] + +val inherit_fds : (int * Fd.t * [< blocking]) list -> t +(** [inherit_fds mapping] marks file descriptors as not close-on-exec and renumbers them. + + For each (fd, src, flags) in [mapping], we use [dup2] to duplicate [src] as [fd]. + If there are cycles in [mapping], a temporary FD is used to break the cycle. + A mapping from an FD to itself simply clears the close-on-exec flag. + + After this, the new FDs may also be set as blocking or non-blocking, depending on [flags]. *) diff --git a/lib_eio/unix/include/fork_action.h b/lib_eio/unix/include/fork_action.h index ab15a39bd..11bb24b11 100644 --- a/lib_eio/unix/include/fork_action.h +++ b/lib_eio/unix/include/fork_action.h @@ -1,23 +1,23 @@ -#include -#include - -/* A function that runs in the forked child process. - * It must not run any OCaml code, invoke the GC, or even call [malloc]. - * If the action fails then it writes an error message to the FD [errors] and calls [_exit]. - * v_args is the c_action tuple (where field 0 is the function itself). - */ -typedef void fork_fn(int errors, value v_args); - -Caml_inline value Val_fork_fn(fork_fn *fn) { - return caml_copy_nativeint((intnat) fn); -} - -/* Run each C action in the list [v_actions]. - * Sets [errors] to be blocking. Never returns. - */ -void eio_unix_run_fork_actions(int errors, value v_actions); - -/* Write "$fn: $msg" to fd. - * fd must be blocking. - * Ignores failure. */ -void eio_unix_fork_error(int fd, char *fn, char *msg); +#include +#include + +/* A function that runs in the forked child process. + * It must not run any OCaml code, invoke the GC, or even call [malloc]. + * If the action fails then it writes an error message to the FD [errors] and calls [_exit]. + * v_args is the c_action tuple (where field 0 is the function itself). + */ +typedef void fork_fn(int errors, value v_args); + +Caml_inline value Val_fork_fn(fork_fn *fn) { + return caml_copy_nativeint((intnat) fn); +} + +/* Run each C action in the list [v_actions]. + * Sets [errors] to be blocking. Never returns. + */ +void eio_unix_run_fork_actions(int errors, value v_actions); + +/* Write "$fn: $msg" to fd. + * fd must be blocking. + * Ignores failure. */ +void eio_unix_fork_error(int fd, char *fn, char *msg); diff --git a/lib_eio/unix/inherit_fds.ml b/lib_eio/unix/inherit_fds.ml index 40687f0e1..9bd2a8ce6 100644 --- a/lib_eio/unix/inherit_fds.ml +++ b/lib_eio/unix/inherit_fds.ml @@ -1,97 +1,97 @@ -(* - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -module M = Map.Make(Int) - -module Count = struct - let create () = ref M.empty - - let get t fd = - M.find_opt fd !t - |> Option.value ~default:0 - - let incr t fd = - let inc x = Some (1 + Option.value x ~default:0) in - t := M.update fd inc !t - - let decr t fd = - match get t fd with - | i when i <= 0 -> assert false - | 1 -> t := M.remove fd !t; `Unused - | i -> t := M.add fd (pred i) !t; `Still_needed -end - -type action = { src : int; dst : int } - -let plan mapping = - let mapping = - List.fold_left (fun acc (dst, src) -> - if M.mem dst acc then Fmt.invalid_arg "FD %d assigned twice!" dst; - M.add dst src acc - ) M.empty mapping - in - let plan = ref [] in - let dup2 src dst = plan := {src; dst} :: !plan in - let users_of = Count.create () in - (* First, for any FDs that map to themselves we emit (fd, fd) and then forget about it, - as this doesn't interfere with anything else. - We also set [users_of] to track how many times each FD is needed. *) - let mapping = mapping |> M.filter (fun dst src -> - if src = dst then (dup2 src src; false) (* Just clear the close-on-exec flag. *) - else (Count.incr users_of src; true) - ) in - let tmp = ref (-1) in (* The FD we dup'd to the temporary FD when breaking cycles. *) - let rec no_users dst = - (* Nothing requires the old value of [dst] now, - so if we wanted to put something there, do it. *) - M.find_opt dst mapping |> Option.iter (fun src -> dup src dst) - and dup src dst = - (* Duplicate [src] as [dst]. *) - if src = !tmp then ( - (* We moved [src] to [tmp] to break a cycle, so use [tmp] instead. - Also, there's nothing to do after this as the cycle is broken. *) - dup2 (-1) dst; - ) else ( - dup2 src dst; - (* Record that [dst] no longer depends on [src]. *) - match Count.decr users_of src with - | `Still_needed -> () - | `Unused -> no_users src - ) - in - (* Find any loose ends and work backwards. - Note: we need to do this in two steps because [dup] modifies [users_of]. *) - mapping - |> M.filter (fun dst _src -> Count.get users_of dst = 0) (* FDs with no dependants *) - |> M.iter (fun dst src -> dup src dst); - (* At this point there are no loose ends; we have nothing but cycles left. *) - (* M.iter (fun _ v -> assert (v = 1)) !users_of; *) - (* For each cycle, break it at one point using the temporary FD. - It's safe to allocate the temporary FD now because every FD we plan to use is already allocated. *) - let rec break_cycles () = - match M.min_binding_opt !users_of with (* Pick any remaining FD. *) - | None -> () - | Some (src, _) -> - dup2 src (-1); (* Duplicate [src] somewhere. *) - tmp := src; (* Remember that when we try to use it later. *) - (* The FD that needed [src] can now use [tmp] instead: *) - let state = Count.decr users_of src in - assert (state = `Unused); - no_users src; (* Free this cycle. *) - break_cycles () (* Free any other cycles. *) - in - break_cycles (); - List.rev !plan +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module M = Map.Make(Int) + +module Count = struct + let create () = ref M.empty + + let get t fd = + M.find_opt fd !t + |> Option.value ~default:0 + + let incr t fd = + let inc x = Some (1 + Option.value x ~default:0) in + t := M.update fd inc !t + + let decr t fd = + match get t fd with + | i when i <= 0 -> assert false + | 1 -> t := M.remove fd !t; `Unused + | i -> t := M.add fd (pred i) !t; `Still_needed +end + +type action = { src : int; dst : int } + +let plan mapping = + let mapping = + List.fold_left (fun acc (dst, src) -> + if M.mem dst acc then Fmt.invalid_arg "FD %d assigned twice!" dst; + M.add dst src acc + ) M.empty mapping + in + let plan = ref [] in + let dup2 src dst = plan := {src; dst} :: !plan in + let users_of = Count.create () in + (* First, for any FDs that map to themselves we emit (fd, fd) and then forget about it, + as this doesn't interfere with anything else. + We also set [users_of] to track how many times each FD is needed. *) + let mapping = mapping |> M.filter (fun dst src -> + if src = dst then (dup2 src src; false) (* Just clear the close-on-exec flag. *) + else (Count.incr users_of src; true) + ) in + let tmp = ref (-1) in (* The FD we dup'd to the temporary FD when breaking cycles. *) + let rec no_users dst = + (* Nothing requires the old value of [dst] now, + so if we wanted to put something there, do it. *) + M.find_opt dst mapping |> Option.iter (fun src -> dup src dst) + and dup src dst = + (* Duplicate [src] as [dst]. *) + if src = !tmp then ( + (* We moved [src] to [tmp] to break a cycle, so use [tmp] instead. + Also, there's nothing to do after this as the cycle is broken. *) + dup2 (-1) dst; + ) else ( + dup2 src dst; + (* Record that [dst] no longer depends on [src]. *) + match Count.decr users_of src with + | `Still_needed -> () + | `Unused -> no_users src + ) + in + (* Find any loose ends and work backwards. + Note: we need to do this in two steps because [dup] modifies [users_of]. *) + mapping + |> M.filter (fun dst _src -> Count.get users_of dst = 0) (* FDs with no dependants *) + |> M.iter (fun dst src -> dup src dst); + (* At this point there are no loose ends; we have nothing but cycles left. *) + (* M.iter (fun _ v -> assert (v = 1)) !users_of; *) + (* For each cycle, break it at one point using the temporary FD. + It's safe to allocate the temporary FD now because every FD we plan to use is already allocated. *) + let rec break_cycles () = + match M.min_binding_opt !users_of with (* Pick any remaining FD. *) + | None -> () + | Some (src, _) -> + dup2 src (-1); (* Duplicate [src] somewhere. *) + tmp := src; (* Remember that when we try to use it later. *) + (* The FD that needed [src] can now use [tmp] instead: *) + let state = Count.decr users_of src in + assert (state = `Unused); + no_users src; (* Free this cycle. *) + break_cycles () (* Free any other cycles. *) + in + break_cycles (); + List.rev !plan diff --git a/lib_eio/unix/inherit_fds.mli b/lib_eio/unix/inherit_fds.mli index 3077ce5a8..ea08f6c92 100644 --- a/lib_eio/unix/inherit_fds.mli +++ b/lib_eio/unix/inherit_fds.mli @@ -1,19 +1,19 @@ -(** Plan how to renumber FDs in a child process. *) - -type action = { src : int; dst : int } -(** [{ src; dst}] is (roughly) a request to [dup2(src, dst)]. - - [dst] should not be marked as close-on-exec. - If [src = dst] then simply clear the close-on-exec flag for the FD. - - An FD of -1 means to use a temporary FD (e.g. use [dup] the first time, - with close-on-exec true). This is needed if there are cycles (e.g. we want - to switch FDs 1 and 2). Only one temporary FD is needed at a time, so it - can be reused as necessary. *) - -val plan : (int * int) list -> action list -(** [plan mapping] calculates a sequence of operations to renumber file descriptors so that - FD x afterwards refers to the object that [List.assoc x mapping] referred to at the start. - - It returns a list of actions to be performed in sequence. - Example: [plan [1, 2]] is just [[(2, 1)]]. *) +(** Plan how to renumber FDs in a child process. *) + +type action = { src : int; dst : int } +(** [{ src; dst}] is (roughly) a request to [dup2(src, dst)]. + + [dst] should not be marked as close-on-exec. + If [src = dst] then simply clear the close-on-exec flag for the FD. + + An FD of -1 means to use a temporary FD (e.g. use [dup] the first time, + with close-on-exec true). This is needed if there are cycles (e.g. we want + to switch FDs 1 and 2). Only one temporary FD is needed at a time, so it + can be reused as necessary. *) + +val plan : (int * int) list -> action list +(** [plan mapping] calculates a sequence of operations to renumber file descriptors so that + FD x afterwards refers to the object that [List.assoc x mapping] referred to at the start. + + It returns a list of actions to be performed in sequence. + Example: [plan [1, 2]] is just [[(2, 1)]]. *) diff --git a/lib_eio/unix/net.ml b/lib_eio/unix/net.ml index 11f4a173a..07f838574 100644 --- a/lib_eio/unix/net.ml +++ b/lib_eio/unix/net.ml @@ -1,93 +1,93 @@ -open Eio.Std - -type stream_socket_ty = [`Generic | `Unix] Eio.Net.stream_socket_ty -type datagram_socket_ty = [`Generic | `Unix] Eio.Net.datagram_socket_ty -type listening_socket_ty = [`Generic | `Unix] Eio.Net.listening_socket_ty -type 'a stream_socket = ([> stream_socket_ty] as 'a) r -type 'a datagram_socket = ([> datagram_socket_ty] as 'a) r -type 'a listening_socket = ([> listening_socket_ty] as 'a) r - -module Ipaddr = struct - let to_unix : _ Eio.Net.Ipaddr.t -> Unix.inet_addr = Obj.magic - let of_unix : Unix.inet_addr -> _ Eio.Net.Ipaddr.t = Obj.magic -end - -let sockaddr_to_unix = function - | `Unix path -> Unix.ADDR_UNIX path - | `Tcp (host, port) | `Udp (host, port) -> - let host = Ipaddr.to_unix host in - Unix.ADDR_INET (host, port) - -let sockaddr_of_unix_stream = function - | Unix.ADDR_UNIX path -> `Unix path - | Unix.ADDR_INET (host, port) -> - let host = Ipaddr.of_unix host in - `Tcp (host, port) - -let sockaddr_of_unix_datagram = function - | Unix.ADDR_UNIX path -> `Unix path - | Unix.ADDR_INET (host, port) -> - let host = Ipaddr.of_unix host in - `Udp (host, port) - -let send_msg (Eio.Resource.T (t, ops)) ?(fds=[]) bufs = - let module X = (val (Eio.Resource.get ops Pi.Stream_socket)) in - let rec aux ~fds bufs = - let sent = X.send_msg t ~fds bufs in - match Cstruct.shiftv bufs sent with - | [] -> () - | bufs -> aux bufs ~fds:[] - in - aux ~fds bufs - -let recv_msg_with_fds (Eio.Resource.T (t, ops)) ~sw ~max_fds bufs = - let module X = (val (Eio.Resource.get ops Pi.Stream_socket)) in - X.recv_msg_with_fds t ~sw ~max_fds bufs - -let getnameinfo (sockaddr : Eio.Net.Sockaddr.t) = - let options = - match sockaddr with - | `Unix _ | `Tcp _ -> [] - | `Udp _ -> [Unix.NI_DGRAM] - in - let sockaddr = sockaddr_to_unix sockaddr in - Thread_pool.run_in_systhread ~label:"getnameinfo" (fun () -> - let Unix.{ni_hostname; ni_service} = Unix.getnameinfo sockaddr options in - (ni_hostname, ni_service)) - -type t = [`Generic | `Unix] Eio.Net.ty r - -[@@@alert "-unstable"] - -type _ Effect.t += - | Import_socket_stream : Switch.t * bool * Unix.file_descr -> [`Unix_fd | stream_socket_ty] r Effect.t - | Import_socket_listening : Switch.t * bool * Unix.file_descr -> [`Unix_fd | listening_socket_ty] r Effect.t - | Import_socket_datagram : Switch.t * bool * Unix.file_descr -> [`Unix_fd | datagram_socket_ty] r Effect.t - | Socketpair_stream : Switch.t * Unix.socket_domain * int -> - ([`Unix_fd | stream_socket_ty] r * [`Unix_fd | stream_socket_ty] r) Effect.t - | Socketpair_datagram : Switch.t * Unix.socket_domain * int -> - ([`Unix_fd | datagram_socket_ty] r * [`Unix_fd | datagram_socket_ty] r) Effect.t - -let open_stream s = (s : [`Unix_fd | stream_socket_ty] r :> [< `Unix_fd | stream_socket_ty] r) -let open_listening s = (s : [`Unix_fd | listening_socket_ty] r :> [< `Unix_fd | listening_socket_ty] r) -let open_datagram s = (s : [`Unix_fd | datagram_socket_ty] r :> [< `Unix_fd | datagram_socket_ty] r) - -let import_socket_stream ~sw ~close_unix fd = - open_stream @@ Effect.perform (Import_socket_stream (sw, close_unix, fd)) - -let import_socket_listening ~sw ~close_unix fd = - open_listening @@ Effect.perform (Import_socket_listening (sw, close_unix, fd)) - -let import_socket_datagram ~sw ~close_unix fd = - open_datagram @@ Effect.perform (Import_socket_datagram (sw, close_unix, fd)) - -let socketpair_stream ~sw ?(domain=Unix.PF_UNIX) ?(protocol=0) () = - let a, b = Effect.perform (Socketpair_stream (sw, domain, protocol)) in - (open_stream a, open_stream b) - -let socketpair_datagram ~sw ?(domain=Unix.PF_UNIX) ?(protocol=0) () = - let a, b = Effect.perform (Socketpair_datagram (sw, domain, protocol)) in - (open_datagram a, open_datagram b) - -let fd socket = - Option.get (Resource.fd_opt socket) +open Eio.Std + +type stream_socket_ty = [`Generic | `Unix] Eio.Net.stream_socket_ty +type datagram_socket_ty = [`Generic | `Unix] Eio.Net.datagram_socket_ty +type listening_socket_ty = [`Generic | `Unix] Eio.Net.listening_socket_ty +type 'a stream_socket = ([> stream_socket_ty] as 'a) r +type 'a datagram_socket = ([> datagram_socket_ty] as 'a) r +type 'a listening_socket = ([> listening_socket_ty] as 'a) r + +module Ipaddr = struct + let to_unix : _ Eio.Net.Ipaddr.t -> Unix.inet_addr = Obj.magic + let of_unix : Unix.inet_addr -> _ Eio.Net.Ipaddr.t = Obj.magic +end + +let sockaddr_to_unix = function + | `Unix path -> Unix.ADDR_UNIX path + | `Tcp (host, port) | `Udp (host, port) -> + let host = Ipaddr.to_unix host in + Unix.ADDR_INET (host, port) + +let sockaddr_of_unix_stream = function + | Unix.ADDR_UNIX path -> `Unix path + | Unix.ADDR_INET (host, port) -> + let host = Ipaddr.of_unix host in + `Tcp (host, port) + +let sockaddr_of_unix_datagram = function + | Unix.ADDR_UNIX path -> `Unix path + | Unix.ADDR_INET (host, port) -> + let host = Ipaddr.of_unix host in + `Udp (host, port) + +let send_msg (Eio.Resource.T (t, ops)) ?(fds=[]) bufs = + let module X = (val (Eio.Resource.get ops Pi.Stream_socket)) in + let rec aux ~fds bufs = + let sent = X.send_msg t ~fds bufs in + match Cstruct.shiftv bufs sent with + | [] -> () + | bufs -> aux bufs ~fds:[] + in + aux ~fds bufs + +let recv_msg_with_fds (Eio.Resource.T (t, ops)) ~sw ~max_fds bufs = + let module X = (val (Eio.Resource.get ops Pi.Stream_socket)) in + X.recv_msg_with_fds t ~sw ~max_fds bufs + +let getnameinfo (sockaddr : Eio.Net.Sockaddr.t) = + let options = + match sockaddr with + | `Unix _ | `Tcp _ -> [] + | `Udp _ -> [Unix.NI_DGRAM] + in + let sockaddr = sockaddr_to_unix sockaddr in + Thread_pool.run_in_systhread ~label:"getnameinfo" (fun () -> + let Unix.{ni_hostname; ni_service} = Unix.getnameinfo sockaddr options in + (ni_hostname, ni_service)) + +type t = [`Generic | `Unix] Eio.Net.ty r + +[@@@alert "-unstable"] + +type _ Effect.t += + | Import_socket_stream : Switch.t * bool * Unix.file_descr -> [`Unix_fd | stream_socket_ty] r Effect.t + | Import_socket_listening : Switch.t * bool * Unix.file_descr -> [`Unix_fd | listening_socket_ty] r Effect.t + | Import_socket_datagram : Switch.t * bool * Unix.file_descr -> [`Unix_fd | datagram_socket_ty] r Effect.t + | Socketpair_stream : Switch.t * Unix.socket_domain * int -> + ([`Unix_fd | stream_socket_ty] r * [`Unix_fd | stream_socket_ty] r) Effect.t + | Socketpair_datagram : Switch.t * Unix.socket_domain * int -> + ([`Unix_fd | datagram_socket_ty] r * [`Unix_fd | datagram_socket_ty] r) Effect.t + +let open_stream s = (s : [`Unix_fd | stream_socket_ty] r :> [< `Unix_fd | stream_socket_ty] r) +let open_listening s = (s : [`Unix_fd | listening_socket_ty] r :> [< `Unix_fd | listening_socket_ty] r) +let open_datagram s = (s : [`Unix_fd | datagram_socket_ty] r :> [< `Unix_fd | datagram_socket_ty] r) + +let import_socket_stream ~sw ~close_unix fd = + open_stream @@ Effect.perform (Import_socket_stream (sw, close_unix, fd)) + +let import_socket_listening ~sw ~close_unix fd = + open_listening @@ Effect.perform (Import_socket_listening (sw, close_unix, fd)) + +let import_socket_datagram ~sw ~close_unix fd = + open_datagram @@ Effect.perform (Import_socket_datagram (sw, close_unix, fd)) + +let socketpair_stream ~sw ?(domain=Unix.PF_UNIX) ?(protocol=0) () = + let a, b = Effect.perform (Socketpair_stream (sw, domain, protocol)) in + (open_stream a, open_stream b) + +let socketpair_datagram ~sw ?(domain=Unix.PF_UNIX) ?(protocol=0) () = + let a, b = Effect.perform (Socketpair_datagram (sw, domain, protocol)) in + (open_datagram a, open_datagram b) + +let fd socket = + Option.get (Resource.fd_opt socket) diff --git a/lib_eio/unix/net.mli b/lib_eio/unix/net.mli index 7da1a54bd..4d15316b2 100644 --- a/lib_eio/unix/net.mli +++ b/lib_eio/unix/net.mli @@ -1,118 +1,118 @@ -open Eio.Std - -(** {2 Types} - - These extend the types in {!Eio.Net} with support for file descriptors. *) - -type stream_socket_ty = [`Generic | `Unix] Eio.Net.stream_socket_ty -type datagram_socket_ty = [`Generic | `Unix] Eio.Net.datagram_socket_ty -type listening_socket_ty = [`Generic | `Unix] Eio.Net.listening_socket_ty -type 'a stream_socket = ([> stream_socket_ty] as 'a) r -type 'a datagram_socket = ([> datagram_socket_ty] as 'a) r -type 'a listening_socket = ([> listening_socket_ty] as 'a) r - -type t = [`Generic | `Unix] Eio.Net.ty r - -(** {2 Passing file descriptors} *) - -val send_msg : - [> `Platform of [>`Unix] | `Socket | `Stream] r -> - ?fds:Fd.t list -> - Cstruct.t list -> unit -(** Like {!Eio.Flow.write}, but allows passing file descriptors (for Unix-domain sockets). *) - -val recv_msg_with_fds : - [> `Platform of [>`Unix] | `Socket | `Stream] r -> - sw:Switch.t -> - max_fds:int -> - Cstruct.t list -> - int * Fd.t list -(** Like {!Eio.Flow.single_read}, but also allows receiving file descriptors (for Unix-domain sockets). - - @param max_fds The maximum number of file descriptors to accept (additional ones will be closed). *) - -val fd : [> `Platform of [> `Unix] | `Socket] r -> Fd.t -(** [fd socket] is the underlying FD of [socket]. *) - -(** {2 Unix address conversions} - - Note: OCaml's {!Unix.sockaddr} type considers e.g. TCP port 80 and UDP port - 80 to be the same thing, whereas Eio regards them as separate addresses - that just happen to have the same representation (a host address and a port - number), so we have separate "of_unix" functions for each. *) - -val sockaddr_to_unix : [< Eio.Net.Sockaddr.stream | Eio.Net.Sockaddr.datagram] -> Unix.sockaddr -val sockaddr_of_unix_stream : Unix.sockaddr -> Eio.Net.Sockaddr.stream -val sockaddr_of_unix_datagram : Unix.sockaddr -> Eio.Net.Sockaddr.datagram - -(** Convert between Eio.Net.Ipaddr and Unix.inet_addr. *) -module Ipaddr : sig - (** Internally, these are actually the same type, so these are just casts. *) - - val to_unix : [< `V4 | `V6] Eio.Net.Ipaddr.t -> Unix.inet_addr - val of_unix : Unix.inet_addr -> Eio.Net.Ipaddr.v4v6 -end - -(** {2 Creating or importing sockets} *) - -val import_socket_stream : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> [< `Unix_fd | stream_socket_ty] r -(** [import_socket_stream ~sw ~close_unix fd] is an Eio flow that uses [fd]. - - It can be cast to e.g. {!source} for a one-way flow. - The socket object will be closed when [sw] finishes. - - The [close_unix] and [sw] arguments are passed to {!Fd.of_unix}. *) - -val import_socket_listening : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> [< `Unix_fd | listening_socket_ty] r -(** [import_socket_listening ~sw ~close_unix fd] is an Eio listening socket that uses [fd]. - - The socket object will be closed when [sw] finishes. - - The [close_unix] and [sw] arguments are passed to {!Fd.of_unix}. *) - -val import_socket_datagram : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> [< `Unix_fd | datagram_socket_ty] r -(** [import_socket_datagram ~sw ~close_unix fd] is an Eio datagram socket that uses [fd]. - - The socket object will be closed when [sw] finishes. - - The [close_unix] and [sw] arguments are passed to {!Fd.of_unix}. *) - -val socketpair_stream : - sw:Switch.t -> - ?domain:Unix.socket_domain -> - ?protocol:int -> - unit -> - [< `Unix_fd | stream_socket_ty] r * [< `Unix_fd | stream_socket_ty] r -(** [socketpair_stream ~sw ()] returns a connected pair of flows, such that writes to one can be read by the other. - - This creates OS-level resources using [socketpair(2)]. - Note that, like all FDs created by Eio, they are both marked as close-on-exec by default. *) - -val socketpair_datagram : - sw:Switch.t -> - ?domain:Unix.socket_domain -> - ?protocol:int -> - unit -> - [< `Unix_fd | datagram_socket_ty] r * [< `Unix_fd | datagram_socket_ty] r -(** [socketpair_datagram ~sw ()] returns a connected pair of flows, such that writes to one can be read by the other. - - This creates OS-level resources using [socketpair(2)]. - Note that, like all FDs created by Eio, they are both marked as close-on-exec by default. *) - -(** {2 Private API for backends} *) - -val getnameinfo : Eio.Net.Sockaddr.t -> (string * string) -(** [getnameinfo sockaddr] returns domain name and service for [sockaddr]. *) - -type _ Effect.t += - | Import_socket_stream : - Switch.t * bool * Unix.file_descr -> [`Unix_fd | stream_socket_ty] r Effect.t (** See {!import_socket_stream} *) - | Import_socket_listening : - Switch.t * bool * Unix.file_descr -> [`Unix_fd | listening_socket_ty] r Effect.t (** See {!import_socket_listening} *) - | Import_socket_datagram : - Switch.t * bool * Unix.file_descr -> [`Unix_fd | datagram_socket_ty] r Effect.t (** See {!import_socket_datagram} *) - | Socketpair_stream : Eio.Switch.t * Unix.socket_domain * int -> - ([`Unix_fd | stream_socket_ty] r * [`Unix_fd | stream_socket_ty] r) Effect.t (** See {!socketpair_stream} *) - | Socketpair_datagram : Eio.Switch.t * Unix.socket_domain * int -> - ([`Unix_fd | datagram_socket_ty] r * [`Unix_fd | datagram_socket_ty] r) Effect.t (** See {!socketpair_datagram} *) -[@@alert "-unstable"] +open Eio.Std + +(** {2 Types} + + These extend the types in {!Eio.Net} with support for file descriptors. *) + +type stream_socket_ty = [`Generic | `Unix] Eio.Net.stream_socket_ty +type datagram_socket_ty = [`Generic | `Unix] Eio.Net.datagram_socket_ty +type listening_socket_ty = [`Generic | `Unix] Eio.Net.listening_socket_ty +type 'a stream_socket = ([> stream_socket_ty] as 'a) r +type 'a datagram_socket = ([> datagram_socket_ty] as 'a) r +type 'a listening_socket = ([> listening_socket_ty] as 'a) r + +type t = [`Generic | `Unix] Eio.Net.ty r + +(** {2 Passing file descriptors} *) + +val send_msg : + [> `Platform of [>`Unix] | `Socket | `Stream] r -> + ?fds:Fd.t list -> + Cstruct.t list -> unit +(** Like {!Eio.Flow.write}, but allows passing file descriptors (for Unix-domain sockets). *) + +val recv_msg_with_fds : + [> `Platform of [>`Unix] | `Socket | `Stream] r -> + sw:Switch.t -> + max_fds:int -> + Cstruct.t list -> + int * Fd.t list +(** Like {!Eio.Flow.single_read}, but also allows receiving file descriptors (for Unix-domain sockets). + + @param max_fds The maximum number of file descriptors to accept (additional ones will be closed). *) + +val fd : [> `Platform of [> `Unix] | `Socket] r -> Fd.t +(** [fd socket] is the underlying FD of [socket]. *) + +(** {2 Unix address conversions} + + Note: OCaml's {!Unix.sockaddr} type considers e.g. TCP port 80 and UDP port + 80 to be the same thing, whereas Eio regards them as separate addresses + that just happen to have the same representation (a host address and a port + number), so we have separate "of_unix" functions for each. *) + +val sockaddr_to_unix : [< Eio.Net.Sockaddr.stream | Eio.Net.Sockaddr.datagram] -> Unix.sockaddr +val sockaddr_of_unix_stream : Unix.sockaddr -> Eio.Net.Sockaddr.stream +val sockaddr_of_unix_datagram : Unix.sockaddr -> Eio.Net.Sockaddr.datagram + +(** Convert between Eio.Net.Ipaddr and Unix.inet_addr. *) +module Ipaddr : sig + (** Internally, these are actually the same type, so these are just casts. *) + + val to_unix : [< `V4 | `V6] Eio.Net.Ipaddr.t -> Unix.inet_addr + val of_unix : Unix.inet_addr -> Eio.Net.Ipaddr.v4v6 +end + +(** {2 Creating or importing sockets} *) + +val import_socket_stream : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> [< `Unix_fd | stream_socket_ty] r +(** [import_socket_stream ~sw ~close_unix fd] is an Eio flow that uses [fd]. + + It can be cast to e.g. {!source} for a one-way flow. + The socket object will be closed when [sw] finishes. + + The [close_unix] and [sw] arguments are passed to {!Fd.of_unix}. *) + +val import_socket_listening : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> [< `Unix_fd | listening_socket_ty] r +(** [import_socket_listening ~sw ~close_unix fd] is an Eio listening socket that uses [fd]. + + The socket object will be closed when [sw] finishes. + + The [close_unix] and [sw] arguments are passed to {!Fd.of_unix}. *) + +val import_socket_datagram : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> [< `Unix_fd | datagram_socket_ty] r +(** [import_socket_datagram ~sw ~close_unix fd] is an Eio datagram socket that uses [fd]. + + The socket object will be closed when [sw] finishes. + + The [close_unix] and [sw] arguments are passed to {!Fd.of_unix}. *) + +val socketpair_stream : + sw:Switch.t -> + ?domain:Unix.socket_domain -> + ?protocol:int -> + unit -> + [< `Unix_fd | stream_socket_ty] r * [< `Unix_fd | stream_socket_ty] r +(** [socketpair_stream ~sw ()] returns a connected pair of flows, such that writes to one can be read by the other. + + This creates OS-level resources using [socketpair(2)]. + Note that, like all FDs created by Eio, they are both marked as close-on-exec by default. *) + +val socketpair_datagram : + sw:Switch.t -> + ?domain:Unix.socket_domain -> + ?protocol:int -> + unit -> + [< `Unix_fd | datagram_socket_ty] r * [< `Unix_fd | datagram_socket_ty] r +(** [socketpair_datagram ~sw ()] returns a connected pair of flows, such that writes to one can be read by the other. + + This creates OS-level resources using [socketpair(2)]. + Note that, like all FDs created by Eio, they are both marked as close-on-exec by default. *) + +(** {2 Private API for backends} *) + +val getnameinfo : Eio.Net.Sockaddr.t -> (string * string) +(** [getnameinfo sockaddr] returns domain name and service for [sockaddr]. *) + +type _ Effect.t += + | Import_socket_stream : + Switch.t * bool * Unix.file_descr -> [`Unix_fd | stream_socket_ty] r Effect.t (** See {!import_socket_stream} *) + | Import_socket_listening : + Switch.t * bool * Unix.file_descr -> [`Unix_fd | listening_socket_ty] r Effect.t (** See {!import_socket_listening} *) + | Import_socket_datagram : + Switch.t * bool * Unix.file_descr -> [`Unix_fd | datagram_socket_ty] r Effect.t (** See {!import_socket_datagram} *) + | Socketpair_stream : Eio.Switch.t * Unix.socket_domain * int -> + ([`Unix_fd | stream_socket_ty] r * [`Unix_fd | stream_socket_ty] r) Effect.t (** See {!socketpair_stream} *) + | Socketpair_datagram : Eio.Switch.t * Unix.socket_domain * int -> + ([`Unix_fd | datagram_socket_ty] r * [`Unix_fd | datagram_socket_ty] r) Effect.t (** See {!socketpair_datagram} *) +[@@alert "-unstable"] diff --git a/lib_eio/unix/pi.ml b/lib_eio/unix/pi.ml index 43204391b..a5adbc595 100644 --- a/lib_eio/unix/pi.ml +++ b/lib_eio/unix/pi.ml @@ -1,51 +1,51 @@ -open Eio.Std - -module type STREAM_SOCKET = sig - include Eio.Net.Pi.STREAM_SOCKET - - val send_msg : t -> fds:Fd.t list -> Cstruct.t list -> int - val recv_msg_with_fds : t -> sw:Switch.t -> max_fds:int -> Cstruct.t list -> int * Fd.t list - - val fd : t -> Fd.t -end - -type (_, _, _) Eio.Resource.pi += - | Stream_socket : ('t, (module STREAM_SOCKET with type t = 't), [> `Platform of [> `Unix] | `Socket | `Stream]) Eio.Resource.pi - -module type FLOW = sig - include Eio.File.Pi.WRITE - include STREAM_SOCKET with type t := t -end - -let flow_handler (type t tag) (module X : FLOW with type t = t and type tag = tag) : (t, _) Eio.Resource.handler = - Eio.Resource.handler @@ - Eio.Resource.bindings (Eio.Net.Pi.stream_socket (module X)) @ - Eio.Resource.bindings (Eio.File.Pi.rw (module X)) @ [ - H (Resource.T, X.fd); - H (Stream_socket, (module X)); - ] - -module type DATAGRAM_SOCKET = sig - include Eio.Net.Pi.DATAGRAM_SOCKET - - val fd : t -> Fd.t -end - -let datagram_handler (type t tag) (module X : DATAGRAM_SOCKET with type t = t and type tag = tag) : (t, _) Eio.Resource.handler = - Eio.Resource.handler @@ - Eio.Resource.bindings (Eio.Net.Pi.datagram_socket (module X)) @ [ - H (Resource.T, X.fd); - ] - -module type LISTENING_SOCKET = sig - include Eio.Net.Pi.LISTENING_SOCKET - - val fd : t -> Fd.t -end - -let listening_socket_handler (type t tag) (module X : LISTENING_SOCKET with type t = t and type tag = tag) - : (t, _) Eio.Resource.handler = - Eio.Resource.handler @@ - Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module X)) @ [ - H (Resource.T, X.fd); - ] +open Eio.Std + +module type STREAM_SOCKET = sig + include Eio.Net.Pi.STREAM_SOCKET + + val send_msg : t -> fds:Fd.t list -> Cstruct.t list -> int + val recv_msg_with_fds : t -> sw:Switch.t -> max_fds:int -> Cstruct.t list -> int * Fd.t list + + val fd : t -> Fd.t +end + +type (_, _, _) Eio.Resource.pi += + | Stream_socket : ('t, (module STREAM_SOCKET with type t = 't), [> `Platform of [> `Unix] | `Socket | `Stream]) Eio.Resource.pi + +module type FLOW = sig + include Eio.File.Pi.WRITE + include STREAM_SOCKET with type t := t +end + +let flow_handler (type t tag) (module X : FLOW with type t = t and type tag = tag) : (t, _) Eio.Resource.handler = + Eio.Resource.handler @@ + Eio.Resource.bindings (Eio.Net.Pi.stream_socket (module X)) @ + Eio.Resource.bindings (Eio.File.Pi.rw (module X)) @ [ + H (Resource.T, X.fd); + H (Stream_socket, (module X)); + ] + +module type DATAGRAM_SOCKET = sig + include Eio.Net.Pi.DATAGRAM_SOCKET + + val fd : t -> Fd.t +end + +let datagram_handler (type t tag) (module X : DATAGRAM_SOCKET with type t = t and type tag = tag) : (t, _) Eio.Resource.handler = + Eio.Resource.handler @@ + Eio.Resource.bindings (Eio.Net.Pi.datagram_socket (module X)) @ [ + H (Resource.T, X.fd); + ] + +module type LISTENING_SOCKET = sig + include Eio.Net.Pi.LISTENING_SOCKET + + val fd : t -> Fd.t +end + +let listening_socket_handler (type t tag) (module X : LISTENING_SOCKET with type t = t and type tag = tag) + : (t, _) Eio.Resource.handler = + Eio.Resource.handler @@ + Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module X)) @ [ + H (Resource.T, X.fd); + ] diff --git a/lib_eio/unix/pi.mli b/lib_eio/unix/pi.mli index 0fe366d6f..6ca92d1f1 100644 --- a/lib_eio/unix/pi.mli +++ b/lib_eio/unix/pi.mli @@ -1,42 +1,42 @@ -open Eio.Std - -module type STREAM_SOCKET = sig - include Eio.Net.Pi.STREAM_SOCKET - - val send_msg : t -> fds:Fd.t list -> Cstruct.t list -> int - val recv_msg_with_fds : t -> sw:Switch.t -> max_fds:int -> Cstruct.t list -> int * Fd.t list - - val fd : t -> Fd.t -end - -type (_, _, _) Eio.Resource.pi += - | Stream_socket : ('t, (module STREAM_SOCKET with type t = 't), [> `Platform of [> `Unix] | `Socket | `Stream]) Eio.Resource.pi - -module type FLOW = sig - include Eio.File.Pi.WRITE - include STREAM_SOCKET with type t := t -end - -val flow_handler : - (module FLOW with type t = 't and type tag = 'tag) -> - ('t, [`Unix_fd | 'tag Eio.Net.stream_socket_ty | Eio.File.rw_ty]) Eio.Resource.handler - -module type DATAGRAM_SOCKET = sig - include Eio.Net.Pi.DATAGRAM_SOCKET - - val fd : t -> Fd.t -end - -val datagram_handler : - (module DATAGRAM_SOCKET with type t = 't and type tag = 'tag) -> - ('t, [`Unix_fd | 'tag Eio.Net.datagram_socket_ty]) Eio.Resource.handler - -module type LISTENING_SOCKET = sig - include Eio.Net.Pi.LISTENING_SOCKET - - val fd : t -> Fd.t -end - -val listening_socket_handler : - (module LISTENING_SOCKET with type t = 't and type tag = 'tag) -> - ('t, [`Unix_fd | 'tag Eio.Net.listening_socket_ty]) Eio.Resource.handler +open Eio.Std + +module type STREAM_SOCKET = sig + include Eio.Net.Pi.STREAM_SOCKET + + val send_msg : t -> fds:Fd.t list -> Cstruct.t list -> int + val recv_msg_with_fds : t -> sw:Switch.t -> max_fds:int -> Cstruct.t list -> int * Fd.t list + + val fd : t -> Fd.t +end + +type (_, _, _) Eio.Resource.pi += + | Stream_socket : ('t, (module STREAM_SOCKET with type t = 't), [> `Platform of [> `Unix] | `Socket | `Stream]) Eio.Resource.pi + +module type FLOW = sig + include Eio.File.Pi.WRITE + include STREAM_SOCKET with type t := t +end + +val flow_handler : + (module FLOW with type t = 't and type tag = 'tag) -> + ('t, [`Unix_fd | 'tag Eio.Net.stream_socket_ty | Eio.File.rw_ty]) Eio.Resource.handler + +module type DATAGRAM_SOCKET = sig + include Eio.Net.Pi.DATAGRAM_SOCKET + + val fd : t -> Fd.t +end + +val datagram_handler : + (module DATAGRAM_SOCKET with type t = 't and type tag = 'tag) -> + ('t, [`Unix_fd | 'tag Eio.Net.datagram_socket_ty]) Eio.Resource.handler + +module type LISTENING_SOCKET = sig + include Eio.Net.Pi.LISTENING_SOCKET + + val fd : t -> Fd.t +end + +val listening_socket_handler : + (module LISTENING_SOCKET with type t = 't and type tag = 'tag) -> + ('t, [`Unix_fd | 'tag Eio.Net.listening_socket_ty]) Eio.Resource.handler diff --git a/lib_eio/unix/primitives.h b/lib_eio/unix/primitives.h index d43166a92..0b2ead98f 100644 --- a/lib_eio/unix/primitives.h +++ b/lib_eio/unix/primitives.h @@ -1,12 +1,12 @@ -/* AUTOGENERATED FILE, DO NOT EDIT */ -#define CAML_NAME_SPACE -#define _GNU_SOURCE -#include -CAMLprim value eio_unix_make_string_array(value); -CAMLprim value eio_unix_fork_execve(value); -CAMLprim value eio_unix_fork_chdir(value); -CAMLprim value eio_unix_fork_fchdir(value); -CAMLprim value eio_unix_fork_dups(value); -CAMLprim value eio_unix_cap_enter(value); -CAMLprim value eio_unix_readlinkat(value, value, value); -CAMLprim value eio_unix_is_blocking(value); +/* AUTOGENERATED FILE, DO NOT EDIT */ +#define CAML_NAME_SPACE +#define _GNU_SOURCE +#include +CAMLprim value eio_unix_make_string_array(value); +CAMLprim value eio_unix_fork_execve(value); +CAMLprim value eio_unix_fork_chdir(value); +CAMLprim value eio_unix_fork_fchdir(value); +CAMLprim value eio_unix_fork_dups(value); +CAMLprim value eio_unix_cap_enter(value); +CAMLprim value eio_unix_readlinkat(value, value, value); +CAMLprim value eio_unix_is_blocking(value); diff --git a/lib_eio/unix/private.ml b/lib_eio/unix/private.ml index 961990766..ab34e1152 100644 --- a/lib_eio/unix/private.ml +++ b/lib_eio/unix/private.ml @@ -1,35 +1,35 @@ -[@@@alert "-unstable"] - -open Eio.Std -open Types - -type _ Effect.t += - | Await_readable : Unix.file_descr -> unit Effect.t - | Await_writable : Unix.file_descr -> unit Effect.t - | Get_monotonic_clock : Eio.Time.Mono.ty r Effect.t - | Pipe : Switch.t -> (source_ty r * sink_ty r) Effect.t - -let await_readable fd = Effect.perform (Await_readable fd) -let await_writable fd = Effect.perform (Await_writable fd) - -let pipe sw = Effect.perform (Pipe sw) - -module Rcfd = Rcfd -module Fork_action = Fork_action -module Thread_pool = Thread_pool - -external eio_readlinkat : Unix.file_descr -> string -> Cstruct.t -> int = "eio_unix_readlinkat" - -let read_link_unix fd path = - match fd with - | None -> Unix.readlink path - | Some fd -> - let rec aux size = - let buf = Cstruct.create_unsafe size in - let len = eio_readlinkat fd path buf in - if len < size then Cstruct.to_string ~len buf - else aux (size * 4) - in - aux 1024 - -let read_link fd path = Fd.use_exn_opt "readlink" fd (fun fd -> read_link_unix fd path) +[@@@alert "-unstable"] + +open Eio.Std +open Types + +type _ Effect.t += + | Await_readable : Unix.file_descr -> unit Effect.t + | Await_writable : Unix.file_descr -> unit Effect.t + | Get_monotonic_clock : Eio.Time.Mono.ty r Effect.t + | Pipe : Switch.t -> (source_ty r * sink_ty r) Effect.t + +let await_readable fd = Effect.perform (Await_readable fd) +let await_writable fd = Effect.perform (Await_writable fd) + +let pipe sw = Effect.perform (Pipe sw) + +module Rcfd = Rcfd +module Fork_action = Fork_action +module Thread_pool = Thread_pool + +external eio_readlinkat : Unix.file_descr -> string -> Cstruct.t -> int = "eio_unix_readlinkat" + +let read_link_unix fd path = + match fd with + | None -> Unix.readlink path + | Some fd -> + let rec aux size = + let buf = Cstruct.create_unsafe size in + let len = eio_readlinkat fd path buf in + if len < size then Cstruct.to_string ~len buf + else aux (size * 4) + in + aux 1024 + +let read_link fd path = Fd.use_exn_opt "readlink" fd (fun fd -> read_link_unix fd path) diff --git a/lib_eio/unix/process.ml b/lib_eio/unix/process.ml index 4cf9b1eac..d96197c97 100644 --- a/lib_eio/unix/process.ml +++ b/lib_eio/unix/process.ml @@ -1,150 +1,150 @@ -open Eio.Std - -let resolve_program name = - if Filename.is_implicit name then ( - Sys.getenv_opt "PATH" - |> Option.value ~default:"/bin:/usr/bin" - |> String.split_on_char ':' - |> List.find_map (fun dir -> - let p = Filename.concat dir name in - if Sys.file_exists p then Some p else None - ) - ) else if Sys.file_exists name then ( - Some name - ) else None - -let read_of_fd ~sw ~default ~to_close = function - | None -> default - | Some f -> - match Resource.fd_opt f with - | Some fd -> fd - | None -> - let r, w = Private.pipe sw in - Fiber.fork ~sw (fun () -> - Eio.Flow.copy f w; - Eio.Flow.close w - ); - let r = Resource.fd r in - to_close := r :: !to_close; - r - -let write_of_fd ~sw ~default ~to_close = function - | None -> default - | Some f -> - match Resource.fd_opt f with - | Some fd -> fd - | None -> - let r, w = Private.pipe sw in - Fiber.fork ~sw (fun () -> - Eio.Flow.copy r f; - Eio.Flow.close r - ); - let w = Resource.fd w in - to_close := w :: !to_close; - w - -let with_close_list fn = - let to_close = ref [] in - let close () = - List.iter Fd.close !to_close - in - match fn to_close with - | x -> close (); x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - close (); - Printexc.raise_with_backtrace ex bt - -let get_executable ~args = function - | Some exe -> exe - | None -> - match args with - | [] -> invalid_arg "Arguments list is empty and no executable given!" - | (x :: _) -> - match resolve_program x with - | Some x -> x - | None -> raise (Eio.Process.err (Executable_not_found x)) - -let get_env = function - | Some e -> e - | None -> Unix.environment () - -type ty = [ `Generic | `Unix ] Eio.Process.ty -type 'a t = ([> ty] as 'a) r - -type mgr_ty = [`Generic | `Unix] Eio.Process.mgr_ty -type 'a mgr = ([> mgr_ty] as 'a) r - -module Pi = struct - module type MGR = sig - include Eio.Process.Pi.MGR - - val spawn_unix : - t -> - sw:Switch.t -> - ?cwd:Eio.Fs.dir_ty Eio.Path.t -> - env:string array -> - fds:(int * Fd.t * Fork_action.blocking) list -> - executable:string -> - string list -> - ty r - end - - type (_, _, _) Eio.Resource.pi += - | Mgr_unix : ('t, (module MGR with type t = 't), [> mgr_ty]) Eio.Resource.pi - - let mgr_unix (type t tag) (module X : MGR with type t = t and type tag = tag) = - Eio.Resource.handler [ - H (Eio.Process.Pi.Mgr, (module X)); - H (Mgr_unix, (module X)); - ] -end - -module Make_mgr (X : sig - type t - - val spawn_unix : - t -> - sw:Switch.t -> - ?cwd:Eio.Fs.dir_ty Eio.Path.t -> - env:string array -> - fds:(int * Fd.t * Fork_action.blocking) list -> - executable:string -> - string list -> - ty r -end) = struct - type t = X.t - - type tag = [ `Generic | `Unix ] - - let pipe _ ~sw = - (Private.pipe sw :> ([Eio.Resource.close_ty | Eio.Flow.source_ty] r * - [Eio.Resource.close_ty | Eio.Flow.sink_ty] r)) - - let spawn v ~sw ?cwd ?stdin ?stdout ?stderr ?env ?executable args = - let executable = get_executable executable ~args in - let env = get_env env in - with_close_list @@ fun to_close -> - let stdin_fd = read_of_fd ~sw stdin ~default:Fd.stdin ~to_close in - let stdout_fd = write_of_fd ~sw stdout ~default:Fd.stdout ~to_close in - let stderr_fd = write_of_fd ~sw stderr ~default:Fd.stderr ~to_close in - let fds = [ - 0, stdin_fd, `Blocking; - 1, stdout_fd, `Blocking; - 2, stderr_fd, `Blocking; - ] in - X.spawn_unix v ~sw ?cwd ~env ~fds ~executable args - - let spawn_unix = X.spawn_unix -end - -let spawn_unix ~sw (Eio.Resource.T (v, ops)) ?cwd ~fds ?env ?executable args = - let module X = (val (Eio.Resource.get ops Pi.Mgr_unix)) in - let executable = get_executable executable ~args in - let env = get_env env in - X.spawn_unix v ~sw ?cwd ~fds ~env ~executable args - -let sigchld = Eio.Condition.create () - -let install_sigchld_handler () = - Sys.(set_signal sigchld) (Signal_handle (fun (_:int) -> Eio.Condition.broadcast sigchld)) +open Eio.Std + +let resolve_program name = + if Filename.is_implicit name then ( + Sys.getenv_opt "PATH" + |> Option.value ~default:"/bin:/usr/bin" + |> String.split_on_char ':' + |> List.find_map (fun dir -> + let p = Filename.concat dir name in + if Sys.file_exists p then Some p else None + ) + ) else if Sys.file_exists name then ( + Some name + ) else None + +let read_of_fd ~sw ~default ~to_close = function + | None -> default + | Some f -> + match Resource.fd_opt f with + | Some fd -> fd + | None -> + let r, w = Private.pipe sw in + Fiber.fork ~sw (fun () -> + Eio.Flow.copy f w; + Eio.Flow.close w + ); + let r = Resource.fd r in + to_close := r :: !to_close; + r + +let write_of_fd ~sw ~default ~to_close = function + | None -> default + | Some f -> + match Resource.fd_opt f with + | Some fd -> fd + | None -> + let r, w = Private.pipe sw in + Fiber.fork ~sw (fun () -> + Eio.Flow.copy r f; + Eio.Flow.close r + ); + let w = Resource.fd w in + to_close := w :: !to_close; + w + +let with_close_list fn = + let to_close = ref [] in + let close () = + List.iter Fd.close !to_close + in + match fn to_close with + | x -> close (); x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + close (); + Printexc.raise_with_backtrace ex bt + +let get_executable ~args = function + | Some exe -> exe + | None -> + match args with + | [] -> invalid_arg "Arguments list is empty and no executable given!" + | (x :: _) -> + match resolve_program x with + | Some x -> x + | None -> raise (Eio.Process.err (Executable_not_found x)) + +let get_env = function + | Some e -> e + | None -> Unix.environment () + +type ty = [ `Generic | `Unix ] Eio.Process.ty +type 'a t = ([> ty] as 'a) r + +type mgr_ty = [`Generic | `Unix] Eio.Process.mgr_ty +type 'a mgr = ([> mgr_ty] as 'a) r + +module Pi = struct + module type MGR = sig + include Eio.Process.Pi.MGR + + val spawn_unix : + t -> + sw:Switch.t -> + ?cwd:Eio.Fs.dir_ty Eio.Path.t -> + env:string array -> + fds:(int * Fd.t * Fork_action.blocking) list -> + executable:string -> + string list -> + ty r + end + + type (_, _, _) Eio.Resource.pi += + | Mgr_unix : ('t, (module MGR with type t = 't), [> mgr_ty]) Eio.Resource.pi + + let mgr_unix (type t tag) (module X : MGR with type t = t and type tag = tag) = + Eio.Resource.handler [ + H (Eio.Process.Pi.Mgr, (module X)); + H (Mgr_unix, (module X)); + ] +end + +module Make_mgr (X : sig + type t + + val spawn_unix : + t -> + sw:Switch.t -> + ?cwd:Eio.Fs.dir_ty Eio.Path.t -> + env:string array -> + fds:(int * Fd.t * Fork_action.blocking) list -> + executable:string -> + string list -> + ty r +end) = struct + type t = X.t + + type tag = [ `Generic | `Unix ] + + let pipe _ ~sw = + (Private.pipe sw :> ([Eio.Resource.close_ty | Eio.Flow.source_ty] r * + [Eio.Resource.close_ty | Eio.Flow.sink_ty] r)) + + let spawn v ~sw ?cwd ?stdin ?stdout ?stderr ?env ?executable args = + let executable = get_executable executable ~args in + let env = get_env env in + with_close_list @@ fun to_close -> + let stdin_fd = read_of_fd ~sw stdin ~default:Fd.stdin ~to_close in + let stdout_fd = write_of_fd ~sw stdout ~default:Fd.stdout ~to_close in + let stderr_fd = write_of_fd ~sw stderr ~default:Fd.stderr ~to_close in + let fds = [ + 0, stdin_fd, `Blocking; + 1, stdout_fd, `Blocking; + 2, stderr_fd, `Blocking; + ] in + X.spawn_unix v ~sw ?cwd ~env ~fds ~executable args + + let spawn_unix = X.spawn_unix +end + +let spawn_unix ~sw (Eio.Resource.T (v, ops)) ?cwd ~fds ?env ?executable args = + let module X = (val (Eio.Resource.get ops Pi.Mgr_unix)) in + let executable = get_executable executable ~args in + let env = get_env env in + X.spawn_unix v ~sw ?cwd ~fds ~env ~executable args + +let sigchld = Eio.Condition.create () + +let install_sigchld_handler () = + Sys.(set_signal sigchld) (Signal_handle (fun (_:int) -> Eio.Condition.broadcast sigchld)) diff --git a/lib_eio/unix/process.mli b/lib_eio/unix/process.mli index a5745a317..6dbf1fd16 100644 --- a/lib_eio/unix/process.mli +++ b/lib_eio/unix/process.mli @@ -1,76 +1,76 @@ -(** This extends the {!Eio.Process} API with more control over file-descriptors. *) - -open Eio.Std - -(** {2 Types} - - These extend the types in {!Eio.Process} with support for file descriptors. *) - -type ty = [ `Generic | `Unix ] Eio.Process.ty -type 'a t = ([> ty] as 'a) r - -type mgr_ty = [`Generic | `Unix] Eio.Process.mgr_ty -type 'a mgr = ([> mgr_ty] as 'a) r - -module Pi : sig - module type MGR = sig - include Eio.Process.Pi.MGR - - val spawn_unix : - t -> - sw:Switch.t -> - ?cwd:Eio.Fs.dir_ty Eio.Path.t -> - env:string array -> - fds:(int * Fd.t * Fork_action.blocking) list -> - executable:string -> - string list -> - ty r - end - - type (_, _, _) Eio.Resource.pi += - | Mgr_unix : ('t, (module MGR with type t = 't), [> mgr_ty]) Eio.Resource.pi - - val mgr_unix : - (module MGR with type t = 't and type tag = 'tag) -> - ('t, 'tag Eio.Process.mgr_ty) Eio.Resource.handler -end - -module Make_mgr (X : sig - type t - - val spawn_unix : - t -> - sw:Switch.t -> - ?cwd:Eio.Fs.dir_ty Eio.Path.t -> - env:string array -> - fds:(int * Fd.t * Fork_action.blocking) list -> - executable:string -> - string list -> - ty r -end) : Pi.MGR with type t = X.t and type tag = [`Generic | `Unix] - -val spawn_unix : - sw:Switch.t -> - _ mgr -> - ?cwd:Eio.Fs.dir_ty Eio.Path.t -> - fds:(int * Fd.t * Fork_action.blocking) list -> - ?env:string array -> - ?executable:string -> - string list -> - ty r -(** [spawn_unix ~sw mgr ~fds args] spawns a child process running the command [args]. - - The arguments are as for {!Eio.Process.spawn}, - except that it takes a list of FD mappings for {!Fork_action.inherit_fds} - directly, rather than just flows for the standard streams. *) - -val sigchld : Eio.Condition.t -(** {b If} an Eio backend installs a SIGCHLD handler, the handler will broadcast on this condition. - - This allows non-Eio libraries (such as Lwt) to share its signal handler. - - Note: Not all backends install a handler (e.g. eio_linux uses process descriptors instead), - so be sure to call {!install_sigchld_handler} if you need to use this. *) - -val install_sigchld_handler : unit -> unit -(** [install_sigchld_handler ()] sets the signal handler for SIGCHLD to broadcast {!sigchld}. *) +(** This extends the {!Eio.Process} API with more control over file-descriptors. *) + +open Eio.Std + +(** {2 Types} + + These extend the types in {!Eio.Process} with support for file descriptors. *) + +type ty = [ `Generic | `Unix ] Eio.Process.ty +type 'a t = ([> ty] as 'a) r + +type mgr_ty = [`Generic | `Unix] Eio.Process.mgr_ty +type 'a mgr = ([> mgr_ty] as 'a) r + +module Pi : sig + module type MGR = sig + include Eio.Process.Pi.MGR + + val spawn_unix : + t -> + sw:Switch.t -> + ?cwd:Eio.Fs.dir_ty Eio.Path.t -> + env:string array -> + fds:(int * Fd.t * Fork_action.blocking) list -> + executable:string -> + string list -> + ty r + end + + type (_, _, _) Eio.Resource.pi += + | Mgr_unix : ('t, (module MGR with type t = 't), [> mgr_ty]) Eio.Resource.pi + + val mgr_unix : + (module MGR with type t = 't and type tag = 'tag) -> + ('t, 'tag Eio.Process.mgr_ty) Eio.Resource.handler +end + +module Make_mgr (X : sig + type t + + val spawn_unix : + t -> + sw:Switch.t -> + ?cwd:Eio.Fs.dir_ty Eio.Path.t -> + env:string array -> + fds:(int * Fd.t * Fork_action.blocking) list -> + executable:string -> + string list -> + ty r +end) : Pi.MGR with type t = X.t and type tag = [`Generic | `Unix] + +val spawn_unix : + sw:Switch.t -> + _ mgr -> + ?cwd:Eio.Fs.dir_ty Eio.Path.t -> + fds:(int * Fd.t * Fork_action.blocking) list -> + ?env:string array -> + ?executable:string -> + string list -> + ty r +(** [spawn_unix ~sw mgr ~fds args] spawns a child process running the command [args]. + + The arguments are as for {!Eio.Process.spawn}, + except that it takes a list of FD mappings for {!Fork_action.inherit_fds} + directly, rather than just flows for the standard streams. *) + +val sigchld : Eio.Condition.t +(** {b If} an Eio backend installs a SIGCHLD handler, the handler will broadcast on this condition. + + This allows non-Eio libraries (such as Lwt) to share its signal handler. + + Note: Not all backends install a handler (e.g. eio_linux uses process descriptors instead), + so be sure to call {!install_sigchld_handler} if you need to use this. *) + +val install_sigchld_handler : unit -> unit +(** [install_sigchld_handler ()] sets the signal handler for SIGCHLD to broadcast {!sigchld}. *) diff --git a/lib_eio/unix/rcfd.ml b/lib_eio/unix/rcfd.ml index ee4455bf4..c3ed95e2c 100644 --- a/lib_eio/unix/rcfd.ml +++ b/lib_eio/unix/rcfd.ml @@ -1,185 +1,185 @@ -(* To prevent races closing FDs, we do some ref-counting. - - Logically, the states of the wrapper for an FD [x] are: - - - open : the FD is available for use. - - closing/users : no further operations can start, but some are still in progress. - - closing/no-users : all operations have finished. - - closing/closed : we no longer own the FD. - - We start by dividing ownership of [x] into [max_int] shares - (enough shares for every sys-thread to take one). - Having a fractional share (not 0 or 1) means you can use [x] but not close it. - - In the [open] and [closing/users] states, [t] owns the fraction - [(max_int - ops) / max_int] of [x]. - - In [closing/no-users], [t] owns all of [x]. - - Initially, [t] is in the [open] state and [ops = 0]. - - If you increment [ops] in [open] or [closing/users], you get one share and can use the FD - (though in [closing/users] you should immediately return it). - When you decrement [ops] in these cases, you give back your share and must not use the FD further. - - If you increment/decrement when in the state [closing/no-users] or [closing/closed], - you do not get/return a share. - - A fiber can call {!close} to move from [open] at any time. - If there are operations in progress when it does this, it transitions to [closing/users]. - Otherwise, it goes directly to [closing/no-users]. - The fiber that does this is known as the "closing fiber" - and is responsible for finishing the close. - - We move from [closing/users] to [closing/no-users] when [ops] becomes 0 - (and [t] therefore owns all shares of [x]). - [ops] may continue to change after this, but we never return to [closing/users] - or give any user a share of [x] after this. - - From [closing/no-users], we transition to [closing/closed], - transferring the now-full ownership of [x] to the closing fiber. - - In reality, the three [closing/*] states are represented by the single constructor [Closing], - and the code must work whatever the true state might be. *) - -type state = - | Open of Unix.file_descr - | Closing of (unit -> unit) (* Function is called when [ops] becomes 0. *) - -type t = { - ops : int Atomic.t; - fd : state Atomic.t; -} - -let fully_closed = Closing ignore (* Used for [closing/closed] *) - -let put t = - let old = Atomic.fetch_and_add t.ops (-1) in - if old = 1 then ( - (* We decremented [ops] from one to zero. We may need to notify the closer. *) - match Atomic.get t.fd with - | Open _ -> () (* The fast path. We're not closing. *) - | Closing no_users as prev -> - (* There are four possibilities for the state when we did the decrement: - - open: But it got closed after that. There could be new active users by now. - - closing/users: We were the last user and transitioned to closing/no-users. - We need to notify the closer, or make sure someone else will do it later. - - closing/no-users: We might need to notify, since a previous thread that reached zero - might have then seen [ops > 0] and deferred it to us. - - closing/closed: No need to do anything, but notifying is harmless. - *) - if Atomic.get t.ops > 0 then () (* Someone else will deal with it. *) - else if Atomic.compare_and_set t.fd prev fully_closed then ( - (* We observed [t.ops = 0] after closing, so we were then at either [closing/no-users] - or [closing/closed], and we're now certainly at [closing/closed]. - If it was [closing/no-users] then we now own the FD, which we pass to the closer. - If it was [closing/closed] then we don't, but [no_users] is [ignore] anyway. *) - no_users () - ) else ( - (* Someone else notified the closer first. We're now in [closing/closed]. *) - ) - ) else ( - assert (old > 1) - ) - -let get t = - Atomic.incr t.ops; - (* If the state was [open] or [closing/users] then we now own 1 share of the FD. *) - match Atomic.get t.fd with - | Open fd -> - (* The state was [open]. Give the share that we took to our caller. *) - Some fd - | Closing _ -> - (* We want to close [t], so don't start a new operation. - If the state was [open] or [closing/users] when we incremented [ops] then - we return the share we took to [t] (which cannot now be [closing/no-users] as we are a user). - Otherwise, it was [closing/no-users] or [closing/closed], and still is one of those. *) - put t; - None - -let close_fd fd = - Eio.Private.Trace.with_span "close" (fun () -> Unix.close fd) - -(* Note: we could simplify this a bit by incrementing [t.ops], as [remove] does. - However, that makes dscheck too slow. *) -let close t = - match Atomic.get t.fd with - | Closing _ -> - (* Another caller closed [t] before us. *) - false - | Open fd as prev -> - let next = Closing (fun () -> close_fd fd) in - if Atomic.compare_and_set t.fd prev next then ( - (* We just transitioned from [open] to [closing/users] or [closing/no-users]. - We are now the closer. *) - if Atomic.get t.ops = 0 && Atomic.compare_and_set t.fd next fully_closed then ( - (* We were in [closing/no-users] and are now in [closing/closed]. - We own the FD (and our original callback will never be called). *) - close_fd fd - ) else ( - (* The [next] callback remained installed and there is nothing left for us to do: - - If [t.ops] was non-zero, another thread will eventually return it to zero and call our callback. - - If the CAS failed, then another thread is invoking our callback. *) - ); - true - ) else ( - (* Another domain became the closer first. *) - false - ) - -let remove t = - Atomic.incr t.ops; - match Atomic.get t.fd with - | Closing _ -> - (* Another domain is dealing with it. *) - put t; - None - | Open fd as prev -> - Eio.Private.Suspend.enter_unchecked "Rcfd.remove" (fun _ctx enqueue -> - if Atomic.compare_and_set t.fd prev (Closing (fun () -> enqueue (Ok (Some fd)))) then ( - (* We transitioned from [open] to [closing/users]. We are the closer. *) - put t - ) else ( - (* Another domain is handling the close instead. *) - put t; - enqueue (Ok (None)) - ) - ) - -let make fd = - { - ops = Atomic.make 0; - fd = Atomic.make (Open fd); - } - -let is_open t = - match Atomic.get t.fd with - | Open _ -> true - | Closing _ -> false - -let use ~if_closed t f = - match get t with - | None -> if_closed () - | Some fd -> - match f fd with - | r -> put t; r - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - put t; - Printexc.raise_with_backtrace ex bt - -let peek t = - match Atomic.get t.fd with - | Open fd -> fd - | Closing _ -> failwith "FD already closed!" - -let pp f t = - match Atomic.get t.fd with - | Closing _ -> Fmt.string f "(closed FD)" - | Open fd -> - match Sys.os_type with - | "Unix" -> - let id : int = Obj.magic (fd : Unix.file_descr) in - Fmt.pf f "FD-%d" id - | _ -> - Fmt.string f "(FD)" +(* To prevent races closing FDs, we do some ref-counting. + + Logically, the states of the wrapper for an FD [x] are: + + - open : the FD is available for use. + - closing/users : no further operations can start, but some are still in progress. + - closing/no-users : all operations have finished. + - closing/closed : we no longer own the FD. + + We start by dividing ownership of [x] into [max_int] shares + (enough shares for every sys-thread to take one). + Having a fractional share (not 0 or 1) means you can use [x] but not close it. + + In the [open] and [closing/users] states, [t] owns the fraction + [(max_int - ops) / max_int] of [x]. + + In [closing/no-users], [t] owns all of [x]. + + Initially, [t] is in the [open] state and [ops = 0]. + + If you increment [ops] in [open] or [closing/users], you get one share and can use the FD + (though in [closing/users] you should immediately return it). + When you decrement [ops] in these cases, you give back your share and must not use the FD further. + + If you increment/decrement when in the state [closing/no-users] or [closing/closed], + you do not get/return a share. + + A fiber can call {!close} to move from [open] at any time. + If there are operations in progress when it does this, it transitions to [closing/users]. + Otherwise, it goes directly to [closing/no-users]. + The fiber that does this is known as the "closing fiber" + and is responsible for finishing the close. + + We move from [closing/users] to [closing/no-users] when [ops] becomes 0 + (and [t] therefore owns all shares of [x]). + [ops] may continue to change after this, but we never return to [closing/users] + or give any user a share of [x] after this. + + From [closing/no-users], we transition to [closing/closed], + transferring the now-full ownership of [x] to the closing fiber. + + In reality, the three [closing/*] states are represented by the single constructor [Closing], + and the code must work whatever the true state might be. *) + +type state = + | Open of Unix.file_descr + | Closing of (unit -> unit) (* Function is called when [ops] becomes 0. *) + +type t = { + ops : int Atomic.t; + fd : state Atomic.t; +} + +let fully_closed = Closing ignore (* Used for [closing/closed] *) + +let put t = + let old = Atomic.fetch_and_add t.ops (-1) in + if old = 1 then ( + (* We decremented [ops] from one to zero. We may need to notify the closer. *) + match Atomic.get t.fd with + | Open _ -> () (* The fast path. We're not closing. *) + | Closing no_users as prev -> + (* There are four possibilities for the state when we did the decrement: + - open: But it got closed after that. There could be new active users by now. + - closing/users: We were the last user and transitioned to closing/no-users. + We need to notify the closer, or make sure someone else will do it later. + - closing/no-users: We might need to notify, since a previous thread that reached zero + might have then seen [ops > 0] and deferred it to us. + - closing/closed: No need to do anything, but notifying is harmless. + *) + if Atomic.get t.ops > 0 then () (* Someone else will deal with it. *) + else if Atomic.compare_and_set t.fd prev fully_closed then ( + (* We observed [t.ops = 0] after closing, so we were then at either [closing/no-users] + or [closing/closed], and we're now certainly at [closing/closed]. + If it was [closing/no-users] then we now own the FD, which we pass to the closer. + If it was [closing/closed] then we don't, but [no_users] is [ignore] anyway. *) + no_users () + ) else ( + (* Someone else notified the closer first. We're now in [closing/closed]. *) + ) + ) else ( + assert (old > 1) + ) + +let get t = + Atomic.incr t.ops; + (* If the state was [open] or [closing/users] then we now own 1 share of the FD. *) + match Atomic.get t.fd with + | Open fd -> + (* The state was [open]. Give the share that we took to our caller. *) + Some fd + | Closing _ -> + (* We want to close [t], so don't start a new operation. + If the state was [open] or [closing/users] when we incremented [ops] then + we return the share we took to [t] (which cannot now be [closing/no-users] as we are a user). + Otherwise, it was [closing/no-users] or [closing/closed], and still is one of those. *) + put t; + None + +let close_fd fd = + Eio.Private.Trace.with_span "close" (fun () -> Unix.close fd) + +(* Note: we could simplify this a bit by incrementing [t.ops], as [remove] does. + However, that makes dscheck too slow. *) +let close t = + match Atomic.get t.fd with + | Closing _ -> + (* Another caller closed [t] before us. *) + false + | Open fd as prev -> + let next = Closing (fun () -> close_fd fd) in + if Atomic.compare_and_set t.fd prev next then ( + (* We just transitioned from [open] to [closing/users] or [closing/no-users]. + We are now the closer. *) + if Atomic.get t.ops = 0 && Atomic.compare_and_set t.fd next fully_closed then ( + (* We were in [closing/no-users] and are now in [closing/closed]. + We own the FD (and our original callback will never be called). *) + close_fd fd + ) else ( + (* The [next] callback remained installed and there is nothing left for us to do: + - If [t.ops] was non-zero, another thread will eventually return it to zero and call our callback. + - If the CAS failed, then another thread is invoking our callback. *) + ); + true + ) else ( + (* Another domain became the closer first. *) + false + ) + +let remove t = + Atomic.incr t.ops; + match Atomic.get t.fd with + | Closing _ -> + (* Another domain is dealing with it. *) + put t; + None + | Open fd as prev -> + Eio.Private.Suspend.enter_unchecked "Rcfd.remove" (fun _ctx enqueue -> + if Atomic.compare_and_set t.fd prev (Closing (fun () -> enqueue (Ok (Some fd)))) then ( + (* We transitioned from [open] to [closing/users]. We are the closer. *) + put t + ) else ( + (* Another domain is handling the close instead. *) + put t; + enqueue (Ok (None)) + ) + ) + +let make fd = + { + ops = Atomic.make 0; + fd = Atomic.make (Open fd); + } + +let is_open t = + match Atomic.get t.fd with + | Open _ -> true + | Closing _ -> false + +let use ~if_closed t f = + match get t with + | None -> if_closed () + | Some fd -> + match f fd with + | r -> put t; r + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + put t; + Printexc.raise_with_backtrace ex bt + +let peek t = + match Atomic.get t.fd with + | Open fd -> fd + | Closing _ -> failwith "FD already closed!" + +let pp f t = + match Atomic.get t.fd with + | Closing _ -> Fmt.string f "(closed FD)" + | Open fd -> + match Sys.os_type with + | "Unix" -> + let id : int = Obj.magic (fd : Unix.file_descr) in + Fmt.pf f "FD-%d" id + | _ -> + Fmt.string f "(FD)" diff --git a/lib_eio/unix/rcfd.mli b/lib_eio/unix/rcfd.mli index 803b45fdd..a314c66c8 100644 --- a/lib_eio/unix/rcfd.mli +++ b/lib_eio/unix/rcfd.mli @@ -1,74 +1,74 @@ -(** A safe wrapper around [Unix.file_descr]. - - When FDs are shared between domains, there is the risk that one domain will try to use an FD - just as another domain is closing it. Then this can happen: - - + Domain A decides to write to FD 3, which it shares with domain B. - + Domain B closes FD 3. - + Domain C opens a new file, getting assigned FD 3 by the OS. - + Domain A writes to FD 3, corrupting domain C's file. - - This would break modularity, since the fibers in domains A and C may have no connection with each other. - - To prevent this, we keep a ref-count, tracking how many fibers are using the FD. - Wrap uses of the FD in {!use} to ensure that it won't be closed while you're using it. - - Calling {!close} while one or more operations are still in progress marks - the wrapper as closing (so that no futher operations can start); the last - operation to finish will close the underlying FD. *) - -type t - -val make : Unix.file_descr -> t -(** [let t = make fd] wraps [fd]. - - [t] takes ownership of [fd]. The caller is responsible for ensuring that {!close} - (or {!remove}) is called at least once in the future. *) - -val use : if_closed:(unit -> 'a) -> t -> (Unix.file_descr -> 'a) -> 'a -(** [use t fn ~if_closed] calls [fn fd], preventing [fd] from being closed until [fn] returns. - - [if_closed ()] is used if [t] is closed before we can increment the ref-count. - [use] can be used in parallel from multiple domains at the same time. - - This operation is lock-free and can be used safely from signal handlers, etc. *) - -val is_open : t -> bool -(** [is_open t] returns [true] until [t] has been marked as closing, after which it returns [false]. - - This is mostly useful inside the callback of {!use}, to test whether - another fiber has started closing [t] (in which case you may decide to stop early). *) - -val close : t -> bool -(** [close t] marks [t] as closed and arranges for its FD to be closed. - - If there are calls to {!use} in progress, the last one to finish will close the underlying FD. - Note that this function returns without waiting for the close to happen in that case. - - Returns [true] after successfully marking [t] as closing, or [false] if it was already marked. - - If you need to wait until the underlying FD is closed, use {!remove} and then close the FD yourself instead. *) - -val remove : t -> Unix.file_descr option -(** [remove t] closes [t] and returns the FD. - - It immediately marks [t] as closing (so no further operations can start) - and then waits until there are no further users. - - This operation suspends the calling fiber and so must run from an Eio fiber. - It does not allow itself to be cancelled, - since it takes ownership of the FD and that would be leaked if it aborted. - - If another fiber marks [t] as closing before [remove] can, it returns [None] immediately. *) - -val peek : t -> Unix.file_descr -(** [peek t] returns the file-descriptor without updating the ref-count. - - You must ensure that [t] isn't closed while using the result. - This is a dangerous operation and may be removed in the future. - - If [t] was closed, it instead raises an exception (if you're not sure when - [t] might get closed, you shouldn't be using this function). *) - -val pp : t Fmt.t -(** Displays the FD number. *) +(** A safe wrapper around [Unix.file_descr]. + + When FDs are shared between domains, there is the risk that one domain will try to use an FD + just as another domain is closing it. Then this can happen: + + + Domain A decides to write to FD 3, which it shares with domain B. + + Domain B closes FD 3. + + Domain C opens a new file, getting assigned FD 3 by the OS. + + Domain A writes to FD 3, corrupting domain C's file. + + This would break modularity, since the fibers in domains A and C may have no connection with each other. + + To prevent this, we keep a ref-count, tracking how many fibers are using the FD. + Wrap uses of the FD in {!use} to ensure that it won't be closed while you're using it. + + Calling {!close} while one or more operations are still in progress marks + the wrapper as closing (so that no futher operations can start); the last + operation to finish will close the underlying FD. *) + +type t + +val make : Unix.file_descr -> t +(** [let t = make fd] wraps [fd]. + + [t] takes ownership of [fd]. The caller is responsible for ensuring that {!close} + (or {!remove}) is called at least once in the future. *) + +val use : if_closed:(unit -> 'a) -> t -> (Unix.file_descr -> 'a) -> 'a +(** [use t fn ~if_closed] calls [fn fd], preventing [fd] from being closed until [fn] returns. + + [if_closed ()] is used if [t] is closed before we can increment the ref-count. + [use] can be used in parallel from multiple domains at the same time. + + This operation is lock-free and can be used safely from signal handlers, etc. *) + +val is_open : t -> bool +(** [is_open t] returns [true] until [t] has been marked as closing, after which it returns [false]. + + This is mostly useful inside the callback of {!use}, to test whether + another fiber has started closing [t] (in which case you may decide to stop early). *) + +val close : t -> bool +(** [close t] marks [t] as closed and arranges for its FD to be closed. + + If there are calls to {!use} in progress, the last one to finish will close the underlying FD. + Note that this function returns without waiting for the close to happen in that case. + + Returns [true] after successfully marking [t] as closing, or [false] if it was already marked. + + If you need to wait until the underlying FD is closed, use {!remove} and then close the FD yourself instead. *) + +val remove : t -> Unix.file_descr option +(** [remove t] closes [t] and returns the FD. + + It immediately marks [t] as closing (so no further operations can start) + and then waits until there are no further users. + + This operation suspends the calling fiber and so must run from an Eio fiber. + It does not allow itself to be cancelled, + since it takes ownership of the FD and that would be leaked if it aborted. + + If another fiber marks [t] as closing before [remove] can, it returns [None] immediately. *) + +val peek : t -> Unix.file_descr +(** [peek t] returns the file-descriptor without updating the ref-count. + + You must ensure that [t] isn't closed while using the result. + This is a dangerous operation and may be removed in the future. + + If [t] was closed, it instead raises an exception (if you're not sure when + [t] might get closed, you shouldn't be using this function). *) + +val pp : t Fmt.t +(** Displays the FD number. *) diff --git a/lib_eio/unix/resource.ml b/lib_eio/unix/resource.ml index a9fd32c3a..089ba695a 100644 --- a/lib_eio/unix/resource.ml +++ b/lib_eio/unix/resource.ml @@ -1,9 +1,9 @@ -type 'a t = ([> `Unix_fd] as 'a) Eio.Resource.t - -type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi -let fd (Eio.Resource.T (t, ops)) = Eio.Resource.get ops T t - -let fd_opt (Eio.Resource.T (t, ops)) = - match Eio.Resource.get_opt ops T with - | Some f -> Some (f t) - | None -> None +type 'a t = ([> `Unix_fd] as 'a) Eio.Resource.t + +type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi +let fd (Eio.Resource.T (t, ops)) = Eio.Resource.get ops T t + +let fd_opt (Eio.Resource.T (t, ops)) = + match Eio.Resource.get_opt ops T with + | Some f -> Some (f t) + | None -> None diff --git a/lib_eio/unix/stubs.c b/lib_eio/unix/stubs.c index 78572bf4f..4a0941c93 100644 --- a/lib_eio/unix/stubs.c +++ b/lib_eio/unix/stubs.c @@ -1,54 +1,54 @@ -#include "primitives.h" - -#include -#include -#include - -#include -#include -#include -#include - -static void caml_stat_free_preserving_errno(void *ptr) { - int saved = errno; - caml_stat_free(ptr); - errno = saved; -} - -CAMLprim value eio_unix_is_blocking(value v_fd) { - #ifdef _WIN32 - // We should not call this function from Windows - caml_unix_error(EOPNOTSUPP, "Unsupported blocking check on Windows", Nothing); - #else - int fd = Int_val(v_fd); - int r = fcntl(fd, F_GETFL, 0); - if (r == -1) - caml_uerror("fcntl", Nothing); - - return Val_bool((r & O_NONBLOCK) == 0); - #endif -} - -CAMLprim value eio_unix_readlinkat(value v_fd, value v_path, value v_cs) { - #ifdef _WIN32 - caml_unix_error(EOPNOTSUPP, "readlinkat not supported on Windows", v_path); - #else - CAMLparam2(v_path, v_cs); - char *path; - value v_ba = Field(v_cs, 0); - value v_off = Field(v_cs, 1); - value v_len = Field(v_cs, 2); - char *buf = (char *)Caml_ba_data_val(v_ba) + Long_val(v_off); - size_t buf_size = Long_val(v_len); - int fd = Int_val(v_fd); - int ret; - caml_unix_check_path(v_path, "readlinkat"); - path = caml_stat_strdup(String_val(v_path)); - caml_enter_blocking_section(); - ret = readlinkat(fd, path, buf, buf_size); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(path); - if (ret == -1) caml_uerror("readlinkat", v_path); - CAMLreturn(Val_int(ret)); - #endif -} +#include "primitives.h" + +#include +#include +#include + +#include +#include +#include +#include + +static void caml_stat_free_preserving_errno(void *ptr) { + int saved = errno; + caml_stat_free(ptr); + errno = saved; +} + +CAMLprim value eio_unix_is_blocking(value v_fd) { + #ifdef _WIN32 + // We should not call this function from Windows + caml_unix_error(EOPNOTSUPP, "Unsupported blocking check on Windows", Nothing); + #else + int fd = Int_val(v_fd); + int r = fcntl(fd, F_GETFL, 0); + if (r == -1) + caml_uerror("fcntl", Nothing); + + return Val_bool((r & O_NONBLOCK) == 0); + #endif +} + +CAMLprim value eio_unix_readlinkat(value v_fd, value v_path, value v_cs) { + #ifdef _WIN32 + caml_unix_error(EOPNOTSUPP, "readlinkat not supported on Windows", v_path); + #else + CAMLparam2(v_path, v_cs); + char *path; + value v_ba = Field(v_cs, 0); + value v_off = Field(v_cs, 1); + value v_len = Field(v_cs, 2); + char *buf = (char *)Caml_ba_data_val(v_ba) + Long_val(v_off); + size_t buf_size = Long_val(v_len); + int fd = Int_val(v_fd); + int ret; + caml_unix_check_path(v_path, "readlinkat"); + path = caml_stat_strdup(String_val(v_path)); + caml_enter_blocking_section(); + ret = readlinkat(fd, path, buf, buf_size); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(path); + if (ret == -1) caml_uerror("readlinkat", v_path); + CAMLreturn(Val_int(ret)); + #endif +} diff --git a/lib_eio/unix/thread_pool.ml b/lib_eio/unix/thread_pool.ml index c1700f11a..472955b57 100644 --- a/lib_eio/unix/thread_pool.ml +++ b/lib_eio/unix/thread_pool.ml @@ -1,134 +1,134 @@ -module Zzz = Eio_utils.Zzz - -type job = - | New - | Exit - | Job : { - fn : unit -> 'a; - enqueue : ('a, Eio.Exn.with_bt) result -> unit; - } -> job - -(* Mailbox with blocking semaphore *) -module Mailbox = struct - type t = { - available : Semaphore.Binary.t; - mutable cell : job; - } - - let create () = { available = Semaphore.Binary.make false; cell = New } - - let put mbox x = - (* The Semaphore contains an atomic frontier, - therefore [cell] does not need to be an atomic *) - mbox.cell <- x; - Semaphore.Binary.release mbox.available - - let take mbox = - Semaphore.Binary.acquire mbox.available; - mbox.cell -end - -module Free_pool = struct - type list = - | Empty - | Closed - | Free of Mailbox.t * list - - type t = list Atomic.t - - let rec close_list = function - | Free (x, xs) -> Mailbox.put x Exit; close_list xs - | Empty | Closed -> () - - let close t = - let items = Atomic.exchange t Closed in - close_list items - - let rec drop t = - match Atomic.get t with - | Closed | Empty -> () - | Free _ as items -> - if Atomic.compare_and_set t items Empty then close_list items - else drop t - - let rec put t mbox = - match Atomic.get t with - | Closed -> assert false - | (Empty | Free _) as current -> - let next = Free (mbox, current) in - if not (Atomic.compare_and_set t current next) then - put t mbox (* concurrent update, try again *) - - let make_thread t = - let mbox = Mailbox.create () in - let _thread : Thread.t = Thread.create (fun () -> - while true do - match Mailbox.take mbox with - | New -> assert false - | Exit -> raise Thread.Exit - | Job { fn; enqueue } -> - let result = - try Ok (fn ()) - with exn -> - let bt = Printexc.get_raw_backtrace () in - Error (exn, bt) - in - put t mbox; (* Ensure thread is in free-pool before enqueuing. *) - enqueue result - done - ) () - in - mbox - - let rec get_thread t = - match Atomic.get t with - | Closed -> invalid_arg "Thread pool closed!" - | Empty -> make_thread t - | Free (mbox, next) as current -> - if Atomic.compare_and_set t current next then mbox - else get_thread t (* concurrent update, try again *) -end - -type t = { - free : Free_pool.t; - sleep_q : Zzz.t; - mutable timeout : Zzz.Key.t option; -} - -type _ Effect.t += Run_in_systhread : (unit -> 'a) -> (('a, Eio.Exn.with_bt) result * t) Effect.t - -let terminate t = - Free_pool.close t.free; - Option.iter (fun key -> Zzz.remove t.sleep_q key; t.timeout <- None) t.timeout - -let create ~sleep_q = - { free = Atomic.make Free_pool.Empty; sleep_q; timeout = None } - -let run t fn = - match fn () with - | x -> terminate t; x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - terminate t; - Printexc.raise_with_backtrace ex bt - -let submit t ~ctx ~enqueue fn = - match Eio.Private.Fiber_context.get_error ctx with - | Some e -> enqueue (Error (e, Eio.Exn.empty_backtrace)) - | None -> - let mbox = Free_pool.get_thread t.free in - Mailbox.put mbox (Job { fn; enqueue }) - -let run_in_systhread ?(label="systhread") fn = - Eio.Private.Trace.suspend_fiber label; - let r, t = Effect.perform (Run_in_systhread fn) in - if t.timeout = None then ( - let time = - Mtime.add_span (Mtime_clock.now ()) Mtime.Span.(20 * ms) - |> Option.value ~default:Mtime.max_stamp - in - t.timeout <- Some (Zzz.add t.sleep_q time (Fn (fun () -> Free_pool.drop t.free; t.timeout <- None))) - ); - match r with - | Ok x -> x - | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt +module Zzz = Eio_utils.Zzz + +type job = + | New + | Exit + | Job : { + fn : unit -> 'a; + enqueue : ('a, Eio.Exn.with_bt) result -> unit; + } -> job + +(* Mailbox with blocking semaphore *) +module Mailbox = struct + type t = { + available : Semaphore.Binary.t; + mutable cell : job; + } + + let create () = { available = Semaphore.Binary.make false; cell = New } + + let put mbox x = + (* The Semaphore contains an atomic frontier, + therefore [cell] does not need to be an atomic *) + mbox.cell <- x; + Semaphore.Binary.release mbox.available + + let take mbox = + Semaphore.Binary.acquire mbox.available; + mbox.cell +end + +module Free_pool = struct + type list = + | Empty + | Closed + | Free of Mailbox.t * list + + type t = list Atomic.t + + let rec close_list = function + | Free (x, xs) -> Mailbox.put x Exit; close_list xs + | Empty | Closed -> () + + let close t = + let items = Atomic.exchange t Closed in + close_list items + + let rec drop t = + match Atomic.get t with + | Closed | Empty -> () + | Free _ as items -> + if Atomic.compare_and_set t items Empty then close_list items + else drop t + + let rec put t mbox = + match Atomic.get t with + | Closed -> assert false + | (Empty | Free _) as current -> + let next = Free (mbox, current) in + if not (Atomic.compare_and_set t current next) then + put t mbox (* concurrent update, try again *) + + let make_thread t = + let mbox = Mailbox.create () in + let _thread : Thread.t = Thread.create (fun () -> + while true do + match Mailbox.take mbox with + | New -> assert false + | Exit -> raise Thread.Exit + | Job { fn; enqueue } -> + let result = + try Ok (fn ()) + with exn -> + let bt = Printexc.get_raw_backtrace () in + Error (exn, bt) + in + put t mbox; (* Ensure thread is in free-pool before enqueuing. *) + enqueue result + done + ) () + in + mbox + + let rec get_thread t = + match Atomic.get t with + | Closed -> invalid_arg "Thread pool closed!" + | Empty -> make_thread t + | Free (mbox, next) as current -> + if Atomic.compare_and_set t current next then mbox + else get_thread t (* concurrent update, try again *) +end + +type t = { + free : Free_pool.t; + sleep_q : Zzz.t; + mutable timeout : Zzz.Key.t option; +} + +type _ Effect.t += Run_in_systhread : (unit -> 'a) -> (('a, Eio.Exn.with_bt) result * t) Effect.t + +let terminate t = + Free_pool.close t.free; + Option.iter (fun key -> Zzz.remove t.sleep_q key; t.timeout <- None) t.timeout + +let create ~sleep_q = + { free = Atomic.make Free_pool.Empty; sleep_q; timeout = None } + +let run t fn = + match fn () with + | x -> terminate t; x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + terminate t; + Printexc.raise_with_backtrace ex bt + +let submit t ~ctx ~enqueue fn = + match Eio.Private.Fiber_context.get_error ctx with + | Some e -> enqueue (Error (e, Eio.Exn.empty_backtrace)) + | None -> + let mbox = Free_pool.get_thread t.free in + Mailbox.put mbox (Job { fn; enqueue }) + +let run_in_systhread ?(label="systhread") fn = + Eio.Private.Trace.suspend_fiber label; + let r, t = Effect.perform (Run_in_systhread fn) in + if t.timeout = None then ( + let time = + Mtime.add_span (Mtime_clock.now ()) Mtime.Span.(20 * ms) + |> Option.value ~default:Mtime.max_stamp + in + t.timeout <- Some (Zzz.add t.sleep_q time (Fn (fun () -> Free_pool.drop t.free; t.timeout <- None))) + ); + match r with + | Ok x -> x + | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt diff --git a/lib_eio/unix/thread_pool.mli b/lib_eio/unix/thread_pool.mli index 0989d1bf8..b5dc932af 100644 --- a/lib_eio/unix/thread_pool.mli +++ b/lib_eio/unix/thread_pool.mli @@ -1,25 +1,25 @@ -(** A pool of systhreads, to avoid the overhead of creating a new thread for each operation. *) - -type t - -val create : sleep_q:Eio_utils.Zzz.t -> t -(** [create ~sleep_q] is a new thread pool. - - [sleep_q] is used to register a clean-up task to finish idle threads. *) - -val run : t -> (unit -> 'a) -> 'a -(** [run t fn] runs [fn ()] and then marks [t] as closed, releasing all idle threads. *) - -val submit : - t -> - ctx:Eio.Private.Fiber_context.t -> - enqueue:(('a, Eio.Exn.with_bt) result -> unit) -> - (unit -> 'a) -> - unit -(** [submit t ~ctx ~enqueue fn] starts running [fn] in a sys-thread, which uses [enqueue] to return the result. - - If [ctx] is already cancelled then the error is passed to [enqueue] immediately. - Systhreads do not respond to cancellation once running. *) - -type _ Effect.t += Run_in_systhread : (unit -> 'a) -> (('a, Eio.Exn.with_bt) result * t) Effect.t -val run_in_systhread : ?label:string -> (unit -> 'a) -> 'a +(** A pool of systhreads, to avoid the overhead of creating a new thread for each operation. *) + +type t + +val create : sleep_q:Eio_utils.Zzz.t -> t +(** [create ~sleep_q] is a new thread pool. + + [sleep_q] is used to register a clean-up task to finish idle threads. *) + +val run : t -> (unit -> 'a) -> 'a +(** [run t fn] runs [fn ()] and then marks [t] as closed, releasing all idle threads. *) + +val submit : + t -> + ctx:Eio.Private.Fiber_context.t -> + enqueue:(('a, Eio.Exn.with_bt) result -> unit) -> + (unit -> 'a) -> + unit +(** [submit t ~ctx ~enqueue fn] starts running [fn] in a sys-thread, which uses [enqueue] to return the result. + + If [ctx] is already cancelled then the error is passed to [enqueue] immediately. + Systhreads do not respond to cancellation once running. *) + +type _ Effect.t += Run_in_systhread : (unit -> 'a) -> (('a, Eio.Exn.with_bt) result * t) Effect.t +val run_in_systhread : ?label:string -> (unit -> 'a) -> 'a diff --git a/lib_eio/unix/types.ml b/lib_eio/unix/types.ml index 4ed2cd602..24767edd0 100644 --- a/lib_eio/unix/types.ml +++ b/lib_eio/unix/types.ml @@ -1,4 +1,4 @@ -type source_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.source_ty] -type sink_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.sink_ty] -type 'a source = ([> source_ty] as 'a) Eio.Resource.t -type 'a sink = ([> sink_ty] as 'a) Eio.Resource.t +type source_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.source_ty] +type sink_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.sink_ty] +type 'a source = ([> source_ty] as 'a) Eio.Resource.t +type 'a sink = ([> sink_ty] as 'a) Eio.Resource.t diff --git a/lib_eio/utils/dla.ml b/lib_eio/utils/dla.ml index a8699150c..b7aae65da 100644 --- a/lib_eio/utils/dla.ml +++ b/lib_eio/utils/dla.ml @@ -1,22 +1,22 @@ -let prepare_for_await () = - let state = Atomic.make `Init in - let release () = - if Atomic.get state != `Released then - match Atomic.exchange state `Released with - | `Awaiting enqueue -> enqueue (Ok ()) - | _ -> () - and await () = - if Atomic.get state != `Released then - Eio.Private.Suspend.enter "domain-local-await" @@ fun ctx enqueue -> - let awaiting = `Awaiting enqueue in - if Atomic.compare_and_set state `Init awaiting then ( - Eio.Private.Fiber_context.set_cancel_fn ctx (fun ex -> - if Atomic.compare_and_set state awaiting `Released then ( - enqueue (Error ex) - ) - ) - ) else ( - enqueue (Ok ()) - ) - in - Domain_local_await.{ release; await } +let prepare_for_await () = + let state = Atomic.make `Init in + let release () = + if Atomic.get state != `Released then + match Atomic.exchange state `Released with + | `Awaiting enqueue -> enqueue (Ok ()) + | _ -> () + and await () = + if Atomic.get state != `Released then + Eio.Private.Suspend.enter "domain-local-await" @@ fun ctx enqueue -> + let awaiting = `Awaiting enqueue in + if Atomic.compare_and_set state `Init awaiting then ( + Eio.Private.Fiber_context.set_cancel_fn ctx (fun ex -> + if Atomic.compare_and_set state awaiting `Released then ( + enqueue (Error ex) + ) + ) + ) else ( + enqueue (Ok ()) + ) + in + Domain_local_await.{ release; await } diff --git a/lib_eio/utils/dla.mli b/lib_eio/utils/dla.mli index 6bc14429f..94b5be03d 100644 --- a/lib_eio/utils/dla.mli +++ b/lib_eio/utils/dla.mli @@ -1 +1 @@ -val prepare_for_await : unit -> Domain_local_await.t +val prepare_for_await : unit -> Domain_local_await.t diff --git a/lib_eio/utils/dune b/lib_eio/utils/dune index 1cf3a3654..50a5884eb 100644 --- a/lib_eio/utils/dune +++ b/lib_eio/utils/dune @@ -1,4 +1,4 @@ -(library - (name eio_utils) - (public_name eio.utils) - (libraries eio psq fmt optint domain-local-await)) +(library + (name eio_utils) + (public_name eio.utils) + (libraries eio psq fmt optint domain-local-await)) diff --git a/lib_eio/utils/eio_utils.ml b/lib_eio/utils/eio_utils.ml index 8597e9fc5..f61b53279 100644 --- a/lib_eio/utils/eio_utils.ml +++ b/lib_eio/utils/eio_utils.ml @@ -1,8 +1,8 @@ -(** Utilities for implementing Eio event loops. - - These aren't intended for users of Eio. *) - -module Lf_queue = Lf_queue -module Suspended = Suspended -module Zzz = Zzz -module Dla = Dla +(** Utilities for implementing Eio event loops. + + These aren't intended for users of Eio. *) + +module Lf_queue = Lf_queue +module Suspended = Suspended +module Zzz = Zzz +module Dla = Dla diff --git a/lib_eio/utils/lf_queue.ml b/lib_eio/utils/lf_queue.ml index a59c08acf..0927a08ad 100644 --- a/lib_eio/utils/lf_queue.ml +++ b/lib_eio/utils/lf_queue.ml @@ -1,80 +1,80 @@ -(* A lock-free multi-producer, single-consumer, thread-safe queue without support for cancellation. - This makes a good data structure for a scheduler's run queue. - - Based on Vesa Karvonen's examaple at: - https://github.com/ocaml-multicore/picos/blob/07d6c2d391e076b490098c0379d01208b3a9cc96/test/lib/foundation/mpsc_queue.ml -*) - -exception Closed - -(* A list where the end indicates whether the queue is closed. *) -type 'a clist = - | (::) of 'a * 'a clist - | Open - | Closed - -(* [rev_append l1 l2] is like [rev l1 @ l2] *) -let rec rev_append l1 l2 = - match l1 with - | a :: l -> rev_append l (a :: l2) - | Open -> l2 - | Closed -> assert false - -let[@tail_mod_cons] rec ( @ ) l1 l2 = - match l1 with - | h1 :: tl -> h1 :: (tl @ l2) - | Open -> l2 - | Closed -> assert false - -(* The queue contains [head @ rev tail]. - If [tail] is non-empty then it ends in [Open]. *) -type 'a t = { - mutable head : 'a clist; - tail : 'a clist Atomic.t; -} - -let rec push t x = - match Atomic.get t.tail with - | Closed -> raise Closed - | before -> - let after = x :: before in - if not (Atomic.compare_and_set t.tail before after) then - push t x - -let push_head t x = - match t.head with - | Closed -> raise Closed - | before -> t.head <- x :: before - -let rec pop t = - match t.head with - | x :: xs -> t.head <- xs; Some x - | Closed -> raise Closed - | Open -> - (* We know the tail is open because we just saw the head was open - and we don't run concurrently with [close]. *) - match Atomic.exchange t.tail Open with - | Closed -> assert false - | Open -> None (* Optimise the common case *) - | tail -> - t.head <- rev_append tail Open; - pop t - -let close t = - match Atomic.exchange t.tail Closed with - | Closed -> invalid_arg "Lf_queue already closed!" - | xs -> t.head <- t.head @ rev_append xs Closed - -let is_empty t = - match t.head with - | _ :: _ -> false - | Closed -> raise Closed - | Open -> - match Atomic.get t.tail with - | _ :: _ -> false - | _ -> true - -let create () = { - head = Open; - tail = Atomic.make Open; -} +(* A lock-free multi-producer, single-consumer, thread-safe queue without support for cancellation. + This makes a good data structure for a scheduler's run queue. + + Based on Vesa Karvonen's examaple at: + https://github.com/ocaml-multicore/picos/blob/07d6c2d391e076b490098c0379d01208b3a9cc96/test/lib/foundation/mpsc_queue.ml +*) + +exception Closed + +(* A list where the end indicates whether the queue is closed. *) +type 'a clist = + | (::) of 'a * 'a clist + | Open + | Closed + +(* [rev_append l1 l2] is like [rev l1 @ l2] *) +let rec rev_append l1 l2 = + match l1 with + | a :: l -> rev_append l (a :: l2) + | Open -> l2 + | Closed -> assert false + +let[@tail_mod_cons] rec ( @ ) l1 l2 = + match l1 with + | h1 :: tl -> h1 :: (tl @ l2) + | Open -> l2 + | Closed -> assert false + +(* The queue contains [head @ rev tail]. + If [tail] is non-empty then it ends in [Open]. *) +type 'a t = { + mutable head : 'a clist; + tail : 'a clist Atomic.t; +} + +let rec push t x = + match Atomic.get t.tail with + | Closed -> raise Closed + | before -> + let after = x :: before in + if not (Atomic.compare_and_set t.tail before after) then + push t x + +let push_head t x = + match t.head with + | Closed -> raise Closed + | before -> t.head <- x :: before + +let rec pop t = + match t.head with + | x :: xs -> t.head <- xs; Some x + | Closed -> raise Closed + | Open -> + (* We know the tail is open because we just saw the head was open + and we don't run concurrently with [close]. *) + match Atomic.exchange t.tail Open with + | Closed -> assert false + | Open -> None (* Optimise the common case *) + | tail -> + t.head <- rev_append tail Open; + pop t + +let close t = + match Atomic.exchange t.tail Closed with + | Closed -> invalid_arg "Lf_queue already closed!" + | xs -> t.head <- t.head @ rev_append xs Closed + +let is_empty t = + match t.head with + | _ :: _ -> false + | Closed -> raise Closed + | Open -> + match Atomic.get t.tail with + | _ :: _ -> false + | _ -> true + +let create () = { + head = Open; + tail = Atomic.make Open; +} diff --git a/lib_eio/utils/lf_queue.mli b/lib_eio/utils/lf_queue.mli index cb1ea0423..9b1d1232b 100644 --- a/lib_eio/utils/lf_queue.mli +++ b/lib_eio/utils/lf_queue.mli @@ -1,32 +1,32 @@ -(** A lock-free multi-producer, single-consumer, thread-safe queue without support for cancellation. - This makes a good data structure for a scheduler's run queue. *) - -type 'a t -(** A queue of items of type ['a]. *) - -exception Closed - -val create : unit -> 'a t -(** [create ()] is a new empty queue. *) - -val push : 'a t -> 'a -> unit -(** [push t x] adds [x] to the tail of the queue. - This can be used safely by multiple producer domains, in parallel with the other operations. - @raise Closed if [t] is closed. *) - -val push_head : 'a t -> 'a -> unit -(** [push_head t x] inserts [x] at the head of the queue. - This can only be used by the consumer (if run in parallel with {!pop}, the item might be skipped). - @raise Closed if [t] is closed and empty. *) - -val pop : 'a t -> 'a option -(** [pop t] removes the head item from [t] and returns it. - Returns [None] if [t] is currently empty. - @raise Closed if [t] has been closed and is empty. *) - -val is_empty : 'a t -> bool -(** [is_empty t] is [true] if calling [pop] would return [None]. - @raise Closed if [t] has been closed and is empty. *) - -val close : 'a t -> unit -(** [close t] marks [t] as closed, preventing any further items from being pushed. *) +(** A lock-free multi-producer, single-consumer, thread-safe queue without support for cancellation. + This makes a good data structure for a scheduler's run queue. *) + +type 'a t +(** A queue of items of type ['a]. *) + +exception Closed + +val create : unit -> 'a t +(** [create ()] is a new empty queue. *) + +val push : 'a t -> 'a -> unit +(** [push t x] adds [x] to the tail of the queue. + This can be used safely by multiple producer domains, in parallel with the other operations. + @raise Closed if [t] is closed. *) + +val push_head : 'a t -> 'a -> unit +(** [push_head t x] inserts [x] at the head of the queue. + This can only be used by the consumer (if run in parallel with {!pop}, the item might be skipped). + @raise Closed if [t] is closed and empty. *) + +val pop : 'a t -> 'a option +(** [pop t] removes the head item from [t] and returns it. + Returns [None] if [t] is currently empty. + @raise Closed if [t] has been closed and is empty. *) + +val is_empty : 'a t -> bool +(** [is_empty t] is [true] if calling [pop] would return [None]. + @raise Closed if [t] has been closed and is empty. *) + +val close : 'a t -> unit +(** [close t] marks [t] as closed, preventing any further items from being pushed. *) diff --git a/lib_eio/utils/suspended.ml b/lib_eio/utils/suspended.ml index e12a3f131..e475ae4cd 100644 --- a/lib_eio/utils/suspended.ml +++ b/lib_eio/utils/suspended.ml @@ -1,19 +1,19 @@ -(** A suspended fiber with its context. *) - -open Effect.Deep -module Trace = Eio.Private.Trace - -type 'a t = { - fiber : Eio.Private.Fiber_context.t; - k : ('a, [`Exit_scheduler]) continuation; -} - -let tid t = Eio.Private.Fiber_context.tid t.fiber - -let continue t v = - Trace.fiber (tid t); - continue t.k v - -let discontinue t ex = - Trace.fiber (tid t); - discontinue t.k ex +(** A suspended fiber with its context. *) + +open Effect.Deep +module Trace = Eio.Private.Trace + +type 'a t = { + fiber : Eio.Private.Fiber_context.t; + k : ('a, [`Exit_scheduler]) continuation; +} + +let tid t = Eio.Private.Fiber_context.tid t.fiber + +let continue t v = + Trace.fiber (tid t); + continue t.k v + +let discontinue t ex = + Trace.fiber (tid t); + discontinue t.k ex diff --git a/lib_eio/utils/zzz.ml b/lib_eio/utils/zzz.ml index a3dd23149..bad9bce91 100644 --- a/lib_eio/utils/zzz.ml +++ b/lib_eio/utils/zzz.ml @@ -1,49 +1,49 @@ -module Key = struct - type t = Optint.Int63.t - let compare = Optint.Int63.compare -end - -type item = - | Fiber of unit Suspended.t - | Fn of (unit -> unit) - -module Job = struct - type t = { - time : Mtime.t; - item : item; - } - - let compare a b = Mtime.compare a.time b.time -end - -module Q = Psq.Make(Key)(Job) - -type t = { - mutable sleep_queue: Q.t; - mutable next_id : Optint.Int63.t; -} - -let create () = { sleep_queue = Q.empty; next_id = Optint.Int63.zero } - -let add t time item = - let id = t.next_id in - t.next_id <- Optint.Int63.succ t.next_id; - let sleeper = { Job.time; item } in - t.sleep_queue <- Q.add id sleeper t.sleep_queue; - id - -let remove t id = - t.sleep_queue <- Q.remove id t.sleep_queue - -let pop t ~now = - match Q.min t.sleep_queue with - | Some (_, { Job.time; item }) when time <= now -> - begin - match item with - | Fiber k -> Eio.Private.Fiber_context.clear_cancel_fn k.fiber - | Fn _ -> () - end; - t.sleep_queue <- Option.get (Q.rest t.sleep_queue); - `Due item - | Some (_, { Job.time; _ }) -> `Wait_until time - | None -> `Nothing +module Key = struct + type t = Optint.Int63.t + let compare = Optint.Int63.compare +end + +type item = + | Fiber of unit Suspended.t + | Fn of (unit -> unit) + +module Job = struct + type t = { + time : Mtime.t; + item : item; + } + + let compare a b = Mtime.compare a.time b.time +end + +module Q = Psq.Make(Key)(Job) + +type t = { + mutable sleep_queue: Q.t; + mutable next_id : Optint.Int63.t; +} + +let create () = { sleep_queue = Q.empty; next_id = Optint.Int63.zero } + +let add t time item = + let id = t.next_id in + t.next_id <- Optint.Int63.succ t.next_id; + let sleeper = { Job.time; item } in + t.sleep_queue <- Q.add id sleeper t.sleep_queue; + id + +let remove t id = + t.sleep_queue <- Q.remove id t.sleep_queue + +let pop t ~now = + match Q.min t.sleep_queue with + | Some (_, { Job.time; item }) when time <= now -> + begin + match item with + | Fiber k -> Eio.Private.Fiber_context.clear_cancel_fn k.fiber + | Fn _ -> () + end; + t.sleep_queue <- Option.get (Q.rest t.sleep_queue); + `Due item + | Some (_, { Job.time; _ }) -> `Wait_until time + | None -> `Nothing diff --git a/lib_eio/utils/zzz.mli b/lib_eio/utils/zzz.mli index 4bb1edc9f..c9fc215e6 100644 --- a/lib_eio/utils/zzz.mli +++ b/lib_eio/utils/zzz.mli @@ -1,31 +1,31 @@ -(** A set of timers. *) - -(** A handle to a registered timer. *) -module Key : sig - type t -end - -type t -(** A set of timers (implemented as a priority queue). *) - -type item = - | Fiber of unit Suspended.t - | Fn of (unit -> unit) - -val create : unit -> t -(** [create ()] is a fresh empty queue. *) - -val add : t -> Mtime.t -> item -> Key.t -(** [add t time item] adds a new event, due at [time], and returns its ID. - - If [item] is a {!Fiber}, - you must use {!Eio.Private.Fiber_context.set_cancel_fn} on it before calling {!pop}. - Your cancel function should call {!remove} (in addition to resuming it). *) - -val remove : t -> Key.t -> unit -(** [remove t key] removes an event previously added with [add]. *) - -val pop : t -> now:Mtime.t -> [`Due of item | `Wait_until of Mtime.t | `Nothing] -(** [pop ~now t] removes and returns the earliest item due by [now]. - For fibers, it also clears the thread's cancel function. - If no item is due yet, it returns the time the earliest item becomes due. *) +(** A set of timers. *) + +(** A handle to a registered timer. *) +module Key : sig + type t +end + +type t +(** A set of timers (implemented as a priority queue). *) + +type item = + | Fiber of unit Suspended.t + | Fn of (unit -> unit) + +val create : unit -> t +(** [create ()] is a fresh empty queue. *) + +val add : t -> Mtime.t -> item -> Key.t +(** [add t time item] adds a new event, due at [time], and returns its ID. + + If [item] is a {!Fiber}, + you must use {!Eio.Private.Fiber_context.set_cancel_fn} on it before calling {!pop}. + Your cancel function should call {!remove} (in addition to resuming it). *) + +val remove : t -> Key.t -> unit +(** [remove t key] removes an event previously added with [add]. *) + +val pop : t -> now:Mtime.t -> [`Due of item | `Wait_until of Mtime.t | `Nothing] +(** [pop ~now t] removes and returns the earliest item due by [now]. + For fibers, it also clears the thread's cancel function. + If no item is due yet, it returns the time the earliest item becomes due. *) diff --git a/lib_eio/waiters.ml b/lib_eio/waiters.ml index 01871975e..1f74197bd 100644 --- a/lib_eio/waiters.ml +++ b/lib_eio/waiters.ml @@ -1,66 +1,66 @@ -type 'a waiter = { - finished : bool Atomic.t; - enqueue : ('a, exn) result -> unit; -} - -type 'a t = 'a waiter Lwt_dllist.t - -let create = Lwt_dllist.create - -let add_waiter_protected ~mutex t cb = - let w = Lwt_dllist.add_l cb t in - Hook.Node_with_mutex (w, mutex) - -let add_waiter t cb = - let w = Lwt_dllist.add_l cb t in - Hook.Node w - -(* Wake a waiter with the result. - Returns [false] if the waiter got cancelled while we were trying to wake it. *) -let wake { enqueue; finished } r = - if Atomic.compare_and_set finished false true then (enqueue (Ok r); true) - else false (* [cancel] gets called and we enqueue an error *) - -let wake_all (t:_ t) v = - try - while true do - let waiter = Lwt_dllist.take_r t in - ignore (wake waiter v : bool) - done - with Lwt_dllist.Empty -> () - -let rec wake_one t v = - match Lwt_dllist.take_opt_r t with - | None -> `Queue_empty - | Some waiter -> - if wake waiter v then `Ok - else wake_one t v - -let is_empty = Lwt_dllist.is_empty - -let await_internal ~mutex (t:'a t) ctx enqueue = - match Fiber_context.get_error ctx with - | Some ex -> - Option.iter Mutex.unlock mutex; - enqueue (Error ex) - | None -> - let resolved_waiter = ref Hook.null in - let finished = Atomic.make false in - let cancel ex = - if Atomic.compare_and_set finished false true then ( - Hook.remove !resolved_waiter; - enqueue (Error ex) - ) - in - Fiber_context.set_cancel_fn ctx cancel; - let waiter = { enqueue; finished } in - match mutex with - | None -> - resolved_waiter := add_waiter t waiter - | Some mutex -> - resolved_waiter := add_waiter_protected ~mutex t waiter; - Mutex.unlock mutex - -(* Returns a result if the wait succeeds, or raises if cancelled. *) -let await ~mutex op waiters = - Suspend.enter_unchecked op (await_internal ~mutex waiters) +type 'a waiter = { + finished : bool Atomic.t; + enqueue : ('a, exn) result -> unit; +} + +type 'a t = 'a waiter Lwt_dllist.t + +let create = Lwt_dllist.create + +let add_waiter_protected ~mutex t cb = + let w = Lwt_dllist.add_l cb t in + Hook.Node_with_mutex (w, mutex) + +let add_waiter t cb = + let w = Lwt_dllist.add_l cb t in + Hook.Node w + +(* Wake a waiter with the result. + Returns [false] if the waiter got cancelled while we were trying to wake it. *) +let wake { enqueue; finished } r = + if Atomic.compare_and_set finished false true then (enqueue (Ok r); true) + else false (* [cancel] gets called and we enqueue an error *) + +let wake_all (t:_ t) v = + try + while true do + let waiter = Lwt_dllist.take_r t in + ignore (wake waiter v : bool) + done + with Lwt_dllist.Empty -> () + +let rec wake_one t v = + match Lwt_dllist.take_opt_r t with + | None -> `Queue_empty + | Some waiter -> + if wake waiter v then `Ok + else wake_one t v + +let is_empty = Lwt_dllist.is_empty + +let await_internal ~mutex (t:'a t) ctx enqueue = + match Fiber_context.get_error ctx with + | Some ex -> + Option.iter Mutex.unlock mutex; + enqueue (Error ex) + | None -> + let resolved_waiter = ref Hook.null in + let finished = Atomic.make false in + let cancel ex = + if Atomic.compare_and_set finished false true then ( + Hook.remove !resolved_waiter; + enqueue (Error ex) + ) + in + Fiber_context.set_cancel_fn ctx cancel; + let waiter = { enqueue; finished } in + match mutex with + | None -> + resolved_waiter := add_waiter t waiter + | Some mutex -> + resolved_waiter := add_waiter_protected ~mutex t waiter; + Mutex.unlock mutex + +(* Returns a result if the wait succeeds, or raises if cancelled. *) +let await ~mutex op waiters = + Suspend.enter_unchecked op (await_internal ~mutex waiters) diff --git a/lib_eio/waiters.mli b/lib_eio/waiters.mli index 1ab68847b..0519fa0ed 100644 --- a/lib_eio/waiters.mli +++ b/lib_eio/waiters.mli @@ -1,43 +1,43 @@ -(** A queue of fibers waiting for an event. *) -type 'a t -(* A queue of fibers waiting for something. - Note: an [_ t] is not thread-safe itself. - To use share it between domains, the user is responsible for wrapping it in a mutex. *) - -val create : unit -> 'a t - -val wake_all : 'a t -> 'a -> unit -(** [wake_all t] calls (and removes) all the functions waiting on [t]. - If [t] is shared between domains, the caller must hold the mutex while calling this. *) - -val wake_one : 'a t -> 'a -> [`Ok | `Queue_empty] -(** [wake_one t] is like {!wake_all}, but only calls (and removes) the first waiter in the queue. - If [t] is shared between domains, the caller must hold the mutex while calling this. *) - -val is_empty : 'a t -> bool -(** [is_empty t] checks whether there are any functions waiting on [t]. - If [t] is shared between domains, the caller must hold the mutex while calling this, - and the result is valid until the mutex is released. *) - -val await : - mutex:Mutex.t option -> - string -> - 'a t -> 'a -(** [await ~mutex op t] suspends the current fiber and adds its continuation to [t]. - When the waiter is woken, the fiber is resumed and returns the result. - If [t] can be used from multiple domains: - - [mutex] must be set to the mutex to use to unlock it. - - [mutex] must be already held when calling this function, which will unlock it before blocking. - When [await] returns, [mutex] will have been unlocked. - @raise Cancel.Cancelled if the fiber's context is cancelled *) - -val await_internal : - mutex:Mutex.t option -> - 'a t -> Fiber_context.t -> - (('a, exn) result -> unit) -> unit -(** [await_internal ~mutex t ctx enqueue] is like [await], but the caller has to suspend the fiber. - This also allows wrapping the [enqueue] function. - Calls [enqueue (Error (Cancelled _))] if cancelled. - Note: [enqueue] is called from the triggering domain, - which is currently calling {!wake_one} or {!wake_all} - and must therefore be holding [mutex]. *) +(** A queue of fibers waiting for an event. *) +type 'a t +(* A queue of fibers waiting for something. + Note: an [_ t] is not thread-safe itself. + To use share it between domains, the user is responsible for wrapping it in a mutex. *) + +val create : unit -> 'a t + +val wake_all : 'a t -> 'a -> unit +(** [wake_all t] calls (and removes) all the functions waiting on [t]. + If [t] is shared between domains, the caller must hold the mutex while calling this. *) + +val wake_one : 'a t -> 'a -> [`Ok | `Queue_empty] +(** [wake_one t] is like {!wake_all}, but only calls (and removes) the first waiter in the queue. + If [t] is shared between domains, the caller must hold the mutex while calling this. *) + +val is_empty : 'a t -> bool +(** [is_empty t] checks whether there are any functions waiting on [t]. + If [t] is shared between domains, the caller must hold the mutex while calling this, + and the result is valid until the mutex is released. *) + +val await : + mutex:Mutex.t option -> + string -> + 'a t -> 'a +(** [await ~mutex op t] suspends the current fiber and adds its continuation to [t]. + When the waiter is woken, the fiber is resumed and returns the result. + If [t] can be used from multiple domains: + - [mutex] must be set to the mutex to use to unlock it. + - [mutex] must be already held when calling this function, which will unlock it before blocking. + When [await] returns, [mutex] will have been unlocked. + @raise Cancel.Cancelled if the fiber's context is cancelled *) + +val await_internal : + mutex:Mutex.t option -> + 'a t -> Fiber_context.t -> + (('a, exn) result -> unit) -> unit +(** [await_internal ~mutex t ctx enqueue] is like [await], but the caller has to suspend the fiber. + This also allows wrapping the [enqueue] function. + Calls [enqueue (Error (Cancelled _))] if cancelled. + Note: [enqueue] is called from the triggering domain, + which is currently calling {!wake_one} or {!wake_all} + and must therefore be holding [mutex]. *) diff --git a/lib_eio_linux/dune b/lib_eio_linux/dune index 12b9921b4..afcff4036 100644 --- a/lib_eio_linux/dune +++ b/lib_eio_linux/dune @@ -1,39 +1,39 @@ -(library - (name eio_linux) - (public_name eio_linux) - (enabled_if ; See https://github.com/ocaml/dune/issues/4895 - (or (= %{system} "linux") ; Historically, just Linux-x86 - (= %{system} "linux_eabihf") ; Historically, Linux-arm32 - (= %{system} "linux_elf") ; Historically, Linux-x86_32 - (= %{system} "elf"))) ; Historically, Linux-ppc64 - (foreign_stubs - (language c) - (flags :standard -D_LARGEFILE64_SOURCE) - (include_dirs ../lib_eio/unix/include) - (names eio_stubs)) - (libraries eio eio.utils eio.unix uring fmt)) - -(rule - (enabled_if - (and - %{bin-available:lintcstubs_arity_cmt} - (or (= %{system} "linux") ; Historically, just Linux-x86 - (= %{system} "linux_eabihf") ; Historically, Linux-arm32 - (= %{system} "linux_elf") ; Historically, Linux-x86_32 - (= %{system} "elf")))) ; Historically, Linux-ppc64 - (action - (with-stdout-to - primitives.h.new - (run %{bin:lintcstubs_arity_cmt} %{dep:.eio_linux.objs/byte/eio_linux__Low_level.cmt} %{dep:.eio_linux.objs/byte/eio_linux__Sched.cmt})))) - -(rule - (enabled_if - (and - %{bin-available:lintcstubs_arity_cmt} - (or (= %{system} "linux") ; Historically, just Linux-x86 - (= %{system} "linux_eabihf") ; Historically, Linux-arm32 - (= %{system} "linux_elf") ; Historically, Linux-x86_32 - (= %{system} "elf")))) ; Historically, Linux-ppc64 - (alias runtest) - (action - (diff primitives.h primitives.h.new))) +(library + (name eio_linux) + (public_name eio_linux) + (enabled_if ; See https://github.com/ocaml/dune/issues/4895 + (or (= %{system} "linux") ; Historically, just Linux-x86 + (= %{system} "linux_eabihf") ; Historically, Linux-arm32 + (= %{system} "linux_elf") ; Historically, Linux-x86_32 + (= %{system} "elf"))) ; Historically, Linux-ppc64 + (foreign_stubs + (language c) + (flags :standard -D_LARGEFILE64_SOURCE) + (include_dirs ../lib_eio/unix/include) + (names eio_stubs)) + (libraries eio eio.utils eio.unix uring fmt)) + +(rule + (enabled_if + (and + %{bin-available:lintcstubs_arity_cmt} + (or (= %{system} "linux") ; Historically, just Linux-x86 + (= %{system} "linux_eabihf") ; Historically, Linux-arm32 + (= %{system} "linux_elf") ; Historically, Linux-x86_32 + (= %{system} "elf")))) ; Historically, Linux-ppc64 + (action + (with-stdout-to + primitives.h.new + (run %{bin:lintcstubs_arity_cmt} %{dep:.eio_linux.objs/byte/eio_linux__Low_level.cmt} %{dep:.eio_linux.objs/byte/eio_linux__Sched.cmt})))) + +(rule + (enabled_if + (and + %{bin-available:lintcstubs_arity_cmt} + (or (= %{system} "linux") ; Historically, just Linux-x86 + (= %{system} "linux_eabihf") ; Historically, Linux-arm32 + (= %{system} "linux_elf") ; Historically, Linux-x86_32 + (= %{system} "elf")))) ; Historically, Linux-ppc64 + (alias runtest) + (action + (diff primitives.h primitives.h.new))) diff --git a/lib_eio_linux/eio_linux.ml b/lib_eio_linux/eio_linux.ml index ec9c8eb07..c4156fbae 100644 --- a/lib_eio_linux/eio_linux.ml +++ b/lib_eio_linux/eio_linux.ml @@ -1,557 +1,557 @@ -(* - * Copyright (C) 2020-2021 Anil Madhavapeddy - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -[@@@alert "-unstable"] - -open Eio.Std - -module Fiber_context = Eio.Private.Fiber_context -module Trace = Eio.Private.Trace -module Fd = Eio_unix.Fd - -module Suspended = Eio_utils.Suspended -module Zzz = Eio_utils.Zzz -module Lf_queue = Eio_utils.Lf_queue - -module Low_level = Low_level - -(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check - that the new location is within its sandbox. *) -type ('t, _, _) Eio.Resource.pi += Dir_fd : ('t, 't -> Low_level.dir_fd, [> `Dir_fd]) Eio.Resource.pi - -let get_dir_fd_opt (Eio.Resource.T (t, ops)) = - match Eio.Resource.get_opt ops Dir_fd with - | Some f -> Some (f t) - | None -> None - - -module Datagram_socket = struct - type tag = [`Generic | `Unix] - - type t = Eio_unix.Fd.t - - let fd t = t - - let close = Eio_unix.Fd.close - - let send t ?dst buf = - let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in - let sent = Low_level.send_msg t ?dst buf in - assert (sent = Cstruct.lenv buf) - - let recv t buf = - let addr, recv = Low_level.recv_msg t [buf] in - Eio_unix.Net.sockaddr_of_unix_datagram (Uring.Sockaddr.get addr), recv - - let shutdown t cmd = - Low_level.shutdown t @@ match cmd with - | `Receive -> Unix.SHUTDOWN_RECEIVE - | `Send -> Unix.SHUTDOWN_SEND - | `All -> Unix.SHUTDOWN_ALL -end - -let datagram_handler = Eio_unix.Pi.datagram_handler (module Datagram_socket) - -let datagram_socket fd = - Eio.Resource.T (fd, datagram_handler) - -module Listening_socket = struct - type t = Fd.t - - type tag = [`Generic | `Unix] - - let fd t = t - - let close = Fd.close - - let accept t ~sw = - Switch.check sw; - let client, client_addr = Low_level.accept ~sw t in - let client_addr = match client_addr with - | Unix.ADDR_UNIX path -> `Unix path - | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port) - in - let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in - flow, client_addr - - let listening_addr fd = - Eio_unix.Fd.use_exn "listening_addr" fd - (fun fd -> Eio_unix.Net.sockaddr_of_unix_stream (Unix.getsockname fd)) -end - -let listening_handler = Eio_unix.Pi.listening_socket_handler (module Listening_socket) - -let listening_socket fd = - Eio.Resource.T (fd, listening_handler) - -let socket_domain_of = function - | `Unix _ -> Unix.PF_UNIX - | `UdpV4 -> Unix.PF_INET - | `UdpV6 -> Unix.PF_INET6 - | `Udp (host, _) - | `Tcp (host, _) -> - Eio.Net.Ipaddr.fold host - ~v4:(fun _ -> Unix.PF_INET) - ~v6:(fun _ -> Unix.PF_INET6) - -let connect ~sw connect_addr = - let addr = Eio_unix.Net.sockaddr_to_unix connect_addr in - let sock_unix = Unix.socket ~cloexec:true (socket_domain_of connect_addr) Unix.SOCK_STREAM 0 in - let sock = Fd.of_unix ~sw ~seekable:false ~close_unix:true sock_unix in - Low_level.connect sock addr; - (Flow.of_fd sock :> _ Eio_unix.Net.stream_socket) - -module Impl = struct - type t = unit - type tag = [`Unix | `Generic] - - let listen () ~reuse_addr ~reuse_port ~backlog ~sw listen_addr = - if reuse_addr then ( - match listen_addr with - | `Tcp _ -> () - | `Unix path -> - match Unix.lstat path with - | Unix.{ st_kind = S_SOCK; _ } -> Unix.unlink path - | _ -> () - | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () - | exception Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg - ); - let addr = Eio_unix.Net.sockaddr_to_unix listen_addr in - let sock_unix = Unix.socket ~cloexec:true (socket_domain_of listen_addr) Unix.SOCK_STREAM 0 in - let sock = Fd.of_unix ~sw ~seekable:false ~close_unix:true sock_unix in - (* For Unix domain sockets, remove the path when done (except for abstract sockets). *) - begin match listen_addr with - | `Unix path -> - if String.length path > 0 && path.[0] <> Char.chr 0 then - Switch.on_release sw (fun () -> Unix.unlink path) - | `Tcp _ -> () - end; - if reuse_addr then - Unix.setsockopt sock_unix Unix.SO_REUSEADDR true; - if reuse_port then - Unix.setsockopt sock_unix Unix.SO_REUSEPORT true; - Unix.bind sock_unix addr; - Unix.listen sock_unix backlog; - (listening_socket sock :> _ Eio.Net.listening_socket_ty r) - - let connect () ~sw addr = (connect ~sw addr :> [`Generic | `Unix] Eio.Net.stream_socket_ty r) - - let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr = - if reuse_addr then ( - match saddr with - | `Udp _ | `UdpV4 | `UdpV6 -> () - | `Unix path -> - match Unix.lstat path with - | Unix.{ st_kind = S_SOCK; _ } -> Unix.unlink path - | _ -> () - | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () - | exception Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg - ); - let sock_unix = Unix.socket ~cloexec:true (socket_domain_of saddr) Unix.SOCK_DGRAM 0 in - let sock = Fd.of_unix ~sw ~seekable:false ~close_unix:true sock_unix in - begin match saddr with - | `Udp _ | `Unix _ as saddr -> - let addr = Eio_unix.Net.sockaddr_to_unix saddr in - if reuse_addr then - Unix.setsockopt sock_unix Unix.SO_REUSEADDR true; - if reuse_port then - Unix.setsockopt sock_unix Unix.SO_REUSEPORT true; - Unix.bind sock_unix addr - | `UdpV4 | `UdpV6 -> () - end; - (datagram_socket sock :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r) - - let getaddrinfo () = Low_level.getaddrinfo - let getnameinfo () = Eio_unix.Net.getnameinfo -end - -let net = - let handler = Eio.Net.Pi.network (module Impl) in - Eio.Resource.T ((), handler) - -type stdenv = Eio_unix.Stdenv.base - -module Process_impl = struct - type t = Low_level.Process.t - type tag = [ `Generic | `Unix ] - - let pid = Low_level.Process.pid - - let await t = - match Eio.Promise.await @@ Low_level.Process.exit_status t with - | Unix.WEXITED i -> `Exited i - | Unix.WSIGNALED i -> `Signaled i - | Unix.WSTOPPED _ -> assert false - - let signal = Low_level.Process.signal -end - -let process = - let handler = Eio.Process.Pi.process (module Process_impl) in - fun proc -> Eio.Resource.T (proc, handler) - -(* fchdir wants just a directory FD, not an FD and a path like the *at functions. *) -let with_dir dir_fd path fn = - Switch.run ~name:"with_dir" @@ fun sw -> - Low_level.openat ~sw - ~seekable:false - ~access:`R - ~perm:0 - ~flags:Uring.Open_flags.(cloexec + path + directory) - dir_fd (if path = "" then "." else path) - |> fn - -module Process_mgr = struct - module T = struct - type t = unit - - let spawn_unix () ~sw ?cwd ~env ~fds ~executable args = - let actions = Low_level.Process.Fork_action.[ - Eio_unix.Private.Fork_action.inherit_fds fds; - execve executable ~argv:(Array.of_list args) ~env - ] in - let with_actions cwd fn = match cwd with - | None -> fn actions - | Some (fd, s) -> - match get_dir_fd_opt fd with - | None -> Fmt.invalid_arg "cwd is not an OS directory!" - | Some dir_fd -> - with_dir dir_fd s @@ fun cwd -> - fn (Low_level.Process.Fork_action.fchdir cwd :: actions) - in - with_actions cwd @@ fun actions -> - process (Low_level.Process.spawn ~sw actions) - end - - include Eio_unix.Process.Make_mgr (T) -end - -let process_mgr : Eio_unix.Process.mgr_ty r = - let h = Eio_unix.Process.Pi.mgr_unix (module Process_mgr) in - Eio.Resource.T ((), h) - -let wrap_backtrace fn x = - match fn x with - | x -> Ok x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - Error (ex, bt) - -let unwrap_backtrace = function - | Ok x -> x - | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt - -module Domain_mgr = struct - type t = { - run_event_loop : (unit -> unit) -> unit -> unit; - } - - let domain_spawn sched k fn = - Domain.spawn @@ fun () -> - Trace.domain_spawn ~parent:(Suspended.tid k); - Fun.protect fn ~finally:(fun () -> Sched.enqueue_thread sched k ()) - - let make ~run_event_loop = { run_event_loop } - - let run_raw _t fn = - let domain = ref None in - Sched.enter "run-domain" (fun sched k -> - let fn = wrap_backtrace fn in - domain := Some (domain_spawn sched k fn) - ); - unwrap_backtrace (Domain.join (Option.get !domain)) - - let run t fn = - let domain = ref None in - Sched.enter "run-domain" (fun sched k -> - let cancelled, set_cancelled = Promise.create () in - Fiber_context.set_cancel_fn k.fiber (Promise.resolve set_cancelled); - domain := Some (domain_spawn sched k (fun () -> - let result = ref None in - let fn = wrap_backtrace (fun () -> fn ~cancelled) in - t.run_event_loop (fun () -> result := Some (fn ())) (); - Option.get !result - )) - ); - Trace.with_span "Domain.join" @@ fun () -> - unwrap_backtrace (Domain.join (Option.get !domain)) -end - -let domain_mgr ~run_event_loop = - let handler = Eio.Domain_manager.Pi.mgr (module Domain_mgr) in - Eio.Resource.T (Domain_mgr.make ~run_event_loop, handler) - -module Mono_clock = struct - type t = unit - type time = Mtime.t - - let now () = Mtime_clock.now () - let sleep_until () time = Low_level.sleep_until time -end - -let mono_clock : Mtime.t Eio.Time.clock_ty r = - let handler = Eio.Time.Pi.clock (module Mono_clock) in - Eio.Resource.T ((), handler) - -module Clock = struct - type t = unit - type time = float - - let now () = Unix.gettimeofday () - - let sleep_until () time = - (* todo: use the realtime clock directly instead of converting to monotonic time. - That is needed to handle adjustments to the system clock correctly. *) - let d = time -. Unix.gettimeofday () in - Eio.Time.Mono.sleep mono_clock d -end - -let clock : float Eio.Time.clock_ty r = - let handler = Eio.Time.Pi.clock (module Clock) in - Eio.Resource.T ((), handler) - -module rec Dir : sig - include Eio.Fs.Pi.DIR - - val v : label:string -> path:string -> Low_level.dir_fd -> t - - val close : t -> unit - - val fd : t -> Low_level.dir_fd -end = struct - type t = { - fd : Low_level.dir_fd; - label : string; - path : string; - } - - let v ~label ~path fd = { fd; label; path } - - let open_in t ~sw path = - let fd = Low_level.openat ~sw t.fd path - ~access:`R - ~flags:Uring.Open_flags.cloexec - ~perm:0 - in - (Flow.of_fd fd :> Eio.File.ro_ty r) - - let open_out t ~sw ~append ~create path = - let perm, flags = - match create with - | `Never -> 0, Uring.Open_flags.empty - | `If_missing perm -> perm, Uring.Open_flags.creat - | `Or_truncate perm -> perm, Uring.Open_flags.(creat + trunc) - | `Exclusive perm -> perm, Uring.Open_flags.(creat + excl) - in - let flags = if append then Uring.Open_flags.(flags + append) else flags in - let fd = Low_level.openat ~sw t.fd path - ~access:`RW - ~flags:Uring.Open_flags.(cloexec + flags) - ~perm - in - (Flow.of_fd fd :> Eio.File.rw_ty r) - - let native_internal t path = - if Filename.is_relative path then ( - let p = Filename.concat t.path path in - if p = "" then "." - else if p = "." then p - else if Filename.is_implicit p then "./" ^ p - else p - ) else path - - let open_dir t ~sw path = - let fd = Low_level.openat ~sw ~seekable:false t.fd (if path = "" then "." else path) - ~access:`R - ~flags:Uring.Open_flags.(cloexec + path + directory) - ~perm:0 - in - let label = Filename.basename path in - let d = v ~label ~path:(native_internal t path) (Low_level.FD fd) in - Eio.Resource.T (d, Dir_handler.v) - - let mkdir t ~perm path = Low_level.mkdir ~perm t.fd path - - let read_dir t path = - Switch.run ~name:"read_dir" @@ fun sw -> - let path = if path = "" then "." else path in - let fd = - Low_level.openat ~sw t.fd path - ~seekable:false - ~access:`R - ~flags:Uring.Open_flags.(cloexec + directory) - ~perm:0 - in - Low_level.read_dir fd - - let read_link t path = Low_level.read_link t.fd path - - let close t = - match t.fd with - | FD x -> Fd.close x - | Cwd | Fs -> failwith "Can't close non-FD directory!" - - let unlink t path = Low_level.unlink ~rmdir:false t.fd path - let rmdir t path = Low_level.unlink ~rmdir:true t.fd path - - let float_of_time s ns = - let s = Int64.to_float s in - let f = s +. (float ns /. 1e9) in - (* It's possible that we might round up to the next second. - Since some algorithms only care about the seconds part, - make sure the integer part is always [s]: *) - if floor f = s then f - else Float.pred f - - let stat t ~follow path = - if !Sched.statx_works then ( - let module X = Uring.Statx in - let x = X.create () in - Low_level.statx ~follow ~mask:X.Mask.basic_stats t.fd path x; - { Eio.File.Stat. - dev = X.dev x; - ino = X.ino x; - kind = X.kind x; - perm = X.perm x; - nlink = X.nlink x; - uid = X.uid x; - gid = X.gid x; - rdev = X.rdev x; - size = X.size x |> Optint.Int63.of_int64; - atime = float_of_time (X.atime_sec x) (X.atime_nsec x); - mtime = float_of_time (X.mtime_sec x) (X.mtime_nsec x); - ctime = float_of_time (X.ctime_sec x) (X.ctime_nsec x); - } - ) else ( - (* Linux < 5.18 *) - Switch.run ~name:"stat" @@ fun sw -> - let fd = Low_level.openat ~sw ~seekable:false t.fd (if path = "" then "." else path) - ~access:`R - ~flags:Uring.Open_flags.(cloexec + path + (if follow then empty else nofollow)) - ~perm:0 - in - Low_level.fstat fd - ) - - let rename t old_path t2 new_path = - match get_dir_fd_opt t2 with - | Some fd2 -> Low_level.rename t.fd old_path fd2 new_path - | None -> raise (Unix.Unix_error (Unix.EXDEV, "rename-dst", new_path)) - - let symlink ~link_to t path = - Low_level.symlink ~link_to t.fd path - - let pp f t = Fmt.string f (String.escaped t.label) - - let fd t = t.fd - - let native t path = - Some (native_internal t path) -end -and Dir_handler : sig - val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler -end = struct - let v = Eio.Resource.handler [ - H (Eio.Fs.Pi.Dir, (module Dir)); - H (Eio.Resource.Close, Dir.close); - H (Dir_fd, Dir.fd); - ] -end - -let dir ~label ~path fd = Eio.Resource.T (Dir.v ~label ~path fd, Dir_handler.v) - -let stdenv ~run_event_loop = - let fs = (dir ~label:"fs" ~path:"" Fs, "") in - let cwd = (dir ~label:"cwd" ~path:"" Cwd, "") in - object (_ : stdenv) - method stdin = Flow.stdin - method stdout = Flow.stdout - method stderr = Flow.stderr - method net = net - method process_mgr = process_mgr - method domain_mgr = domain_mgr ~run_event_loop - method clock = clock - method mono_clock = mono_clock - method fs = (fs :> Eio.Fs.dir_ty Eio.Path.t) - method cwd = (cwd :> Eio.Fs.dir_ty Eio.Path.t) - method secure_random = Flow.secure_random - method debug = Eio.Private.Debug.v - method backend_id = "linux" - end - -let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a = - Sched.with_sched ?fallback config @@ fun st -> - let open Effect.Deep in - let extra_effects : _ effect_handler = { - effc = fun (type a) (e : a Effect.t) : ((a, Sched.exit) continuation -> Sched.exit) option -> - match e with - | Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k mono_clock) - | Eio_unix.Net.Import_socket_stream (sw, close_unix, fd) -> Some (fun k -> - let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in - continue k (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) - ) - | Eio_unix.Net.Import_socket_listening (sw, close_unix, fd) -> Some (fun k -> - let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in - continue k (listening_socket fd) - ) - | Eio_unix.Net.Import_socket_datagram (sw, close_unix, fd) -> Some (fun k -> - let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in - continue k (datagram_socket fd) - ) - | Eio_unix.Net.Socketpair_stream (sw, domain, protocol) -> Some (fun k -> - match - let a, b = Unix.socketpair ~cloexec:true domain Unix.SOCK_STREAM protocol in - let a = Fd.of_unix ~sw ~seekable:false ~close_unix:true a |> Flow.of_fd in - let b = Fd.of_unix ~sw ~seekable:false ~close_unix:true b |> Flow.of_fd in - ((a :> _ Eio_unix.Net.stream_socket), (b :> _ Eio_unix.Net.stream_socket)) - with - | r -> continue k r - | exception Unix.Unix_error (code, name, arg) -> - discontinue k (Err.wrap code name arg) - ) - | Eio_unix.Net.Socketpair_datagram (sw, domain, protocol) -> Some (fun k -> - match - let a, b = Unix.socketpair ~cloexec:true domain Unix.SOCK_DGRAM protocol in - let a = Fd.of_unix ~sw ~seekable:false ~close_unix:true a |> datagram_socket in - let b = Fd.of_unix ~sw ~seekable:false ~close_unix:true b |> datagram_socket in - ((a :> _ Eio_unix.Net.datagram_socket), (b :> _ Eio_unix.Net.datagram_socket)) - with - | r -> continue k r - | exception Unix.Unix_error (code, name, arg) -> - discontinue k (Err.wrap code name arg) - ) - | Eio_unix.Private.Pipe sw -> Some (fun k -> - match - let r, w = Low_level.pipe ~sw in - let r = (Flow.of_fd r :> _ Eio_unix.source) in - let w = (Flow.of_fd w :> _ Eio_unix.sink) in - (r, w) - with - | r -> continue k r - | exception Unix.Unix_error (code, name, arg) -> - discontinue k (Err.wrap code name arg) - ) - | _ -> None - } in - Sched.run ~extra_effects st main arg - -let run ?queue_depth ?n_blocks ?block_size ?polling_timeout ?fallback main = - let config = Sched.config ?queue_depth ?n_blocks ?block_size ?polling_timeout () in - let stdenv = stdenv ~run_event_loop:(run_event_loop ?fallback:None config) in - (* SIGPIPE makes no sense in a modern application. *) - Sys.(set_signal sigpipe Signal_ignore); - run_event_loop ?fallback config main stdenv +(* + * Copyright (C) 2020-2021 Anil Madhavapeddy + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +[@@@alert "-unstable"] + +open Eio.Std + +module Fiber_context = Eio.Private.Fiber_context +module Trace = Eio.Private.Trace +module Fd = Eio_unix.Fd + +module Suspended = Eio_utils.Suspended +module Zzz = Eio_utils.Zzz +module Lf_queue = Eio_utils.Lf_queue + +module Low_level = Low_level + +(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check + that the new location is within its sandbox. *) +type ('t, _, _) Eio.Resource.pi += Dir_fd : ('t, 't -> Low_level.dir_fd, [> `Dir_fd]) Eio.Resource.pi + +let get_dir_fd_opt (Eio.Resource.T (t, ops)) = + match Eio.Resource.get_opt ops Dir_fd with + | Some f -> Some (f t) + | None -> None + + +module Datagram_socket = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t + + let fd t = t + + let close = Eio_unix.Fd.close + + let send t ?dst buf = + let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in + let sent = Low_level.send_msg t ?dst buf in + assert (sent = Cstruct.lenv buf) + + let recv t buf = + let addr, recv = Low_level.recv_msg t [buf] in + Eio_unix.Net.sockaddr_of_unix_datagram (Uring.Sockaddr.get addr), recv + + let shutdown t cmd = + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL +end + +let datagram_handler = Eio_unix.Pi.datagram_handler (module Datagram_socket) + +let datagram_socket fd = + Eio.Resource.T (fd, datagram_handler) + +module Listening_socket = struct + type t = Fd.t + + type tag = [`Generic | `Unix] + + let fd t = t + + let close = Fd.close + + let accept t ~sw = + Switch.check sw; + let client, client_addr = Low_level.accept ~sw t in + let client_addr = match client_addr with + | Unix.ADDR_UNIX path -> `Unix path + | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port) + in + let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in + flow, client_addr + + let listening_addr fd = + Eio_unix.Fd.use_exn "listening_addr" fd + (fun fd -> Eio_unix.Net.sockaddr_of_unix_stream (Unix.getsockname fd)) +end + +let listening_handler = Eio_unix.Pi.listening_socket_handler (module Listening_socket) + +let listening_socket fd = + Eio.Resource.T (fd, listening_handler) + +let socket_domain_of = function + | `Unix _ -> Unix.PF_UNIX + | `UdpV4 -> Unix.PF_INET + | `UdpV6 -> Unix.PF_INET6 + | `Udp (host, _) + | `Tcp (host, _) -> + Eio.Net.Ipaddr.fold host + ~v4:(fun _ -> Unix.PF_INET) + ~v6:(fun _ -> Unix.PF_INET6) + +let connect ~sw connect_addr = + let addr = Eio_unix.Net.sockaddr_to_unix connect_addr in + let sock_unix = Unix.socket ~cloexec:true (socket_domain_of connect_addr) Unix.SOCK_STREAM 0 in + let sock = Fd.of_unix ~sw ~seekable:false ~close_unix:true sock_unix in + Low_level.connect sock addr; + (Flow.of_fd sock :> _ Eio_unix.Net.stream_socket) + +module Impl = struct + type t = unit + type tag = [`Unix | `Generic] + + let listen () ~reuse_addr ~reuse_port ~backlog ~sw listen_addr = + if reuse_addr then ( + match listen_addr with + | `Tcp _ -> () + | `Unix path -> + match Unix.lstat path with + | Unix.{ st_kind = S_SOCK; _ } -> Unix.unlink path + | _ -> () + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () + | exception Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg + ); + let addr = Eio_unix.Net.sockaddr_to_unix listen_addr in + let sock_unix = Unix.socket ~cloexec:true (socket_domain_of listen_addr) Unix.SOCK_STREAM 0 in + let sock = Fd.of_unix ~sw ~seekable:false ~close_unix:true sock_unix in + (* For Unix domain sockets, remove the path when done (except for abstract sockets). *) + begin match listen_addr with + | `Unix path -> + if String.length path > 0 && path.[0] <> Char.chr 0 then + Switch.on_release sw (fun () -> Unix.unlink path) + | `Tcp _ -> () + end; + if reuse_addr then + Unix.setsockopt sock_unix Unix.SO_REUSEADDR true; + if reuse_port then + Unix.setsockopt sock_unix Unix.SO_REUSEPORT true; + Unix.bind sock_unix addr; + Unix.listen sock_unix backlog; + (listening_socket sock :> _ Eio.Net.listening_socket_ty r) + + let connect () ~sw addr = (connect ~sw addr :> [`Generic | `Unix] Eio.Net.stream_socket_ty r) + + let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr = + if reuse_addr then ( + match saddr with + | `Udp _ | `UdpV4 | `UdpV6 -> () + | `Unix path -> + match Unix.lstat path with + | Unix.{ st_kind = S_SOCK; _ } -> Unix.unlink path + | _ -> () + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () + | exception Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg + ); + let sock_unix = Unix.socket ~cloexec:true (socket_domain_of saddr) Unix.SOCK_DGRAM 0 in + let sock = Fd.of_unix ~sw ~seekable:false ~close_unix:true sock_unix in + begin match saddr with + | `Udp _ | `Unix _ as saddr -> + let addr = Eio_unix.Net.sockaddr_to_unix saddr in + if reuse_addr then + Unix.setsockopt sock_unix Unix.SO_REUSEADDR true; + if reuse_port then + Unix.setsockopt sock_unix Unix.SO_REUSEPORT true; + Unix.bind sock_unix addr + | `UdpV4 | `UdpV6 -> () + end; + (datagram_socket sock :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r) + + let getaddrinfo () = Low_level.getaddrinfo + let getnameinfo () = Eio_unix.Net.getnameinfo +end + +let net = + let handler = Eio.Net.Pi.network (module Impl) in + Eio.Resource.T ((), handler) + +type stdenv = Eio_unix.Stdenv.base + +module Process_impl = struct + type t = Low_level.Process.t + type tag = [ `Generic | `Unix ] + + let pid = Low_level.Process.pid + + let await t = + match Eio.Promise.await @@ Low_level.Process.exit_status t with + | Unix.WEXITED i -> `Exited i + | Unix.WSIGNALED i -> `Signaled i + | Unix.WSTOPPED _ -> assert false + + let signal = Low_level.Process.signal +end + +let process = + let handler = Eio.Process.Pi.process (module Process_impl) in + fun proc -> Eio.Resource.T (proc, handler) + +(* fchdir wants just a directory FD, not an FD and a path like the *at functions. *) +let with_dir dir_fd path fn = + Switch.run ~name:"with_dir" @@ fun sw -> + Low_level.openat ~sw + ~seekable:false + ~access:`R + ~perm:0 + ~flags:Uring.Open_flags.(cloexec + path + directory) + dir_fd (if path = "" then "." else path) + |> fn + +module Process_mgr = struct + module T = struct + type t = unit + + let spawn_unix () ~sw ?cwd ~env ~fds ~executable args = + let actions = Low_level.Process.Fork_action.[ + Eio_unix.Private.Fork_action.inherit_fds fds; + execve executable ~argv:(Array.of_list args) ~env + ] in + let with_actions cwd fn = match cwd with + | None -> fn actions + | Some (fd, s) -> + match get_dir_fd_opt fd with + | None -> Fmt.invalid_arg "cwd is not an OS directory!" + | Some dir_fd -> + with_dir dir_fd s @@ fun cwd -> + fn (Low_level.Process.Fork_action.fchdir cwd :: actions) + in + with_actions cwd @@ fun actions -> + process (Low_level.Process.spawn ~sw actions) + end + + include Eio_unix.Process.Make_mgr (T) +end + +let process_mgr : Eio_unix.Process.mgr_ty r = + let h = Eio_unix.Process.Pi.mgr_unix (module Process_mgr) in + Eio.Resource.T ((), h) + +let wrap_backtrace fn x = + match fn x with + | x -> Ok x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + Error (ex, bt) + +let unwrap_backtrace = function + | Ok x -> x + | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt + +module Domain_mgr = struct + type t = { + run_event_loop : (unit -> unit) -> unit -> unit; + } + + let domain_spawn sched k fn = + Domain.spawn @@ fun () -> + Trace.domain_spawn ~parent:(Suspended.tid k); + Fun.protect fn ~finally:(fun () -> Sched.enqueue_thread sched k ()) + + let make ~run_event_loop = { run_event_loop } + + let run_raw _t fn = + let domain = ref None in + Sched.enter "run-domain" (fun sched k -> + let fn = wrap_backtrace fn in + domain := Some (domain_spawn sched k fn) + ); + unwrap_backtrace (Domain.join (Option.get !domain)) + + let run t fn = + let domain = ref None in + Sched.enter "run-domain" (fun sched k -> + let cancelled, set_cancelled = Promise.create () in + Fiber_context.set_cancel_fn k.fiber (Promise.resolve set_cancelled); + domain := Some (domain_spawn sched k (fun () -> + let result = ref None in + let fn = wrap_backtrace (fun () -> fn ~cancelled) in + t.run_event_loop (fun () -> result := Some (fn ())) (); + Option.get !result + )) + ); + Trace.with_span "Domain.join" @@ fun () -> + unwrap_backtrace (Domain.join (Option.get !domain)) +end + +let domain_mgr ~run_event_loop = + let handler = Eio.Domain_manager.Pi.mgr (module Domain_mgr) in + Eio.Resource.T (Domain_mgr.make ~run_event_loop, handler) + +module Mono_clock = struct + type t = unit + type time = Mtime.t + + let now () = Mtime_clock.now () + let sleep_until () time = Low_level.sleep_until time +end + +let mono_clock : Mtime.t Eio.Time.clock_ty r = + let handler = Eio.Time.Pi.clock (module Mono_clock) in + Eio.Resource.T ((), handler) + +module Clock = struct + type t = unit + type time = float + + let now () = Unix.gettimeofday () + + let sleep_until () time = + (* todo: use the realtime clock directly instead of converting to monotonic time. + That is needed to handle adjustments to the system clock correctly. *) + let d = time -. Unix.gettimeofday () in + Eio.Time.Mono.sleep mono_clock d +end + +let clock : float Eio.Time.clock_ty r = + let handler = Eio.Time.Pi.clock (module Clock) in + Eio.Resource.T ((), handler) + +module rec Dir : sig + include Eio.Fs.Pi.DIR + + val v : label:string -> path:string -> Low_level.dir_fd -> t + + val close : t -> unit + + val fd : t -> Low_level.dir_fd +end = struct + type t = { + fd : Low_level.dir_fd; + label : string; + path : string; + } + + let v ~label ~path fd = { fd; label; path } + + let open_in t ~sw path = + let fd = Low_level.openat ~sw t.fd path + ~access:`R + ~flags:Uring.Open_flags.cloexec + ~perm:0 + in + (Flow.of_fd fd :> Eio.File.ro_ty r) + + let open_out t ~sw ~append ~create path = + let perm, flags = + match create with + | `Never -> 0, Uring.Open_flags.empty + | `If_missing perm -> perm, Uring.Open_flags.creat + | `Or_truncate perm -> perm, Uring.Open_flags.(creat + trunc) + | `Exclusive perm -> perm, Uring.Open_flags.(creat + excl) + in + let flags = if append then Uring.Open_flags.(flags + append) else flags in + let fd = Low_level.openat ~sw t.fd path + ~access:`RW + ~flags:Uring.Open_flags.(cloexec + flags) + ~perm + in + (Flow.of_fd fd :> Eio.File.rw_ty r) + + let native_internal t path = + if Filename.is_relative path then ( + let p = Filename.concat t.path path in + if p = "" then "." + else if p = "." then p + else if Filename.is_implicit p then "./" ^ p + else p + ) else path + + let open_dir t ~sw path = + let fd = Low_level.openat ~sw ~seekable:false t.fd (if path = "" then "." else path) + ~access:`R + ~flags:Uring.Open_flags.(cloexec + path + directory) + ~perm:0 + in + let label = Filename.basename path in + let d = v ~label ~path:(native_internal t path) (Low_level.FD fd) in + Eio.Resource.T (d, Dir_handler.v) + + let mkdir t ~perm path = Low_level.mkdir ~perm t.fd path + + let read_dir t path = + Switch.run ~name:"read_dir" @@ fun sw -> + let path = if path = "" then "." else path in + let fd = + Low_level.openat ~sw t.fd path + ~seekable:false + ~access:`R + ~flags:Uring.Open_flags.(cloexec + directory) + ~perm:0 + in + Low_level.read_dir fd + + let read_link t path = Low_level.read_link t.fd path + + let close t = + match t.fd with + | FD x -> Fd.close x + | Cwd | Fs -> failwith "Can't close non-FD directory!" + + let unlink t path = Low_level.unlink ~rmdir:false t.fd path + let rmdir t path = Low_level.unlink ~rmdir:true t.fd path + + let float_of_time s ns = + let s = Int64.to_float s in + let f = s +. (float ns /. 1e9) in + (* It's possible that we might round up to the next second. + Since some algorithms only care about the seconds part, + make sure the integer part is always [s]: *) + if floor f = s then f + else Float.pred f + + let stat t ~follow path = + if !Sched.statx_works then ( + let module X = Uring.Statx in + let x = X.create () in + Low_level.statx ~follow ~mask:X.Mask.basic_stats t.fd path x; + { Eio.File.Stat. + dev = X.dev x; + ino = X.ino x; + kind = X.kind x; + perm = X.perm x; + nlink = X.nlink x; + uid = X.uid x; + gid = X.gid x; + rdev = X.rdev x; + size = X.size x |> Optint.Int63.of_int64; + atime = float_of_time (X.atime_sec x) (X.atime_nsec x); + mtime = float_of_time (X.mtime_sec x) (X.mtime_nsec x); + ctime = float_of_time (X.ctime_sec x) (X.ctime_nsec x); + } + ) else ( + (* Linux < 5.18 *) + Switch.run ~name:"stat" @@ fun sw -> + let fd = Low_level.openat ~sw ~seekable:false t.fd (if path = "" then "." else path) + ~access:`R + ~flags:Uring.Open_flags.(cloexec + path + (if follow then empty else nofollow)) + ~perm:0 + in + Low_level.fstat fd + ) + + let rename t old_path t2 new_path = + match get_dir_fd_opt t2 with + | Some fd2 -> Low_level.rename t.fd old_path fd2 new_path + | None -> raise (Unix.Unix_error (Unix.EXDEV, "rename-dst", new_path)) + + let symlink ~link_to t path = + Low_level.symlink ~link_to t.fd path + + let pp f t = Fmt.string f (String.escaped t.label) + + let fd t = t.fd + + let native t path = + Some (native_internal t path) +end +and Dir_handler : sig + val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler +end = struct + let v = Eio.Resource.handler [ + H (Eio.Fs.Pi.Dir, (module Dir)); + H (Eio.Resource.Close, Dir.close); + H (Dir_fd, Dir.fd); + ] +end + +let dir ~label ~path fd = Eio.Resource.T (Dir.v ~label ~path fd, Dir_handler.v) + +let stdenv ~run_event_loop = + let fs = (dir ~label:"fs" ~path:"" Fs, "") in + let cwd = (dir ~label:"cwd" ~path:"" Cwd, "") in + object (_ : stdenv) + method stdin = Flow.stdin + method stdout = Flow.stdout + method stderr = Flow.stderr + method net = net + method process_mgr = process_mgr + method domain_mgr = domain_mgr ~run_event_loop + method clock = clock + method mono_clock = mono_clock + method fs = (fs :> Eio.Fs.dir_ty Eio.Path.t) + method cwd = (cwd :> Eio.Fs.dir_ty Eio.Path.t) + method secure_random = Flow.secure_random + method debug = Eio.Private.Debug.v + method backend_id = "linux" + end + +let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a = + Sched.with_sched ?fallback config @@ fun st -> + let open Effect.Deep in + let extra_effects : _ effect_handler = { + effc = fun (type a) (e : a Effect.t) : ((a, Sched.exit) continuation -> Sched.exit) option -> + match e with + | Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k mono_clock) + | Eio_unix.Net.Import_socket_stream (sw, close_unix, fd) -> Some (fun k -> + let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in + continue k (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) + ) + | Eio_unix.Net.Import_socket_listening (sw, close_unix, fd) -> Some (fun k -> + let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in + continue k (listening_socket fd) + ) + | Eio_unix.Net.Import_socket_datagram (sw, close_unix, fd) -> Some (fun k -> + let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in + continue k (datagram_socket fd) + ) + | Eio_unix.Net.Socketpair_stream (sw, domain, protocol) -> Some (fun k -> + match + let a, b = Unix.socketpair ~cloexec:true domain Unix.SOCK_STREAM protocol in + let a = Fd.of_unix ~sw ~seekable:false ~close_unix:true a |> Flow.of_fd in + let b = Fd.of_unix ~sw ~seekable:false ~close_unix:true b |> Flow.of_fd in + ((a :> _ Eio_unix.Net.stream_socket), (b :> _ Eio_unix.Net.stream_socket)) + with + | r -> continue k r + | exception Unix.Unix_error (code, name, arg) -> + discontinue k (Err.wrap code name arg) + ) + | Eio_unix.Net.Socketpair_datagram (sw, domain, protocol) -> Some (fun k -> + match + let a, b = Unix.socketpair ~cloexec:true domain Unix.SOCK_DGRAM protocol in + let a = Fd.of_unix ~sw ~seekable:false ~close_unix:true a |> datagram_socket in + let b = Fd.of_unix ~sw ~seekable:false ~close_unix:true b |> datagram_socket in + ((a :> _ Eio_unix.Net.datagram_socket), (b :> _ Eio_unix.Net.datagram_socket)) + with + | r -> continue k r + | exception Unix.Unix_error (code, name, arg) -> + discontinue k (Err.wrap code name arg) + ) + | Eio_unix.Private.Pipe sw -> Some (fun k -> + match + let r, w = Low_level.pipe ~sw in + let r = (Flow.of_fd r :> _ Eio_unix.source) in + let w = (Flow.of_fd w :> _ Eio_unix.sink) in + (r, w) + with + | r -> continue k r + | exception Unix.Unix_error (code, name, arg) -> + discontinue k (Err.wrap code name arg) + ) + | _ -> None + } in + Sched.run ~extra_effects st main arg + +let run ?queue_depth ?n_blocks ?block_size ?polling_timeout ?fallback main = + let config = Sched.config ?queue_depth ?n_blocks ?block_size ?polling_timeout () in + let stdenv = stdenv ~run_event_loop:(run_event_loop ?fallback:None config) in + (* SIGPIPE makes no sense in a modern application. *) + Sys.(set_signal sigpipe Signal_ignore); + run_event_loop ?fallback config main stdenv diff --git a/lib_eio_linux/eio_linux.mli b/lib_eio_linux/eio_linux.mli index 6159bc29d..6900b5b02 100644 --- a/lib_eio_linux/eio_linux.mli +++ b/lib_eio_linux/eio_linux.mli @@ -1,50 +1,50 @@ -(** Eio backend using Linux's io_uring. - - You will normally not use this module directly. - Instead, use {!Eio_main.run} to start an event loop and then use the API in the {!Eio} module. - - However, it is possible to use this module directly if you only want to support recent versions of Linux. *) - -(* - * Copyright (C) 2020-2021 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -(** {1 Main Loop} *) - -type stdenv = Eio_unix.Stdenv.base - -val run : - ?queue_depth:int -> - ?n_blocks:int -> - ?block_size:int -> - ?polling_timeout:int -> - ?fallback:([`Msg of string] -> 'a) -> - (stdenv -> 'a) -> 'a -(** Run an event loop using io_uring. - - Uses {!Uring.create} to create the io_uring, - and {!Uring.set_fixed_buffer} to set a [block_size * n_blocks] fixed buffer. - - Note that if Linux resource limits prevent the requested fixed buffer from being allocated - then [run] will continue without one (and log a warning). - - For portable code, you should use {!Eio_main.run} instead, which will use this automatically - if running on Linux with a recent-enough kernel version. - - @param fallback Call this instead if io_uring is not available for some reason. - The argument is a message describing the problem (for logging). - The default simply raises an exception. *) - -module Low_level = Low_level +(** Eio backend using Linux's io_uring. + + You will normally not use this module directly. + Instead, use {!Eio_main.run} to start an event loop and then use the API in the {!Eio} module. + + However, it is possible to use this module directly if you only want to support recent versions of Linux. *) + +(* + * Copyright (C) 2020-2021 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {1 Main Loop} *) + +type stdenv = Eio_unix.Stdenv.base + +val run : + ?queue_depth:int -> + ?n_blocks:int -> + ?block_size:int -> + ?polling_timeout:int -> + ?fallback:([`Msg of string] -> 'a) -> + (stdenv -> 'a) -> 'a +(** Run an event loop using io_uring. + + Uses {!Uring.create} to create the io_uring, + and {!Uring.set_fixed_buffer} to set a [block_size * n_blocks] fixed buffer. + + Note that if Linux resource limits prevent the requested fixed buffer from being allocated + then [run] will continue without one (and log a warning). + + For portable code, you should use {!Eio_main.run} instead, which will use this automatically + if running on Linux with a recent-enough kernel version. + + @param fallback Call this instead if io_uring is not available for some reason. + The argument is a message describing the problem (for logging). + The default simply raises an exception. *) + +module Low_level = Low_level diff --git a/lib_eio_linux/eio_stubs.c b/lib_eio_linux/eio_stubs.c index 4e4054104..d93c30c42 100644 --- a/lib_eio_linux/eio_stubs.c +++ b/lib_eio_linux/eio_stubs.c @@ -1,238 +1,238 @@ -#define _GNU_SOURCE -#include - -#include -#include -#include -#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24 -#include -#endif -#include -#include -#include -#include -#include -#include -#include -#include - -// We need caml_convert_signal_number -#define CAML_INTERNALS - -#include "primitives.h" - -#include -#include -#include -#include -#include -#include - -#include "fork_action.h" - -#ifndef SYS_pidfd_send_signal -# define SYS_pidfd_send_signal 424 -#endif -#ifndef SYS_pidfd_open -# define SYS_pidfd_open 434 -#endif -#ifndef SYS_clone3 -# define SYS_clone3 435 -# define CLONE_PIDFD 0x00001000 -#endif - -// struct clone_args isn't defined in linux-lts headers, so define it here -// Note that this struct is versioned by size. See linux/sched.h for details -struct caml_eio_clone_args { - uint64_t flags; - uint64_t pidfd; - uint64_t child_tid; - uint64_t parent_tid; - uint64_t exit_signal; - uint64_t stack; - uint64_t stack_size; - uint64_t tls; -}; - -// Make sure we have enough space for at least one entry. -#define DIRENT_BUF_SIZE (PATH_MAX + sizeof(struct dirent64)) - -CAMLprim value caml_eio_eventfd(value v_initval) { - int ret; - ret = eventfd(Int_val(v_initval), EFD_CLOEXEC); - if (ret == -1) uerror("eventfd", Nothing); - return Val_int(ret); -} - -CAMLprim value caml_eio_mkdirat(value v_fd, value v_path, value v_perm) { - CAMLparam1(v_path); - char *path; - int ret; - caml_unix_check_path(v_path, "mkdirat"); - path = caml_stat_strdup(String_val(v_path)); - caml_enter_blocking_section(); - ret = mkdirat(Int_val(v_fd), path, Int_val(v_perm)); - caml_leave_blocking_section(); - caml_stat_free(path); - if (ret == -1) uerror("mkdirat", v_path); - CAMLreturn(Val_unit); -} - -CAMLprim value caml_eio_renameat(value v_old_fd, value v_old_path, value v_new_fd, value v_new_path) { - CAMLparam2(v_old_path, v_new_path); - char *old_path; - char *new_path; - int ret; - caml_unix_check_path(v_old_path, "renameat-old"); - caml_unix_check_path(v_new_path, "renameat-new"); - old_path = caml_stat_strdup(String_val(v_old_path)); - new_path = caml_stat_strdup(String_val(v_new_path)); - caml_enter_blocking_section(); - ret = renameat(Int_val(v_old_fd), old_path, - Int_val(v_new_fd), new_path); - caml_leave_blocking_section(); - caml_stat_free(old_path); - caml_stat_free(new_path); - if (ret == -1) uerror("renameat", v_old_path); - CAMLreturn(Val_unit); -} - -CAMLprim value caml_eio_symlinkat(value v_old_path, value v_new_fd, value v_new_path) { - CAMLparam2(v_old_path, v_new_path); - char *old_path; - char *new_path; - int ret; - caml_unix_check_path(v_old_path, "symlinkat-old"); - caml_unix_check_path(v_new_path, "symlinkat-new"); - old_path = caml_stat_strdup(String_val(v_old_path)); - new_path = caml_stat_strdup(String_val(v_new_path)); - caml_enter_blocking_section(); - ret = symlinkat(old_path, Int_val(v_new_fd), new_path); - caml_leave_blocking_section(); - caml_stat_free(old_path); - caml_stat_free(new_path); - if (ret == -1) uerror("symlinkat", v_old_path); - CAMLreturn(Val_unit); -} - -CAMLprim value caml_eio_getrandom(value v_ba, value v_off, value v_len) { - CAMLparam1(v_ba); - ssize_t ret; - ssize_t off = (ssize_t)Long_val(v_off); - ssize_t len = (ssize_t)Long_val(v_len); - do { - void *buf = (char *)Caml_ba_data_val(v_ba) + off; - caml_enter_blocking_section(); -#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24 - ret = getrandom(buf, len, 0); -#else - ret = syscall(SYS_getrandom, buf, len, 0); -#endif - caml_leave_blocking_section(); - } while (ret == -1 && errno == EINTR); - if (ret == -1) uerror("getrandom", Nothing); - CAMLreturn(Val_long(ret)); -} - -CAMLprim value caml_eio_getdents(value v_fd) { - CAMLparam1(v_fd); - CAMLlocal2(result, cons); - char buf[DIRENT_BUF_SIZE]; - struct dirent64 *d; - int nread, pos; - caml_enter_blocking_section(); - nread = syscall(SYS_getdents64, Int_val(v_fd), buf, DIRENT_BUF_SIZE); - caml_leave_blocking_section(); - if (nread == -1) uerror("getdents", Nothing); - - result = Val_int(0); /* The empty list */ - - for (pos = 0; pos < nread;) { - d = (struct dirent64 *) (buf + pos); - cons = caml_alloc(2, 0); - Store_field(cons, 0, caml_copy_string_of_os(d->d_name)); // Head - Store_field(cons, 1, result); // Tail - result = cons; - pos += d->d_reclen; - } - - CAMLreturn(result); -} - -static int pidfd_send_signal(int pidfd, int sig, siginfo_t *info, unsigned int flags) { - return syscall(SYS_pidfd_send_signal, pidfd, sig, info, flags); -} - -CAMLprim value caml_eio_pidfd_send_signal(value v_pidfd, value v_signal) { - CAMLparam0(); - int res; - - res = pidfd_send_signal(Int_val(v_pidfd), caml_convert_signal_number(Int_val(v_signal)), NULL, 0); - if (res == -1) uerror("pidfd_send_signal", Nothing); - CAMLreturn(Val_unit); -} - -static int pidfd_open(pid_t pid, unsigned int flags) { - return syscall(SYS_pidfd_open, pid, flags); -} - -/* Like clone3, but falls back to fork if not supported. - Also, raises exceptions rather then returning an error. */ -static pid_t clone3_with_fallback(struct caml_eio_clone_args *cl_args) { - int *pidfd = (int *)(uintptr_t) cl_args->pidfd; - pid_t child_pid = syscall(SYS_clone3, cl_args, sizeof(struct caml_eio_clone_args)); - - if (child_pid >= 0) - return child_pid; /* Success! */ - - if (errno != ENOSYS && errno != EPERM) { - uerror("clone3", Nothing); /* Unknown error */ - } - - /* Probably Docker's security policy is blocking clone3. Fall back to forking. */ - - child_pid = fork(); - if (child_pid == 0) { - /* We are the child */ - return 0; - } else if (child_pid < 0) { - uerror("fork", Nothing); - } - - *pidfd = pidfd_open(child_pid, 0); /* Is automatically close-on-exec */ - if (*pidfd < 0) { - int e = errno; - kill(child_pid, SIGKILL); - waitpid(child_pid, NULL, 0); - errno = e; - uerror("pidfd_open", Nothing); - } - - return child_pid; -} - -CAMLprim value caml_eio_clone3(value v_errors, value v_actions) { - CAMLparam1(v_actions); - CAMLlocal1(v_result); - pid_t child_pid; - int pidfd = -1; /* Is automatically close-on-exec */ - struct caml_eio_clone_args cl_args = { - .flags = CLONE_PIDFD, - .pidfd = (uintptr_t) &pidfd, - .exit_signal = SIGCHLD, /* Needed for wait4 to work if we exit before exec */ - .stack = (uintptr_t) NULL, /* Use copy-on-write parent stack */ - .stack_size = 0, - }; - - child_pid = clone3_with_fallback(&cl_args); - if (child_pid == 0) { - /* Run child actions (doesn't return) */ - eio_unix_run_fork_actions(Int_val(v_errors), v_actions); - } - - v_result = caml_alloc_tuple(2); - Store_field(v_result, 0, Val_long(child_pid)); - Store_field(v_result, 1, Val_int(pidfd)); - - CAMLreturn(v_result); -} +#define _GNU_SOURCE +#include + +#include +#include +#include +#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24 +#include +#endif +#include +#include +#include +#include +#include +#include +#include +#include + +// We need caml_convert_signal_number +#define CAML_INTERNALS + +#include "primitives.h" + +#include +#include +#include +#include +#include +#include + +#include "fork_action.h" + +#ifndef SYS_pidfd_send_signal +# define SYS_pidfd_send_signal 424 +#endif +#ifndef SYS_pidfd_open +# define SYS_pidfd_open 434 +#endif +#ifndef SYS_clone3 +# define SYS_clone3 435 +# define CLONE_PIDFD 0x00001000 +#endif + +// struct clone_args isn't defined in linux-lts headers, so define it here +// Note that this struct is versioned by size. See linux/sched.h for details +struct caml_eio_clone_args { + uint64_t flags; + uint64_t pidfd; + uint64_t child_tid; + uint64_t parent_tid; + uint64_t exit_signal; + uint64_t stack; + uint64_t stack_size; + uint64_t tls; +}; + +// Make sure we have enough space for at least one entry. +#define DIRENT_BUF_SIZE (PATH_MAX + sizeof(struct dirent64)) + +CAMLprim value caml_eio_eventfd(value v_initval) { + int ret; + ret = eventfd(Int_val(v_initval), EFD_CLOEXEC); + if (ret == -1) uerror("eventfd", Nothing); + return Val_int(ret); +} + +CAMLprim value caml_eio_mkdirat(value v_fd, value v_path, value v_perm) { + CAMLparam1(v_path); + char *path; + int ret; + caml_unix_check_path(v_path, "mkdirat"); + path = caml_stat_strdup(String_val(v_path)); + caml_enter_blocking_section(); + ret = mkdirat(Int_val(v_fd), path, Int_val(v_perm)); + caml_leave_blocking_section(); + caml_stat_free(path); + if (ret == -1) uerror("mkdirat", v_path); + CAMLreturn(Val_unit); +} + +CAMLprim value caml_eio_renameat(value v_old_fd, value v_old_path, value v_new_fd, value v_new_path) { + CAMLparam2(v_old_path, v_new_path); + char *old_path; + char *new_path; + int ret; + caml_unix_check_path(v_old_path, "renameat-old"); + caml_unix_check_path(v_new_path, "renameat-new"); + old_path = caml_stat_strdup(String_val(v_old_path)); + new_path = caml_stat_strdup(String_val(v_new_path)); + caml_enter_blocking_section(); + ret = renameat(Int_val(v_old_fd), old_path, + Int_val(v_new_fd), new_path); + caml_leave_blocking_section(); + caml_stat_free(old_path); + caml_stat_free(new_path); + if (ret == -1) uerror("renameat", v_old_path); + CAMLreturn(Val_unit); +} + +CAMLprim value caml_eio_symlinkat(value v_old_path, value v_new_fd, value v_new_path) { + CAMLparam2(v_old_path, v_new_path); + char *old_path; + char *new_path; + int ret; + caml_unix_check_path(v_old_path, "symlinkat-old"); + caml_unix_check_path(v_new_path, "symlinkat-new"); + old_path = caml_stat_strdup(String_val(v_old_path)); + new_path = caml_stat_strdup(String_val(v_new_path)); + caml_enter_blocking_section(); + ret = symlinkat(old_path, Int_val(v_new_fd), new_path); + caml_leave_blocking_section(); + caml_stat_free(old_path); + caml_stat_free(new_path); + if (ret == -1) uerror("symlinkat", v_old_path); + CAMLreturn(Val_unit); +} + +CAMLprim value caml_eio_getrandom(value v_ba, value v_off, value v_len) { + CAMLparam1(v_ba); + ssize_t ret; + ssize_t off = (ssize_t)Long_val(v_off); + ssize_t len = (ssize_t)Long_val(v_len); + do { + void *buf = (char *)Caml_ba_data_val(v_ba) + off; + caml_enter_blocking_section(); +#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24 + ret = getrandom(buf, len, 0); +#else + ret = syscall(SYS_getrandom, buf, len, 0); +#endif + caml_leave_blocking_section(); + } while (ret == -1 && errno == EINTR); + if (ret == -1) uerror("getrandom", Nothing); + CAMLreturn(Val_long(ret)); +} + +CAMLprim value caml_eio_getdents(value v_fd) { + CAMLparam1(v_fd); + CAMLlocal2(result, cons); + char buf[DIRENT_BUF_SIZE]; + struct dirent64 *d; + int nread, pos; + caml_enter_blocking_section(); + nread = syscall(SYS_getdents64, Int_val(v_fd), buf, DIRENT_BUF_SIZE); + caml_leave_blocking_section(); + if (nread == -1) uerror("getdents", Nothing); + + result = Val_int(0); /* The empty list */ + + for (pos = 0; pos < nread;) { + d = (struct dirent64 *) (buf + pos); + cons = caml_alloc(2, 0); + Store_field(cons, 0, caml_copy_string_of_os(d->d_name)); // Head + Store_field(cons, 1, result); // Tail + result = cons; + pos += d->d_reclen; + } + + CAMLreturn(result); +} + +static int pidfd_send_signal(int pidfd, int sig, siginfo_t *info, unsigned int flags) { + return syscall(SYS_pidfd_send_signal, pidfd, sig, info, flags); +} + +CAMLprim value caml_eio_pidfd_send_signal(value v_pidfd, value v_signal) { + CAMLparam0(); + int res; + + res = pidfd_send_signal(Int_val(v_pidfd), caml_convert_signal_number(Int_val(v_signal)), NULL, 0); + if (res == -1) uerror("pidfd_send_signal", Nothing); + CAMLreturn(Val_unit); +} + +static int pidfd_open(pid_t pid, unsigned int flags) { + return syscall(SYS_pidfd_open, pid, flags); +} + +/* Like clone3, but falls back to fork if not supported. + Also, raises exceptions rather then returning an error. */ +static pid_t clone3_with_fallback(struct caml_eio_clone_args *cl_args) { + int *pidfd = (int *)(uintptr_t) cl_args->pidfd; + pid_t child_pid = syscall(SYS_clone3, cl_args, sizeof(struct caml_eio_clone_args)); + + if (child_pid >= 0) + return child_pid; /* Success! */ + + if (errno != ENOSYS && errno != EPERM) { + uerror("clone3", Nothing); /* Unknown error */ + } + + /* Probably Docker's security policy is blocking clone3. Fall back to forking. */ + + child_pid = fork(); + if (child_pid == 0) { + /* We are the child */ + return 0; + } else if (child_pid < 0) { + uerror("fork", Nothing); + } + + *pidfd = pidfd_open(child_pid, 0); /* Is automatically close-on-exec */ + if (*pidfd < 0) { + int e = errno; + kill(child_pid, SIGKILL); + waitpid(child_pid, NULL, 0); + errno = e; + uerror("pidfd_open", Nothing); + } + + return child_pid; +} + +CAMLprim value caml_eio_clone3(value v_errors, value v_actions) { + CAMLparam1(v_actions); + CAMLlocal1(v_result); + pid_t child_pid; + int pidfd = -1; /* Is automatically close-on-exec */ + struct caml_eio_clone_args cl_args = { + .flags = CLONE_PIDFD, + .pidfd = (uintptr_t) &pidfd, + .exit_signal = SIGCHLD, /* Needed for wait4 to work if we exit before exec */ + .stack = (uintptr_t) NULL, /* Use copy-on-write parent stack */ + .stack_size = 0, + }; + + child_pid = clone3_with_fallback(&cl_args); + if (child_pid == 0) { + /* Run child actions (doesn't return) */ + eio_unix_run_fork_actions(Int_val(v_errors), v_actions); + } + + v_result = caml_alloc_tuple(2); + Store_field(v_result, 0, Val_long(child_pid)); + Store_field(v_result, 1, Val_int(pidfd)); + + CAMLreturn(v_result); +} diff --git a/lib_eio_linux/err.ml b/lib_eio_linux/err.ml index 6099cc5a5..0c96eb927 100644 --- a/lib_eio_linux/err.ml +++ b/lib_eio_linux/err.ml @@ -1,16 +1,16 @@ -let unclassified e = Eio.Exn.create (Eio.Exn.X e) - -let wrap code name arg = - let ex = Eio_unix.Unix_error (code, name, arg) in - match code with - | ECONNREFUSED -> Eio.Net.err (Connection_failure (Refused ex)) - | ECONNRESET | EPIPE -> Eio.Net.err (Connection_reset ex) - | _ -> unclassified ex - -let wrap_fs code name arg = - let e = Eio_unix.Unix_error (code, name, arg) in - match code with - | Unix.EEXIST -> Eio.Fs.err (Already_exists e) - | Unix.ENOENT -> Eio.Fs.err (Not_found e) - | Unix.EXDEV | EPERM | EACCES -> Eio.Fs.err (Permission_denied e) - | _ -> wrap code name arg +let unclassified e = Eio.Exn.create (Eio.Exn.X e) + +let wrap code name arg = + let ex = Eio_unix.Unix_error (code, name, arg) in + match code with + | ECONNREFUSED -> Eio.Net.err (Connection_failure (Refused ex)) + | ECONNRESET | EPIPE -> Eio.Net.err (Connection_reset ex) + | _ -> unclassified ex + +let wrap_fs code name arg = + let e = Eio_unix.Unix_error (code, name, arg) in + match code with + | Unix.EEXIST -> Eio.Fs.err (Already_exists e) + | Unix.ENOENT -> Eio.Fs.err (Not_found e) + | Unix.EXDEV | EPERM | EACCES -> Eio.Fs.err (Permission_denied e) + | _ -> wrap code name arg diff --git a/lib_eio_linux/flow.ml b/lib_eio_linux/flow.ml index a280527ef..d8b35c0c6 100644 --- a/lib_eio_linux/flow.ml +++ b/lib_eio_linux/flow.ml @@ -1,157 +1,157 @@ -open Eio.Std - -(* When copying between a source with an FD and a sink with an FD, we can share the chunk - and avoid copying. *) -let fast_copy src dst = - let fallback () = - (* No chunks available. Use regular memory instead. *) - let buf = Cstruct.create 4096 in - try - while true do - let got = Low_level.readv src [buf] in - Low_level.writev dst [Cstruct.sub buf 0 got] - done - with End_of_file -> () - in - Low_level.with_chunk ~fallback @@ fun chunk -> - let chunk_size = Uring.Region.length chunk in - try - while true do - let got = Low_level.read_upto src chunk chunk_size in - Low_level.write dst chunk got - done - with End_of_file -> () - -(* Try a fast copy using splice. If the FDs don't support that, switch to copying. *) -let _fast_copy_try_splice src dst = - try - while true do - let _ : int = Low_level.splice src ~dst ~len:max_int in - () - done - with - | End_of_file -> () - | Eio.Exn.Io (Eio.Exn.X Eio_unix.Unix_error ((EAGAIN | EINVAL), "splice", _), _) -> fast_copy src dst - -(* XXX workaround for issue #319, PR #327 *) -let fast_copy_try_splice src dst = fast_copy src dst - -let[@tail_mod_cons] rec list_take n = function - | [] -> [] - | x :: xs -> - if n = 0 then [] - else x :: list_take (n - 1) xs - -let truncate_to_iomax xs = - if List.compare_length_with xs Uring.iov_max <= 0 then xs - else list_take Uring.iov_max xs - -(* Copy using the [Read_source_buffer] optimisation. - Avoids a copy if the source already has the data. *) -let copy_with_rsb rsb dst = - let write xs = Low_level.writev_single dst (truncate_to_iomax xs) in - try - while true do rsb write done - with End_of_file -> () - -(* Copy by allocating a chunk from the pre-shared buffer and asking - the source to write into it. This used when the other methods - aren't available. *) -let fallback_copy (type src) (module Src : Eio.Flow.Pi.SOURCE with type t = src) src dst = - let fallback () = - (* No chunks available. Use regular memory instead. *) - let buf = Cstruct.create 4096 in - try - while true do - let got = Src.single_read src buf in - Low_level.writev dst [Cstruct.sub buf 0 got] - done - with End_of_file -> () - in - Low_level.with_chunk ~fallback @@ fun chunk -> - let chunk_cs = Uring.Region.to_cstruct chunk in - try - while true do - let got = Src.single_read src chunk_cs in - Low_level.write dst chunk got - done - with End_of_file -> () - -module Impl = struct - type tag = [`Generic | `Unix] - - type t = Eio_unix.Fd.t - - let fd t = t - - let close = Eio_unix.Fd.close - - let stat = Low_level.fstat - - let single_read t buf = - Low_level.readv t [buf] - - let pread t ~file_offset bufs = - Low_level.readv ~file_offset t bufs - - let pwrite t ~file_offset bufs = - Low_level.writev_single ~file_offset t (truncate_to_iomax bufs) - - let read_methods = [] - - let single_write t bufs = Low_level.writev_single t (truncate_to_iomax bufs) - - let copy t ~src = - match Eio_unix.Resource.fd_opt src with - | Some src -> fast_copy_try_splice src t - | None -> - let Eio.Resource.T (src, ops) = src in - let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in - let rec aux = function - | Eio.Flow.Read_source_buffer rsb :: _ -> copy_with_rsb (rsb src) t - | _ :: xs -> aux xs - | [] -> fallback_copy (module Src) src t - in - aux Src.read_methods - - let shutdown t cmd = - Low_level.shutdown t @@ match cmd with - | `Receive -> Unix.SHUTDOWN_RECEIVE - | `Send -> Unix.SHUTDOWN_SEND - | `All -> Unix.SHUTDOWN_ALL - - let send_msg t ~fds data = - Low_level.send_msg t ~fds data - - let recv_msg_with_fds t ~sw ~max_fds data = - let _addr, n, fds = Low_level.recv_msg_with_fds t ~sw ~max_fds data in - n, fds - - let seek = Low_level.lseek - let sync = Low_level.fsync - let truncate = Low_level.ftruncate -end - -let flow_handler = Eio_unix.Pi.flow_handler (module Impl) - -let of_fd fd = - let r = Eio.Resource.T (fd, flow_handler) in - (r : [`Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :> - [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r) - -let source fd = (of_fd fd :> Eio_unix.source_ty r) -let sink fd = (of_fd fd :> Eio_unix.sink_ty r) - -let stdin = source Eio_unix.Fd.stdin -let stdout = sink Eio_unix.Fd.stdout -let stderr = sink Eio_unix.Fd.stderr - -module Secure_random = struct - type t = unit - let single_read () buf = Low_level.getrandom buf; Cstruct.length buf - let read_methods = [] -end - -let secure_random = - let ops = Eio.Flow.Pi.source (module Secure_random) in - Eio.Resource.T ((), ops) +open Eio.Std + +(* When copying between a source with an FD and a sink with an FD, we can share the chunk + and avoid copying. *) +let fast_copy src dst = + let fallback () = + (* No chunks available. Use regular memory instead. *) + let buf = Cstruct.create 4096 in + try + while true do + let got = Low_level.readv src [buf] in + Low_level.writev dst [Cstruct.sub buf 0 got] + done + with End_of_file -> () + in + Low_level.with_chunk ~fallback @@ fun chunk -> + let chunk_size = Uring.Region.length chunk in + try + while true do + let got = Low_level.read_upto src chunk chunk_size in + Low_level.write dst chunk got + done + with End_of_file -> () + +(* Try a fast copy using splice. If the FDs don't support that, switch to copying. *) +let _fast_copy_try_splice src dst = + try + while true do + let _ : int = Low_level.splice src ~dst ~len:max_int in + () + done + with + | End_of_file -> () + | Eio.Exn.Io (Eio.Exn.X Eio_unix.Unix_error ((EAGAIN | EINVAL), "splice", _), _) -> fast_copy src dst + +(* XXX workaround for issue #319, PR #327 *) +let fast_copy_try_splice src dst = fast_copy src dst + +let[@tail_mod_cons] rec list_take n = function + | [] -> [] + | x :: xs -> + if n = 0 then [] + else x :: list_take (n - 1) xs + +let truncate_to_iomax xs = + if List.compare_length_with xs Uring.iov_max <= 0 then xs + else list_take Uring.iov_max xs + +(* Copy using the [Read_source_buffer] optimisation. + Avoids a copy if the source already has the data. *) +let copy_with_rsb rsb dst = + let write xs = Low_level.writev_single dst (truncate_to_iomax xs) in + try + while true do rsb write done + with End_of_file -> () + +(* Copy by allocating a chunk from the pre-shared buffer and asking + the source to write into it. This used when the other methods + aren't available. *) +let fallback_copy (type src) (module Src : Eio.Flow.Pi.SOURCE with type t = src) src dst = + let fallback () = + (* No chunks available. Use regular memory instead. *) + let buf = Cstruct.create 4096 in + try + while true do + let got = Src.single_read src buf in + Low_level.writev dst [Cstruct.sub buf 0 got] + done + with End_of_file -> () + in + Low_level.with_chunk ~fallback @@ fun chunk -> + let chunk_cs = Uring.Region.to_cstruct chunk in + try + while true do + let got = Src.single_read src chunk_cs in + Low_level.write dst chunk got + done + with End_of_file -> () + +module Impl = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t + + let fd t = t + + let close = Eio_unix.Fd.close + + let stat = Low_level.fstat + + let single_read t buf = + Low_level.readv t [buf] + + let pread t ~file_offset bufs = + Low_level.readv ~file_offset t bufs + + let pwrite t ~file_offset bufs = + Low_level.writev_single ~file_offset t (truncate_to_iomax bufs) + + let read_methods = [] + + let single_write t bufs = Low_level.writev_single t (truncate_to_iomax bufs) + + let copy t ~src = + match Eio_unix.Resource.fd_opt src with + | Some src -> fast_copy_try_splice src t + | None -> + let Eio.Resource.T (src, ops) = src in + let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in + let rec aux = function + | Eio.Flow.Read_source_buffer rsb :: _ -> copy_with_rsb (rsb src) t + | _ :: xs -> aux xs + | [] -> fallback_copy (module Src) src t + in + aux Src.read_methods + + let shutdown t cmd = + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL + + let send_msg t ~fds data = + Low_level.send_msg t ~fds data + + let recv_msg_with_fds t ~sw ~max_fds data = + let _addr, n, fds = Low_level.recv_msg_with_fds t ~sw ~max_fds data in + n, fds + + let seek = Low_level.lseek + let sync = Low_level.fsync + let truncate = Low_level.ftruncate +end + +let flow_handler = Eio_unix.Pi.flow_handler (module Impl) + +let of_fd fd = + let r = Eio.Resource.T (fd, flow_handler) in + (r : [`Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :> + [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r) + +let source fd = (of_fd fd :> Eio_unix.source_ty r) +let sink fd = (of_fd fd :> Eio_unix.sink_ty r) + +let stdin = source Eio_unix.Fd.stdin +let stdout = sink Eio_unix.Fd.stdout +let stderr = sink Eio_unix.Fd.stderr + +module Secure_random = struct + type t = unit + let single_read () buf = Low_level.getrandom buf; Cstruct.length buf + let read_methods = [] +end + +let secure_random = + let ops = Eio.Flow.Pi.source (module Secure_random) in + Eio.Resource.T ((), ops) diff --git a/lib_eio_linux/flow.mli b/lib_eio_linux/flow.mli index f393bd4f2..afe3d59e5 100644 --- a/lib_eio_linux/flow.mli +++ b/lib_eio_linux/flow.mli @@ -1,9 +1,9 @@ -open Eio.Std - -val of_fd : Eio_unix.Fd.t -> [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r - -val stdin : Eio_unix.source_ty r -val stdout : Eio_unix.sink_ty r -val stderr : Eio_unix.sink_ty r - -val secure_random : Eio.Flow.source_ty r +open Eio.Std + +val of_fd : Eio_unix.Fd.t -> [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r + +val stdin : Eio_unix.source_ty r +val stdout : Eio_unix.sink_ty r +val stderr : Eio_unix.sink_ty r + +val secure_random : Eio.Flow.source_ty r diff --git a/lib_eio_linux/low_level.ml b/lib_eio_linux/low_level.ml index 42e72bfa3..a3c0c810f 100644 --- a/lib_eio_linux/low_level.ml +++ b/lib_eio_linux/low_level.ml @@ -1,629 +1,629 @@ -[@@@alert "-unstable"] - -open Eio.Std - -module Trace = Eio.Private.Trace -module Fd = Eio_unix.Fd - -type dir_fd = - | FD of Fd.t - | Cwd (* Confined to "." *) - | Fs (* Unconfined "."; also allows absolute paths *) - -let uring_file_offset t = - if Fd.is_seekable t then Optint.Int63.minus_one else Optint.Int63.zero - -let file_offset t = function - | Some x -> `Pos x - | None when Fd.is_seekable t -> `Seekable_current - | None -> `Nonseekable_current - -let enqueue_read st action (file_offset,fd,buf,len) = - let req = { Sched.op=`R; file_offset; len; fd; cur_off = 0; buf; action } in - Sched.submit_rw_req st req - -let rec enqueue_writev args st action = - let (file_offset,fd,bufs) = args in - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.writev st.uring ~file_offset fd bufs (Job action) - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_writev args st action) st.io_q - -let enqueue_write st action (file_offset,fd,buf,len) = - let req = { Sched.op=`W; file_offset; len; fd; cur_off = 0; buf; action } in - Sched.submit_rw_req st req - -let rec enqueue_splice ~src ~dst ~len st action = - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.splice st.uring (Job action) ~src ~dst ~len - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_splice ~src ~dst ~len st action) st.io_q - -let rec enqueue_openat2 ((access, flags, perm, resolve, fd, path) as args) st action = - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.openat2 st.uring ~access ~flags ~perm ~resolve ?fd path (Job action) - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_openat2 args st action) st.io_q - -let rec enqueue_statx ((fd, path, buf, flags, mask) as args) st action = - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.statx st.uring ?fd ~mask path buf flags (Job action) - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_statx args st action) st.io_q - -let rec enqueue_unlink ((dir, fd, path) as args) st action = - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.unlink st.uring ~dir ~fd path (Job action) - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_unlink args st action) st.io_q - -let rec enqueue_connect fd addr st action = - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.connect st.uring fd addr (Job action) - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_connect fd addr st action) st.io_q - -let rec enqueue_send_msg fd ~fds ~dst buf st action = - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.send_msg st.uring fd ~fds ?dst buf (Job action) - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_send_msg fd ~fds ~dst buf st action) st.io_q - -let rec enqueue_recv_msg fd msghdr st action = - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.recv_msg st.uring fd msghdr (Job action); - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_recv_msg fd msghdr st action) st.io_q - -let rec enqueue_accept fd client_addr st action = - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.accept st.uring fd client_addr (Job action) - ) in - if retry then ( - (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_accept fd client_addr st action) st.io_q - ) - -let rec enqueue_noop t action = - let job = Sched.enqueue_job t (fun () -> Uring.noop t.uring (Job_no_cancel action)) in - if job = None then ( - (* wait until an sqe is available *) - Queue.push (fun t -> enqueue_noop t action) t.io_q - ) - -let noop () = - let result = Sched.enter "noop" enqueue_noop in - if result <> 0 then raise (Err.unclassified (Eio_unix.Unix_error (Uring.error_of_errno result, "noop", ""))) - -let sleep_until time = - Sched.enter "sleep" @@ fun t k -> - let job = Eio_utils.Zzz.add t.sleep_q time (Fiber k) in - Eio.Private.Fiber_context.set_cancel_fn k.fiber (fun ex -> - Eio_utils.Zzz.remove t.sleep_q job; - Sched.enqueue_failed_thread t k ex - ) - -let read ?file_offset:off fd buf amount = - let off = file_offset fd off in - Fd.use_exn "read" fd @@ fun fd -> - let res = Sched.enter "read" (fun t k -> enqueue_read t k (off, fd, buf, amount)) in - if res < 0 then ( - raise @@ Err.wrap (Uring.error_of_errno res) "read" "" - ) else res - -let read_exactly ?file_offset fd buf len = - ignore (read ?file_offset fd buf (Exactly len) : int) - -let read_upto ?file_offset fd buf len = - read ?file_offset fd buf (Upto len) - -let rec enqueue_readv args st action = - let (file_offset,fd,bufs) = args in - let retry = Sched.with_cancel_hook ~action st (fun () -> - Uring.readv st.uring ~file_offset fd bufs (Job action)) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_readv args st action) st.io_q - -let readv ?file_offset fd bufs = - let file_offset = - match file_offset with - | Some x -> x - | None -> uring_file_offset fd - in - Fd.use_exn "readv" fd @@ fun fd -> - let res = Sched.enter "readv" (enqueue_readv (file_offset, fd, bufs)) in - if res < 0 then ( - raise @@ Err.wrap (Uring.error_of_errno res) "readv" "" - ) else if res = 0 then ( - raise End_of_file - ) else ( - res - ) - -let writev_single ?file_offset fd bufs = - let file_offset = - match file_offset with - | Some x -> x - | None -> uring_file_offset fd - in - Fd.use_exn "writev" fd @@ fun fd -> - let res = Sched.enter "writev" (enqueue_writev (file_offset, fd, bufs)) in - if res < 0 then ( - raise @@ Err.wrap (Uring.error_of_errno res) "writev" "" - ) else ( - res - ) - -let rec writev ?file_offset fd bufs = - let bytes_written = writev_single ?file_offset fd bufs in - match Cstruct.shiftv bufs bytes_written with - | [] -> () - | bufs -> - let file_offset = - let module I63 = Optint.Int63 in - match file_offset with - | None -> None - | Some ofs when ofs = I63.minus_one -> Some I63.minus_one - | Some ofs -> Some (I63.add ofs (I63.of_int bytes_written)) - in - writev ?file_offset fd bufs - -let await_readable fd = - Fd.use_exn "await_readable" fd @@ fun fd -> - let res = Sched.enter "await_readable" (Sched.enqueue_poll_add fd (Uring.Poll_mask.(pollin + pollerr))) in - if res < 0 then ( - raise (Err.unclassified (Eio_unix.Unix_error (Uring.error_of_errno res, "await_readable", ""))) - ) - -let await_writable fd = - Fd.use_exn "await_writable" fd @@ fun fd -> - let res = Sched.enter "await_writable" (Sched.enqueue_poll_add fd (Uring.Poll_mask.(pollout + pollerr))) in - if res < 0 then ( - raise (Err.unclassified (Eio_unix.Unix_error (Uring.error_of_errno res, "await_writable", ""))) - ) - -let write ?file_offset:off fd buf len = - let off = file_offset fd off in - Fd.use_exn "write" fd @@ fun fd -> - let res = Sched.enter "write" (fun t k -> enqueue_write t k (off, fd, buf, Exactly len)) in - if res < 0 then ( - raise @@ Err.wrap (Uring.error_of_errno res) "write" "" - ) - -let alloc_fixed () = - let s = Sched.get () in - match s.mem with - | None -> None - | Some mem -> - match Uring.Region.alloc mem with - | buf -> Some buf - | exception Uring.Region.No_space -> None - -let alloc_fixed_or_wait () = - let s = Sched.get () in - match s.mem with - | None -> failwith "No fixed buffer available" - | Some mem -> - match Uring.Region.alloc mem with - | buf -> buf - | exception Uring.Region.No_space -> - let id = Eio.Private.Trace.mint_id () in - let trigger = Eio.Private.Single_waiter.create () in - let node = Lwt_dllist.add_r trigger s.mem_q in - try - Eio.Private.Single_waiter.await trigger "alloc_fixed_or_wait" id - with ex -> - Lwt_dllist.remove node; - raise ex - -let rec free_fixed buf = - let s = Sched.get () in - match Lwt_dllist.take_opt_l s.mem_q with - | None -> Uring.Region.free buf - | Some k -> - if not (Eio.Private.Single_waiter.wake k (Ok buf)) then - free_fixed buf (* [k] was already cancelled, but not yet removed from the queue *) - -let splice src ~dst ~len = - Fd.use_exn "splice-src" src @@ fun src -> - Fd.use_exn "splice-dst" dst @@ fun dst -> - let res = Sched.enter "splice" (enqueue_splice ~src ~dst ~len) in - if res > 0 then res - else if res = 0 then raise End_of_file - else raise @@ Err.wrap (Uring.error_of_errno res) "splice" "" - -let connect fd addr = - Fd.use_exn "connect" fd @@ fun fd -> - let res = Sched.enter "connect" (enqueue_connect fd addr) in - if res < 0 then ( - let ex = - match addr with - | ADDR_UNIX _ -> Err.wrap_fs (Uring.error_of_errno res) "connect" "" - | ADDR_INET _ -> Err.wrap (Uring.error_of_errno res) "connect" "" - in - raise ex - ) - -let send_msg fd ?(fds=[]) ?dst buf = - Fd.use_exn "send_msg" fd @@ fun fd -> - Fd.use_exn_list "send_msg" fds @@ fun fds -> - let res = Sched.enter "send_msg" (enqueue_send_msg fd ~fds ~dst buf) in - if res < 0 then ( - raise @@ Err.wrap (Uring.error_of_errno res) "send_msg" "" - ) else res - -let recv_msg fd buf = - Fd.use_exn "recv_msg" fd @@ fun fd -> - let addr = Uring.Sockaddr.create () in - let msghdr = Uring.Msghdr.create ~addr buf in - let res = Sched.enter "recv_msg" (enqueue_recv_msg fd msghdr) in - if res < 0 then ( - raise @@ Err.wrap (Uring.error_of_errno res) "recv_msg" "" - ); - addr, res - -let recv_msg_with_fds ~sw ~max_fds fd buf = - Fd.use_exn "recv_msg_with_fds" fd @@ fun fd -> - let addr = Uring.Sockaddr.create () in - let msghdr = Uring.Msghdr.create ~n_fds:max_fds ~addr buf in - let res = Sched.enter "recv_msg_with_fds" (enqueue_recv_msg fd msghdr) in - if res < 0 then ( - raise @@ Err.wrap (Uring.error_of_errno res) "recv_msg" "" - ); - let fds = Uring.Msghdr.get_fds msghdr |> Fd.of_unix_list ~sw in - addr, res, fds - -let with_chunk ~fallback fn = - match alloc_fixed () with - | Some chunk -> - Fun.protect ~finally:(fun () -> free_fixed chunk) @@ fun () -> - fn chunk - | None -> - fallback () - -let rec openat2 ~sw ?seekable ~access ~flags ~perm ~resolve ?dir path = - let use dir_opt = - let res = Sched.enter "openat2" (enqueue_openat2 (access, flags, perm, resolve, dir_opt, path)) in - if res < 0 then ( - Switch.check sw; (* If cancelled, report that instead. *) - match Uring.error_of_errno res with - | EAGAIN -> - (* Linux can return this due to a concurrent update. - It also seems to happen sometimes with no concurrent updates. *) - openat2 ~sw ?seekable ~access ~flags ~perm ~resolve ?dir path - | e -> raise @@ Err.wrap_fs e "openat2" "" - ) else ( - let fd : Unix.file_descr = Obj.magic res in - Fd.of_unix ~sw ?seekable ~close_unix:true fd - ) - in - match dir with - | None -> use None - | Some dir -> Fd.use_exn "openat2" dir (fun x -> use (Some x)) - -let openat ~sw ?seekable ~access ~flags ~perm dir path = - match dir with - | FD dir -> openat2 ~sw ?seekable ~access ~flags ~perm ~resolve:Uring.Resolve.beneath ~dir path - | Cwd -> openat2 ~sw ?seekable ~access ~flags ~perm ~resolve:Uring.Resolve.beneath path - | Fs -> openat2 ~sw ?seekable ~access ~flags ~perm ~resolve:Uring.Resolve.empty path - -let fstat t = - (* todo: use uring *) - try - let ust = Fd.use_exn "fstat" t Unix.LargeFile.fstat in - let st_kind : Eio.File.Stat.kind = - match ust.st_kind with - | Unix.S_REG -> `Regular_file - | Unix.S_DIR -> `Directory - | Unix.S_CHR -> `Character_special - | Unix.S_BLK -> `Block_device - | Unix.S_LNK -> `Symbolic_link - | Unix.S_FIFO -> `Fifo - | Unix.S_SOCK -> `Socket - in - Eio.File.Stat.{ - dev = ust.st_dev |> Int64.of_int; - ino = ust.st_ino |> Int64.of_int; - kind = st_kind; - perm = ust.st_perm; - nlink = ust.st_nlink |> Int64.of_int; - uid = ust.st_uid |> Int64.of_int; - gid = ust.st_gid |> Int64.of_int; - rdev = ust.st_rdev |> Int64.of_int; - size = ust.st_size |> Optint.Int63.of_int64; - atime = ust.st_atime; - mtime = ust.st_mtime; - ctime = ust.st_ctime; - } - with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg - -external eio_mkdirat : Unix.file_descr -> string -> Unix.file_perm -> unit = "caml_eio_mkdirat" - -external eio_renameat : Unix.file_descr -> string -> Unix.file_descr -> string -> unit = "caml_eio_renameat" - -external eio_symlinkat : string -> Unix.file_descr -> string -> unit = "caml_eio_symlinkat" - -external eio_getrandom : Cstruct.buffer -> int -> int -> int = "caml_eio_getrandom" - -external eio_getdents : Unix.file_descr -> string list = "caml_eio_getdents" - -let lseek fd off cmd = - Fd.use_exn "lseek" fd @@ fun fd -> - let cmd = - match cmd with - | `Set -> Unix.SEEK_SET - | `Cur -> Unix.SEEK_CUR - | `End -> Unix.SEEK_END - in - Unix.LargeFile.lseek fd (Optint.Int63.to_int64 off) cmd - |> Optint.Int63.of_int64 - -let fsync fd = - (* todo: https://github.com/ocaml-multicore/ocaml-uring/pull/103 *) - Eio_unix.run_in_systhread ~label:"fsync" @@ fun () -> - Fd.use_exn "fsync" fd Unix.fsync - -let ftruncate fd len = - Eio_unix.run_in_systhread ~label:"ftruncate" @@ fun () -> - Fd.use_exn "ftruncate" fd @@ fun fd -> - Unix.LargeFile.ftruncate fd (Optint.Int63.to_int64 len) - -let getrandom { Cstruct.buffer; off; len } = - let rec loop n = - if n = len then - () - else - loop (n + eio_getrandom buffer (off + n) (len - n)) - in - loop 0 - -(* [with_parent_dir_fd dir path fn] runs [fn parent (basename path)], - where [parent] is a path FD for [path]'s parent, resolved using [Resolve.beneath]. - - If [basename path] is ".." then we treat it as if path had "/." on the end, - to avoid the special case. - - todo: Optimise this by doing [fn AT_FDCWD path] if [dir = Fs]. -*) -let with_parent_dir_fd dir path fn = - let dir_path = Filename.dirname path in - let leaf = Filename.basename path in - Switch.run ~name:"with_parent_dir" (fun sw -> - match dir with - | _ when leaf = ".." -> - let fd = - openat ~sw ~seekable:false dir path (* Open the full path *) - ~access:`R - ~flags:Uring.Open_flags.(cloexec + path + directory) - ~perm:0 - in - fn fd "." - | FD d when dir_path = "." -> fn d leaf - | _ -> - let parent = - openat ~sw ~seekable:false dir dir_path - ~access:`R - ~flags:Uring.Open_flags.(cloexec + path + directory) - ~perm:0 - in - fn parent leaf - ) - -let with_parent_dir op dir path fn = - with_parent_dir_fd dir path @@ fun parent leaf -> - Fd.use_exn op parent @@ fun parent -> - fn parent leaf - -let statx_raw ?fd ~mask path buf flags = - let res = - match fd with - | None -> Sched.enter "statx" (enqueue_statx (None, path, buf, flags, mask)) - | Some fd -> - Fd.use_exn "statx" fd @@ fun fd -> - Sched.enter "statx" (enqueue_statx (Some fd, path, buf, flags, mask)) - in - if res <> 0 then raise @@ Err.wrap_fs (Uring.error_of_errno res) "statx" path - -let statx ~mask ~follow fd path buf = - let module X = Uring.Statx in - let flags = if follow then X.Flags.empty_path else X.Flags.(empty_path + symlink_nofollow) in - match fd with - | Fs -> statx_raw ~mask path buf flags - | FD fd when path = "" -> statx_raw ~fd ~mask "" buf flags - | Cwd | FD _ when not follow -> - with_parent_dir_fd fd path @@ fun parent leaf -> - statx_raw ~mask ~fd:parent leaf buf flags - | Cwd | FD _ -> - Switch.run ~name:"statx" @@ fun sw -> - let fd = openat ~sw ~seekable:false fd (if path = "" then "." else path) - ~access:`R - ~flags:Uring.Open_flags.(cloexec + path) - ~perm:0 - in - statx_raw ~fd ~mask "" buf flags - -let mkdir ~perm dir path = - (* [mkdir] is really an operation on [path]'s parent. Get a reference to that first: *) - with_parent_dir "mkdir" dir path @@ fun parent leaf -> - try eio_mkdirat parent leaf perm - with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg - -let unlink ~rmdir dir path = - (* [unlink] is really an operation on [path]'s parent. Get a reference to that first: *) - with_parent_dir "unlink" dir path @@ fun parent leaf -> - let res = Sched.enter "unlink" (enqueue_unlink (rmdir, parent, leaf)) in - if res <> 0 then raise @@ Err.wrap_fs (Uring.error_of_errno res) "unlinkat" "" - -let rename old_dir old_path new_dir new_path = - with_parent_dir "renameat-old" old_dir old_path @@ fun old_parent old_leaf -> - with_parent_dir "renameat-new" new_dir new_path @@ fun new_parent new_leaf -> - try - eio_renameat - old_parent old_leaf - new_parent new_leaf - with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg - -let symlink ~link_to dir path = - with_parent_dir "symlinkat-new" dir path @@ fun parent leaf -> - try - eio_symlinkat link_to parent leaf - with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg - -let shutdown socket command = - try - Fd.use_exn "shutdown" socket @@ fun fd -> - Unix.shutdown fd command - with - | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () - | Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg - -let accept ~sw fd = - Fd.use_exn "accept" fd @@ fun fd -> - let client_addr = Uring.Sockaddr.create () in - let res = Sched.enter "accept" (enqueue_accept fd client_addr) in - if res < 0 then ( - raise @@ Err.wrap (Uring.error_of_errno res) "accept" "" - ) else ( - let unix : Unix.file_descr = Obj.magic res in - let client = Fd.of_unix ~sw ~seekable:false ~close_unix:true unix in - let client_addr = Uring.Sockaddr.get client_addr in - client, client_addr - ) - -let read_dir fd = - Fd.use_exn "read_dir" fd @@ fun fd -> - let rec read_all acc fd = - match eio_getdents fd with - | [] -> acc - | files -> - let files = List.filter (function ".." | "." -> false | _ -> true) files in - read_all (files @ acc) fd - in - Eio_unix.run_in_systhread ~label:"read_dir" (fun () -> read_all [] fd) - -let read_link fd path = - try - with_parent_dir_fd fd path @@ fun parent leaf -> - Eio_unix.run_in_systhread ~label:"read_link" (fun () -> Eio_unix.Private.read_link (Some parent) leaf) - with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg - -(* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *) -let getaddrinfo ~service node = - let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } = - match ai_family, ai_socktype, ai_addr with - | (Unix.PF_INET | PF_INET6), - (Unix.SOCK_STREAM | SOCK_DGRAM), - Unix.ADDR_INET (inet_addr,port) -> ( - match ai_protocol with - | 6 -> Some (`Tcp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) - | 17 -> Some (`Udp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) - | _ -> None) - | _ -> None - in - Eio_unix.run_in_systhread ~label:"getaddrinfo" @@ fun () -> - Unix.getaddrinfo node service [] - |> List.filter_map to_eio_sockaddr_t - -let pipe ~sw = - let unix_r, unix_w = Unix.pipe ~cloexec:true () in - let r = Fd.of_unix ~sw ~seekable:false ~close_unix:true unix_r in - let w = Fd.of_unix ~sw ~seekable:false ~close_unix:true unix_w in - (* See issue #319, PR #327 *) - Unix.set_nonblock unix_r; - Unix.set_nonblock unix_w; - (r, w) - -let with_pipe fn = - Switch.run ~name:"with_pipe" @@ fun sw -> - let r, w = pipe ~sw in - fn r w - -module Process = struct - module Rcfd = Eio_unix.Private.Rcfd - - external eio_spawn : - Unix.file_descr -> - Eio_unix.Private.Fork_action.c_action list -> - int * Unix.file_descr = "caml_eio_clone3" - - external pidfd_send_signal : Unix.file_descr -> int -> unit = "caml_eio_pidfd_send_signal" - - type t = { - pid : int; - pid_fd : Fd.t; - exit_status : Unix.process_status Promise.t; - } - - let exit_status t = t.exit_status - let pid t = t.pid - - module Fork_action = Eio_unix.Private.Fork_action - - (* Read a (typically short) error message from a child process. *) - let rec read_response fd = - let buf = Cstruct.create 256 in - match readv fd [buf] with - | len -> Cstruct.to_string buf ~len ^ read_response fd - | exception End_of_file -> "" - - let signal t signum = - Fd.use t.pid_fd ~if_closed:Fun.id @@ fun pid_fd -> - pidfd_send_signal pid_fd signum - - let rec waitpid pid = - match Unix.waitpid [] pid with - | p, status -> assert (p = pid); status - | exception Unix.Unix_error (EINTR, _, _) -> waitpid pid - - let spawn ~sw actions = - with_pipe @@ fun errors_r errors_w -> - Eio_unix.Private.Fork_action.with_actions actions @@ fun c_actions -> - Switch.check sw; - let exit_status, set_exit_status = Promise.create () in - let t = - Fd.use_exn "errors-w" errors_w @@ fun errors_w -> - let pid, pid_fd = - Eio.Private.Trace.with_span "spawn" @@ fun () -> - eio_spawn errors_w c_actions - in - let pid_fd = Fd.of_unix ~sw ~seekable:false ~close_unix:true pid_fd in - { pid; pid_fd; exit_status } - in - Fd.close errors_w; - Fiber.fork_daemon ~sw (fun () -> - let cleanup () = - Fd.close t.pid_fd; - Promise.resolve set_exit_status (waitpid t.pid); - `Stop_daemon - in - match await_readable t.pid_fd with - | () -> Eio.Cancel.protect cleanup - | exception Eio.Cancel.Cancelled _ -> - Eio.Cancel.protect (fun () -> - signal t Sys.sigkill; - await_readable t.pid_fd; - cleanup () - ) - ); - (* Check for errors starting the process. *) - match read_response errors_r with - | "" -> t (* Success! Execing the child closed [errors_w] and we got EOF. *) - | err -> failwith err -end +[@@@alert "-unstable"] + +open Eio.Std + +module Trace = Eio.Private.Trace +module Fd = Eio_unix.Fd + +type dir_fd = + | FD of Fd.t + | Cwd (* Confined to "." *) + | Fs (* Unconfined "."; also allows absolute paths *) + +let uring_file_offset t = + if Fd.is_seekable t then Optint.Int63.minus_one else Optint.Int63.zero + +let file_offset t = function + | Some x -> `Pos x + | None when Fd.is_seekable t -> `Seekable_current + | None -> `Nonseekable_current + +let enqueue_read st action (file_offset,fd,buf,len) = + let req = { Sched.op=`R; file_offset; len; fd; cur_off = 0; buf; action } in + Sched.submit_rw_req st req + +let rec enqueue_writev args st action = + let (file_offset,fd,bufs) = args in + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.writev st.uring ~file_offset fd bufs (Job action) + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_writev args st action) st.io_q + +let enqueue_write st action (file_offset,fd,buf,len) = + let req = { Sched.op=`W; file_offset; len; fd; cur_off = 0; buf; action } in + Sched.submit_rw_req st req + +let rec enqueue_splice ~src ~dst ~len st action = + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.splice st.uring (Job action) ~src ~dst ~len + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_splice ~src ~dst ~len st action) st.io_q + +let rec enqueue_openat2 ((access, flags, perm, resolve, fd, path) as args) st action = + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.openat2 st.uring ~access ~flags ~perm ~resolve ?fd path (Job action) + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_openat2 args st action) st.io_q + +let rec enqueue_statx ((fd, path, buf, flags, mask) as args) st action = + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.statx st.uring ?fd ~mask path buf flags (Job action) + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_statx args st action) st.io_q + +let rec enqueue_unlink ((dir, fd, path) as args) st action = + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.unlink st.uring ~dir ~fd path (Job action) + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_unlink args st action) st.io_q + +let rec enqueue_connect fd addr st action = + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.connect st.uring fd addr (Job action) + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_connect fd addr st action) st.io_q + +let rec enqueue_send_msg fd ~fds ~dst buf st action = + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.send_msg st.uring fd ~fds ?dst buf (Job action) + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_send_msg fd ~fds ~dst buf st action) st.io_q + +let rec enqueue_recv_msg fd msghdr st action = + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.recv_msg st.uring fd msghdr (Job action); + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_recv_msg fd msghdr st action) st.io_q + +let rec enqueue_accept fd client_addr st action = + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.accept st.uring fd client_addr (Job action) + ) in + if retry then ( + (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_accept fd client_addr st action) st.io_q + ) + +let rec enqueue_noop t action = + let job = Sched.enqueue_job t (fun () -> Uring.noop t.uring (Job_no_cancel action)) in + if job = None then ( + (* wait until an sqe is available *) + Queue.push (fun t -> enqueue_noop t action) t.io_q + ) + +let noop () = + let result = Sched.enter "noop" enqueue_noop in + if result <> 0 then raise (Err.unclassified (Eio_unix.Unix_error (Uring.error_of_errno result, "noop", ""))) + +let sleep_until time = + Sched.enter "sleep" @@ fun t k -> + let job = Eio_utils.Zzz.add t.sleep_q time (Fiber k) in + Eio.Private.Fiber_context.set_cancel_fn k.fiber (fun ex -> + Eio_utils.Zzz.remove t.sleep_q job; + Sched.enqueue_failed_thread t k ex + ) + +let read ?file_offset:off fd buf amount = + let off = file_offset fd off in + Fd.use_exn "read" fd @@ fun fd -> + let res = Sched.enter "read" (fun t k -> enqueue_read t k (off, fd, buf, amount)) in + if res < 0 then ( + raise @@ Err.wrap (Uring.error_of_errno res) "read" "" + ) else res + +let read_exactly ?file_offset fd buf len = + ignore (read ?file_offset fd buf (Exactly len) : int) + +let read_upto ?file_offset fd buf len = + read ?file_offset fd buf (Upto len) + +let rec enqueue_readv args st action = + let (file_offset,fd,bufs) = args in + let retry = Sched.with_cancel_hook ~action st (fun () -> + Uring.readv st.uring ~file_offset fd bufs (Job action)) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_readv args st action) st.io_q + +let readv ?file_offset fd bufs = + let file_offset = + match file_offset with + | Some x -> x + | None -> uring_file_offset fd + in + Fd.use_exn "readv" fd @@ fun fd -> + let res = Sched.enter "readv" (enqueue_readv (file_offset, fd, bufs)) in + if res < 0 then ( + raise @@ Err.wrap (Uring.error_of_errno res) "readv" "" + ) else if res = 0 then ( + raise End_of_file + ) else ( + res + ) + +let writev_single ?file_offset fd bufs = + let file_offset = + match file_offset with + | Some x -> x + | None -> uring_file_offset fd + in + Fd.use_exn "writev" fd @@ fun fd -> + let res = Sched.enter "writev" (enqueue_writev (file_offset, fd, bufs)) in + if res < 0 then ( + raise @@ Err.wrap (Uring.error_of_errno res) "writev" "" + ) else ( + res + ) + +let rec writev ?file_offset fd bufs = + let bytes_written = writev_single ?file_offset fd bufs in + match Cstruct.shiftv bufs bytes_written with + | [] -> () + | bufs -> + let file_offset = + let module I63 = Optint.Int63 in + match file_offset with + | None -> None + | Some ofs when ofs = I63.minus_one -> Some I63.minus_one + | Some ofs -> Some (I63.add ofs (I63.of_int bytes_written)) + in + writev ?file_offset fd bufs + +let await_readable fd = + Fd.use_exn "await_readable" fd @@ fun fd -> + let res = Sched.enter "await_readable" (Sched.enqueue_poll_add fd (Uring.Poll_mask.(pollin + pollerr))) in + if res < 0 then ( + raise (Err.unclassified (Eio_unix.Unix_error (Uring.error_of_errno res, "await_readable", ""))) + ) + +let await_writable fd = + Fd.use_exn "await_writable" fd @@ fun fd -> + let res = Sched.enter "await_writable" (Sched.enqueue_poll_add fd (Uring.Poll_mask.(pollout + pollerr))) in + if res < 0 then ( + raise (Err.unclassified (Eio_unix.Unix_error (Uring.error_of_errno res, "await_writable", ""))) + ) + +let write ?file_offset:off fd buf len = + let off = file_offset fd off in + Fd.use_exn "write" fd @@ fun fd -> + let res = Sched.enter "write" (fun t k -> enqueue_write t k (off, fd, buf, Exactly len)) in + if res < 0 then ( + raise @@ Err.wrap (Uring.error_of_errno res) "write" "" + ) + +let alloc_fixed () = + let s = Sched.get () in + match s.mem with + | None -> None + | Some mem -> + match Uring.Region.alloc mem with + | buf -> Some buf + | exception Uring.Region.No_space -> None + +let alloc_fixed_or_wait () = + let s = Sched.get () in + match s.mem with + | None -> failwith "No fixed buffer available" + | Some mem -> + match Uring.Region.alloc mem with + | buf -> buf + | exception Uring.Region.No_space -> + let id = Eio.Private.Trace.mint_id () in + let trigger = Eio.Private.Single_waiter.create () in + let node = Lwt_dllist.add_r trigger s.mem_q in + try + Eio.Private.Single_waiter.await trigger "alloc_fixed_or_wait" id + with ex -> + Lwt_dllist.remove node; + raise ex + +let rec free_fixed buf = + let s = Sched.get () in + match Lwt_dllist.take_opt_l s.mem_q with + | None -> Uring.Region.free buf + | Some k -> + if not (Eio.Private.Single_waiter.wake k (Ok buf)) then + free_fixed buf (* [k] was already cancelled, but not yet removed from the queue *) + +let splice src ~dst ~len = + Fd.use_exn "splice-src" src @@ fun src -> + Fd.use_exn "splice-dst" dst @@ fun dst -> + let res = Sched.enter "splice" (enqueue_splice ~src ~dst ~len) in + if res > 0 then res + else if res = 0 then raise End_of_file + else raise @@ Err.wrap (Uring.error_of_errno res) "splice" "" + +let connect fd addr = + Fd.use_exn "connect" fd @@ fun fd -> + let res = Sched.enter "connect" (enqueue_connect fd addr) in + if res < 0 then ( + let ex = + match addr with + | ADDR_UNIX _ -> Err.wrap_fs (Uring.error_of_errno res) "connect" "" + | ADDR_INET _ -> Err.wrap (Uring.error_of_errno res) "connect" "" + in + raise ex + ) + +let send_msg fd ?(fds=[]) ?dst buf = + Fd.use_exn "send_msg" fd @@ fun fd -> + Fd.use_exn_list "send_msg" fds @@ fun fds -> + let res = Sched.enter "send_msg" (enqueue_send_msg fd ~fds ~dst buf) in + if res < 0 then ( + raise @@ Err.wrap (Uring.error_of_errno res) "send_msg" "" + ) else res + +let recv_msg fd buf = + Fd.use_exn "recv_msg" fd @@ fun fd -> + let addr = Uring.Sockaddr.create () in + let msghdr = Uring.Msghdr.create ~addr buf in + let res = Sched.enter "recv_msg" (enqueue_recv_msg fd msghdr) in + if res < 0 then ( + raise @@ Err.wrap (Uring.error_of_errno res) "recv_msg" "" + ); + addr, res + +let recv_msg_with_fds ~sw ~max_fds fd buf = + Fd.use_exn "recv_msg_with_fds" fd @@ fun fd -> + let addr = Uring.Sockaddr.create () in + let msghdr = Uring.Msghdr.create ~n_fds:max_fds ~addr buf in + let res = Sched.enter "recv_msg_with_fds" (enqueue_recv_msg fd msghdr) in + if res < 0 then ( + raise @@ Err.wrap (Uring.error_of_errno res) "recv_msg" "" + ); + let fds = Uring.Msghdr.get_fds msghdr |> Fd.of_unix_list ~sw in + addr, res, fds + +let with_chunk ~fallback fn = + match alloc_fixed () with + | Some chunk -> + Fun.protect ~finally:(fun () -> free_fixed chunk) @@ fun () -> + fn chunk + | None -> + fallback () + +let rec openat2 ~sw ?seekable ~access ~flags ~perm ~resolve ?dir path = + let use dir_opt = + let res = Sched.enter "openat2" (enqueue_openat2 (access, flags, perm, resolve, dir_opt, path)) in + if res < 0 then ( + Switch.check sw; (* If cancelled, report that instead. *) + match Uring.error_of_errno res with + | EAGAIN -> + (* Linux can return this due to a concurrent update. + It also seems to happen sometimes with no concurrent updates. *) + openat2 ~sw ?seekable ~access ~flags ~perm ~resolve ?dir path + | e -> raise @@ Err.wrap_fs e "openat2" "" + ) else ( + let fd : Unix.file_descr = Obj.magic res in + Fd.of_unix ~sw ?seekable ~close_unix:true fd + ) + in + match dir with + | None -> use None + | Some dir -> Fd.use_exn "openat2" dir (fun x -> use (Some x)) + +let openat ~sw ?seekable ~access ~flags ~perm dir path = + match dir with + | FD dir -> openat2 ~sw ?seekable ~access ~flags ~perm ~resolve:Uring.Resolve.beneath ~dir path + | Cwd -> openat2 ~sw ?seekable ~access ~flags ~perm ~resolve:Uring.Resolve.beneath path + | Fs -> openat2 ~sw ?seekable ~access ~flags ~perm ~resolve:Uring.Resolve.empty path + +let fstat t = + (* todo: use uring *) + try + let ust = Fd.use_exn "fstat" t Unix.LargeFile.fstat in + let st_kind : Eio.File.Stat.kind = + match ust.st_kind with + | Unix.S_REG -> `Regular_file + | Unix.S_DIR -> `Directory + | Unix.S_CHR -> `Character_special + | Unix.S_BLK -> `Block_device + | Unix.S_LNK -> `Symbolic_link + | Unix.S_FIFO -> `Fifo + | Unix.S_SOCK -> `Socket + in + Eio.File.Stat.{ + dev = ust.st_dev |> Int64.of_int; + ino = ust.st_ino |> Int64.of_int; + kind = st_kind; + perm = ust.st_perm; + nlink = ust.st_nlink |> Int64.of_int; + uid = ust.st_uid |> Int64.of_int; + gid = ust.st_gid |> Int64.of_int; + rdev = ust.st_rdev |> Int64.of_int; + size = ust.st_size |> Optint.Int63.of_int64; + atime = ust.st_atime; + mtime = ust.st_mtime; + ctime = ust.st_ctime; + } + with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg + +external eio_mkdirat : Unix.file_descr -> string -> Unix.file_perm -> unit = "caml_eio_mkdirat" + +external eio_renameat : Unix.file_descr -> string -> Unix.file_descr -> string -> unit = "caml_eio_renameat" + +external eio_symlinkat : string -> Unix.file_descr -> string -> unit = "caml_eio_symlinkat" + +external eio_getrandom : Cstruct.buffer -> int -> int -> int = "caml_eio_getrandom" + +external eio_getdents : Unix.file_descr -> string list = "caml_eio_getdents" + +let lseek fd off cmd = + Fd.use_exn "lseek" fd @@ fun fd -> + let cmd = + match cmd with + | `Set -> Unix.SEEK_SET + | `Cur -> Unix.SEEK_CUR + | `End -> Unix.SEEK_END + in + Unix.LargeFile.lseek fd (Optint.Int63.to_int64 off) cmd + |> Optint.Int63.of_int64 + +let fsync fd = + (* todo: https://github.com/ocaml-multicore/ocaml-uring/pull/103 *) + Eio_unix.run_in_systhread ~label:"fsync" @@ fun () -> + Fd.use_exn "fsync" fd Unix.fsync + +let ftruncate fd len = + Eio_unix.run_in_systhread ~label:"ftruncate" @@ fun () -> + Fd.use_exn "ftruncate" fd @@ fun fd -> + Unix.LargeFile.ftruncate fd (Optint.Int63.to_int64 len) + +let getrandom { Cstruct.buffer; off; len } = + let rec loop n = + if n = len then + () + else + loop (n + eio_getrandom buffer (off + n) (len - n)) + in + loop 0 + +(* [with_parent_dir_fd dir path fn] runs [fn parent (basename path)], + where [parent] is a path FD for [path]'s parent, resolved using [Resolve.beneath]. + + If [basename path] is ".." then we treat it as if path had "/." on the end, + to avoid the special case. + + todo: Optimise this by doing [fn AT_FDCWD path] if [dir = Fs]. +*) +let with_parent_dir_fd dir path fn = + let dir_path = Filename.dirname path in + let leaf = Filename.basename path in + Switch.run ~name:"with_parent_dir" (fun sw -> + match dir with + | _ when leaf = ".." -> + let fd = + openat ~sw ~seekable:false dir path (* Open the full path *) + ~access:`R + ~flags:Uring.Open_flags.(cloexec + path + directory) + ~perm:0 + in + fn fd "." + | FD d when dir_path = "." -> fn d leaf + | _ -> + let parent = + openat ~sw ~seekable:false dir dir_path + ~access:`R + ~flags:Uring.Open_flags.(cloexec + path + directory) + ~perm:0 + in + fn parent leaf + ) + +let with_parent_dir op dir path fn = + with_parent_dir_fd dir path @@ fun parent leaf -> + Fd.use_exn op parent @@ fun parent -> + fn parent leaf + +let statx_raw ?fd ~mask path buf flags = + let res = + match fd with + | None -> Sched.enter "statx" (enqueue_statx (None, path, buf, flags, mask)) + | Some fd -> + Fd.use_exn "statx" fd @@ fun fd -> + Sched.enter "statx" (enqueue_statx (Some fd, path, buf, flags, mask)) + in + if res <> 0 then raise @@ Err.wrap_fs (Uring.error_of_errno res) "statx" path + +let statx ~mask ~follow fd path buf = + let module X = Uring.Statx in + let flags = if follow then X.Flags.empty_path else X.Flags.(empty_path + symlink_nofollow) in + match fd with + | Fs -> statx_raw ~mask path buf flags + | FD fd when path = "" -> statx_raw ~fd ~mask "" buf flags + | Cwd | FD _ when not follow -> + with_parent_dir_fd fd path @@ fun parent leaf -> + statx_raw ~mask ~fd:parent leaf buf flags + | Cwd | FD _ -> + Switch.run ~name:"statx" @@ fun sw -> + let fd = openat ~sw ~seekable:false fd (if path = "" then "." else path) + ~access:`R + ~flags:Uring.Open_flags.(cloexec + path) + ~perm:0 + in + statx_raw ~fd ~mask "" buf flags + +let mkdir ~perm dir path = + (* [mkdir] is really an operation on [path]'s parent. Get a reference to that first: *) + with_parent_dir "mkdir" dir path @@ fun parent leaf -> + try eio_mkdirat parent leaf perm + with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg + +let unlink ~rmdir dir path = + (* [unlink] is really an operation on [path]'s parent. Get a reference to that first: *) + with_parent_dir "unlink" dir path @@ fun parent leaf -> + let res = Sched.enter "unlink" (enqueue_unlink (rmdir, parent, leaf)) in + if res <> 0 then raise @@ Err.wrap_fs (Uring.error_of_errno res) "unlinkat" "" + +let rename old_dir old_path new_dir new_path = + with_parent_dir "renameat-old" old_dir old_path @@ fun old_parent old_leaf -> + with_parent_dir "renameat-new" new_dir new_path @@ fun new_parent new_leaf -> + try + eio_renameat + old_parent old_leaf + new_parent new_leaf + with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg + +let symlink ~link_to dir path = + with_parent_dir "symlinkat-new" dir path @@ fun parent leaf -> + try + eio_symlinkat link_to parent leaf + with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg + +let shutdown socket command = + try + Fd.use_exn "shutdown" socket @@ fun fd -> + Unix.shutdown fd command + with + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () + | Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg + +let accept ~sw fd = + Fd.use_exn "accept" fd @@ fun fd -> + let client_addr = Uring.Sockaddr.create () in + let res = Sched.enter "accept" (enqueue_accept fd client_addr) in + if res < 0 then ( + raise @@ Err.wrap (Uring.error_of_errno res) "accept" "" + ) else ( + let unix : Unix.file_descr = Obj.magic res in + let client = Fd.of_unix ~sw ~seekable:false ~close_unix:true unix in + let client_addr = Uring.Sockaddr.get client_addr in + client, client_addr + ) + +let read_dir fd = + Fd.use_exn "read_dir" fd @@ fun fd -> + let rec read_all acc fd = + match eio_getdents fd with + | [] -> acc + | files -> + let files = List.filter (function ".." | "." -> false | _ -> true) files in + read_all (files @ acc) fd + in + Eio_unix.run_in_systhread ~label:"read_dir" (fun () -> read_all [] fd) + +let read_link fd path = + try + with_parent_dir_fd fd path @@ fun parent leaf -> + Eio_unix.run_in_systhread ~label:"read_link" (fun () -> Eio_unix.Private.read_link (Some parent) leaf) + with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg + +(* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *) +let getaddrinfo ~service node = + let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } = + match ai_family, ai_socktype, ai_addr with + | (Unix.PF_INET | PF_INET6), + (Unix.SOCK_STREAM | SOCK_DGRAM), + Unix.ADDR_INET (inet_addr,port) -> ( + match ai_protocol with + | 6 -> Some (`Tcp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) + | 17 -> Some (`Udp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) + | _ -> None) + | _ -> None + in + Eio_unix.run_in_systhread ~label:"getaddrinfo" @@ fun () -> + Unix.getaddrinfo node service [] + |> List.filter_map to_eio_sockaddr_t + +let pipe ~sw = + let unix_r, unix_w = Unix.pipe ~cloexec:true () in + let r = Fd.of_unix ~sw ~seekable:false ~close_unix:true unix_r in + let w = Fd.of_unix ~sw ~seekable:false ~close_unix:true unix_w in + (* See issue #319, PR #327 *) + Unix.set_nonblock unix_r; + Unix.set_nonblock unix_w; + (r, w) + +let with_pipe fn = + Switch.run ~name:"with_pipe" @@ fun sw -> + let r, w = pipe ~sw in + fn r w + +module Process = struct + module Rcfd = Eio_unix.Private.Rcfd + + external eio_spawn : + Unix.file_descr -> + Eio_unix.Private.Fork_action.c_action list -> + int * Unix.file_descr = "caml_eio_clone3" + + external pidfd_send_signal : Unix.file_descr -> int -> unit = "caml_eio_pidfd_send_signal" + + type t = { + pid : int; + pid_fd : Fd.t; + exit_status : Unix.process_status Promise.t; + } + + let exit_status t = t.exit_status + let pid t = t.pid + + module Fork_action = Eio_unix.Private.Fork_action + + (* Read a (typically short) error message from a child process. *) + let rec read_response fd = + let buf = Cstruct.create 256 in + match readv fd [buf] with + | len -> Cstruct.to_string buf ~len ^ read_response fd + | exception End_of_file -> "" + + let signal t signum = + Fd.use t.pid_fd ~if_closed:Fun.id @@ fun pid_fd -> + pidfd_send_signal pid_fd signum + + let rec waitpid pid = + match Unix.waitpid [] pid with + | p, status -> assert (p = pid); status + | exception Unix.Unix_error (EINTR, _, _) -> waitpid pid + + let spawn ~sw actions = + with_pipe @@ fun errors_r errors_w -> + Eio_unix.Private.Fork_action.with_actions actions @@ fun c_actions -> + Switch.check sw; + let exit_status, set_exit_status = Promise.create () in + let t = + Fd.use_exn "errors-w" errors_w @@ fun errors_w -> + let pid, pid_fd = + Eio.Private.Trace.with_span "spawn" @@ fun () -> + eio_spawn errors_w c_actions + in + let pid_fd = Fd.of_unix ~sw ~seekable:false ~close_unix:true pid_fd in + { pid; pid_fd; exit_status } + in + Fd.close errors_w; + Fiber.fork_daemon ~sw (fun () -> + let cleanup () = + Fd.close t.pid_fd; + Promise.resolve set_exit_status (waitpid t.pid); + `Stop_daemon + in + match await_readable t.pid_fd with + | () -> Eio.Cancel.protect cleanup + | exception Eio.Cancel.Cancelled _ -> + Eio.Cancel.protect (fun () -> + signal t Sys.sigkill; + await_readable t.pid_fd; + cleanup () + ) + ); + (* Check for errors starting the process. *) + match read_response errors_r with + | "" -> t (* Success! Execing the child closed [errors_w] and we got EOF. *) + | err -> failwith err +end diff --git a/lib_eio_linux/low_level.mli b/lib_eio_linux/low_level.mli index a3736e161..edb2ac3f4 100644 --- a/lib_eio_linux/low_level.mli +++ b/lib_eio_linux/low_level.mli @@ -1,245 +1,245 @@ -(** {1 Low-level API} - - Low-level API for using uring directly. *) - -open Eio.Std - -type fd := Eio_unix.Fd.t - -type dir_fd = - | FD of fd - | Cwd (** Confined to "." *) - | Fs (** Unconfined "."; also allows absolute paths *) - -val noop : unit -> unit -(** [noop ()] performs a uring noop. This is only useful for benchmarking. *) - -(** {1 Time functions} *) - -val sleep_until : Mtime.t -> unit -(** [sleep_until time] blocks until the current time is [time]. *) - -(** {1 Fixed-buffer memory allocation functions} - - The size of the fixed buffer is set when calling {!run}, which attempts to allocate a fixed buffer. - However, that may fail due to resource limits. *) - -val alloc_fixed : unit -> Uring.Region.chunk option -(** Allocate a chunk of memory from the fixed buffer. - - Warning: The memory is NOT zeroed out. - - Passing such memory to Linux can be faster than using normal memory, in certain cases. - There is a limited amount of such memory, and this will return [None] if none is available at present. *) - -val alloc_fixed_or_wait : unit -> Uring.Region.chunk -(** Like {!alloc_fixed}, but if there are no chunks available then it waits until one is. *) - -val free_fixed : Uring.Region.chunk -> unit - -val with_chunk : fallback:(unit -> 'a) -> (Uring.Region.chunk -> 'a) -> 'a -(** [with_chunk ~fallback fn] runs [fn chunk] with a freshly allocated chunk and then frees it. - - If no chunks are available, it runs [fallback ()] instead. *) - -(** {1 File manipulation functions} *) - -val openat : - sw:Switch.t -> - ?seekable:bool -> - access:[`R|`W|`RW] -> - flags:Uring.Open_flags.t -> - perm:Unix.file_perm -> - dir_fd -> string -> - fd -(** [openat ~sw ~access ~flags ~perm dir path] opens [dir/path]. *) - -val openat2 : - sw:Switch.t -> - ?seekable:bool -> - access:[`R|`W|`RW] -> - flags:Uring.Open_flags.t -> - perm:Unix.file_perm -> - resolve:Uring.Resolve.t -> - ?dir:fd -> string -> fd -(** [openat2 ~sw ~access ~flags ~perm ~resolve ~dir path] opens [dir/path]. - - It provides full access to the resolve flags. - See {!Uring.openat2} for details. *) - -val read_upto : ?file_offset:Optint.Int63.t -> fd -> Uring.Region.chunk -> int -> int -(** [read_upto fd chunk len] reads at most [len] bytes from [fd], - returning as soon as some data is available. - - @param file_offset Read from the given position in [fd] (default: 0). - @raise End_of_file Raised if all data has already been read. *) - -val read_exactly : ?file_offset:Optint.Int63.t -> fd -> Uring.Region.chunk -> int -> unit -(** [read_exactly fd chunk len] reads exactly [len] bytes from [fd], - performing multiple read operations if necessary. - - @param file_offset Read from the given position in [fd] (default: 0). - @raise End_of_file Raised if the stream ends before [len] bytes have been read. *) - -val readv : ?file_offset:Optint.Int63.t -> fd -> Cstruct.t list -> int -(** [readv] is like {!read_upto} but can read into any cstruct(s), - not just chunks of the pre-shared buffer. - - If multiple buffers are given, they are filled in order. *) - -val write : ?file_offset:Optint.Int63.t -> fd -> Uring.Region.chunk -> int -> unit -(** [write fd buf len] writes exactly [len] bytes from [buf] to [fd]. - - It blocks until the OS confirms the write is done, - and resubmits automatically if the OS doesn't write all of it at once. *) - -val writev : ?file_offset:Optint.Int63.t -> fd -> Cstruct.t list -> unit -(** [writev] is like {!write} but can write from any cstruct(s), - not just chunks of the pre-shared buffer. - - If multiple buffers are given, they are sent in order. - It will make multiple OS calls if the OS doesn't write all of it at once. *) - -val writev_single : ?file_offset:Optint.Int63.t -> fd -> Cstruct.t list -> int -(** [writev_single] is like [writev] but only performs a single write operation. - It returns the number of bytes written, which may be smaller than the requested amount. *) - -val splice : fd -> dst:fd -> len:int -> int -(** [splice src ~dst ~len] attempts to copy up to [len] bytes of data from [src] to [dst]. - - @return The number of bytes copied. - @raise End_of_file [src] is at the end of the file. - @raise Unix.Unix_error(EINVAL, "splice", _) if splice is not supported for these FDs. *) - -val connect : fd -> Unix.sockaddr -> unit -(** [connect fd addr] attempts to connect socket [fd] to [addr]. *) - -val await_readable : fd -> unit -(** [await_readable fd] blocks until [fd] is readable (or has an error). *) - -val await_writable : fd -> unit -(** [await_writable fd] blocks until [fd] is writable (or has an error). *) - -val fstat : fd -> Eio.File.Stat.t -(** Like {!Unix.LargeFile.fstat}. *) - -val statx : - mask:Uring.Statx.Mask.t -> - follow:bool -> - dir_fd -> string -> - Uring.Statx.t -> - unit -(** [statx ~mask ~follow dir path buf] stats [dir / path]. - - The results are written to [buf]. - If [follow = true] and the item is a symlink, information is reported about the target of the link. - Otherwise, information about the symlink itself is returned. *) - -val mkdir : perm:int -> dir_fd -> string -> unit -(** [mkdir ~perm dir path] creates directory [dir / path]. *) - -val read_link : dir_fd -> string -> string -(** [read_link dir path] reads the target of symlink [dir / path]. *) - -val unlink : rmdir:bool -> dir_fd -> string -> unit -(** [unlink ~rmdir dir path] removes directory entry [dir / path]. - - If [rmdir = true] then the target must be a directory. - Otherwise, it must not be a directory. *) - -val rename : dir_fd -> string -> dir_fd -> string -> unit -(** [rename old_dir old_path new_dir new_path] renames [old_dir / old_path] as [new_dir / new_path]. *) - -val symlink : link_to:string -> dir_fd -> string -> unit -(** [symlink ~link_to dir path] creates a new symlink at [dir / path] pointing to [link_to]. *) - -val pipe : sw:Switch.t -> fd * fd -(** [pipe ~sw] returns a pair [r, w] with the readable and writeable ends of a new pipe. *) - -val read_dir : fd -> string list -(** [read_dir dir] reads all directory entries from [dir]. - The entries are not returned in any particular order - (not even necessarily the order in which Linux returns them). *) - -val lseek : fd -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t -(** Set and/or get the current file position. - - Like {!Unix.lseek}. *) - -val fsync : fd -> unit -(** Flush file buffers to disk. - - Like {!Unix.fsync}. *) - -val ftruncate : fd -> Optint.Int63.t -> unit -(** Set the length of a file. - - Like {!Unix.ftruncate}. *) - -(** {1 Sockets} *) - -val accept : sw:Switch.t -> fd -> (fd * Unix.sockaddr) -(** [accept ~sw t] blocks until a new connection is received on listening socket [t]. - - It returns the new connection and the address of the connecting peer. - The new connection has the close-on-exec flag set automatically. - The new connection is attached to [sw] and will be closed when that finishes, if - not already closed manually by then. *) - -val shutdown : fd -> Unix.shutdown_command -> unit -(** Like {!Unix.shutdown}. *) - -val send_msg : fd -> ?fds:fd list -> ?dst:Unix.sockaddr -> Cstruct.t list -> int -(** [send_msg socket bufs] is like [writev socket bufs], but also allows setting the destination address - (for unconnected sockets) and attaching FDs (for Unix-domain sockets). *) - -val recv_msg : fd -> Cstruct.t list -> Uring.Sockaddr.t * int -(** [recv_msg socket bufs] is like [readv socket bufs] but also returns the address of the sender. *) - -val recv_msg_with_fds : sw:Switch.t -> max_fds:int -> fd -> Cstruct.t list -> Uring.Sockaddr.t * int * fd list -(** [recv_msg_with_fds] is like [recv_msg] but also allows receiving up to [max_fds] file descriptors - (sent using SCM_RIGHTS over a Unix domain socket). *) - -(** {1 Randomness} *) - -val getrandom : Cstruct.t -> unit -(**[getrandom buf] fills [buf] with random bytes. - - It uses Linux's [getrandom] call, which is like reading from /dev/urandom - except that it will block (the whole domain) if used at early boot - when the random system hasn't been initialised yet. *) - -(** {1 DNS functions} *) - -val getaddrinfo : service:string -> string -> Eio.Net.Sockaddr.t list -(** [getaddrinfo host] returns a list of IP addresses for [host]. [host] is either a domain name or - an ipaddress. *) - -(** {1 Processes} *) - -module Process : sig - type t - (** A child process. *) - - module Fork_action = Eio_unix.Private.Fork_action - (** Setup actions to perform in the child process. *) - - val spawn : sw:Switch.t -> Fork_action.t list -> t - (** [spawn ~sw actions] forks a child process, which executes [actions]. - The last action should be {!Fork_action.execve}. - - You will typically want to do [Promise.await (exit_status child)] after this. - - @param sw The child will be sent {!Sys.sigkill} if [sw] finishes. *) - - val signal : t -> int -> unit - (** [signal t x] sends signal [x] to [t]. - - This is similar to doing [Unix.kill t.pid x], - except that it ensures no signal is sent after [t] has been reaped. *) - - val pid : t -> int - - val exit_status : t -> Unix.process_status Promise.t - (** [exit_status t] is a promise for the process's exit status. *) -end +(** {1 Low-level API} + + Low-level API for using uring directly. *) + +open Eio.Std + +type fd := Eio_unix.Fd.t + +type dir_fd = + | FD of fd + | Cwd (** Confined to "." *) + | Fs (** Unconfined "."; also allows absolute paths *) + +val noop : unit -> unit +(** [noop ()] performs a uring noop. This is only useful for benchmarking. *) + +(** {1 Time functions} *) + +val sleep_until : Mtime.t -> unit +(** [sleep_until time] blocks until the current time is [time]. *) + +(** {1 Fixed-buffer memory allocation functions} + + The size of the fixed buffer is set when calling {!run}, which attempts to allocate a fixed buffer. + However, that may fail due to resource limits. *) + +val alloc_fixed : unit -> Uring.Region.chunk option +(** Allocate a chunk of memory from the fixed buffer. + + Warning: The memory is NOT zeroed out. + + Passing such memory to Linux can be faster than using normal memory, in certain cases. + There is a limited amount of such memory, and this will return [None] if none is available at present. *) + +val alloc_fixed_or_wait : unit -> Uring.Region.chunk +(** Like {!alloc_fixed}, but if there are no chunks available then it waits until one is. *) + +val free_fixed : Uring.Region.chunk -> unit + +val with_chunk : fallback:(unit -> 'a) -> (Uring.Region.chunk -> 'a) -> 'a +(** [with_chunk ~fallback fn] runs [fn chunk] with a freshly allocated chunk and then frees it. + + If no chunks are available, it runs [fallback ()] instead. *) + +(** {1 File manipulation functions} *) + +val openat : + sw:Switch.t -> + ?seekable:bool -> + access:[`R|`W|`RW] -> + flags:Uring.Open_flags.t -> + perm:Unix.file_perm -> + dir_fd -> string -> + fd +(** [openat ~sw ~access ~flags ~perm dir path] opens [dir/path]. *) + +val openat2 : + sw:Switch.t -> + ?seekable:bool -> + access:[`R|`W|`RW] -> + flags:Uring.Open_flags.t -> + perm:Unix.file_perm -> + resolve:Uring.Resolve.t -> + ?dir:fd -> string -> fd +(** [openat2 ~sw ~access ~flags ~perm ~resolve ~dir path] opens [dir/path]. + + It provides full access to the resolve flags. + See {!Uring.openat2} for details. *) + +val read_upto : ?file_offset:Optint.Int63.t -> fd -> Uring.Region.chunk -> int -> int +(** [read_upto fd chunk len] reads at most [len] bytes from [fd], + returning as soon as some data is available. + + @param file_offset Read from the given position in [fd] (default: 0). + @raise End_of_file Raised if all data has already been read. *) + +val read_exactly : ?file_offset:Optint.Int63.t -> fd -> Uring.Region.chunk -> int -> unit +(** [read_exactly fd chunk len] reads exactly [len] bytes from [fd], + performing multiple read operations if necessary. + + @param file_offset Read from the given position in [fd] (default: 0). + @raise End_of_file Raised if the stream ends before [len] bytes have been read. *) + +val readv : ?file_offset:Optint.Int63.t -> fd -> Cstruct.t list -> int +(** [readv] is like {!read_upto} but can read into any cstruct(s), + not just chunks of the pre-shared buffer. + + If multiple buffers are given, they are filled in order. *) + +val write : ?file_offset:Optint.Int63.t -> fd -> Uring.Region.chunk -> int -> unit +(** [write fd buf len] writes exactly [len] bytes from [buf] to [fd]. + + It blocks until the OS confirms the write is done, + and resubmits automatically if the OS doesn't write all of it at once. *) + +val writev : ?file_offset:Optint.Int63.t -> fd -> Cstruct.t list -> unit +(** [writev] is like {!write} but can write from any cstruct(s), + not just chunks of the pre-shared buffer. + + If multiple buffers are given, they are sent in order. + It will make multiple OS calls if the OS doesn't write all of it at once. *) + +val writev_single : ?file_offset:Optint.Int63.t -> fd -> Cstruct.t list -> int +(** [writev_single] is like [writev] but only performs a single write operation. + It returns the number of bytes written, which may be smaller than the requested amount. *) + +val splice : fd -> dst:fd -> len:int -> int +(** [splice src ~dst ~len] attempts to copy up to [len] bytes of data from [src] to [dst]. + + @return The number of bytes copied. + @raise End_of_file [src] is at the end of the file. + @raise Unix.Unix_error(EINVAL, "splice", _) if splice is not supported for these FDs. *) + +val connect : fd -> Unix.sockaddr -> unit +(** [connect fd addr] attempts to connect socket [fd] to [addr]. *) + +val await_readable : fd -> unit +(** [await_readable fd] blocks until [fd] is readable (or has an error). *) + +val await_writable : fd -> unit +(** [await_writable fd] blocks until [fd] is writable (or has an error). *) + +val fstat : fd -> Eio.File.Stat.t +(** Like {!Unix.LargeFile.fstat}. *) + +val statx : + mask:Uring.Statx.Mask.t -> + follow:bool -> + dir_fd -> string -> + Uring.Statx.t -> + unit +(** [statx ~mask ~follow dir path buf] stats [dir / path]. + + The results are written to [buf]. + If [follow = true] and the item is a symlink, information is reported about the target of the link. + Otherwise, information about the symlink itself is returned. *) + +val mkdir : perm:int -> dir_fd -> string -> unit +(** [mkdir ~perm dir path] creates directory [dir / path]. *) + +val read_link : dir_fd -> string -> string +(** [read_link dir path] reads the target of symlink [dir / path]. *) + +val unlink : rmdir:bool -> dir_fd -> string -> unit +(** [unlink ~rmdir dir path] removes directory entry [dir / path]. + + If [rmdir = true] then the target must be a directory. + Otherwise, it must not be a directory. *) + +val rename : dir_fd -> string -> dir_fd -> string -> unit +(** [rename old_dir old_path new_dir new_path] renames [old_dir / old_path] as [new_dir / new_path]. *) + +val symlink : link_to:string -> dir_fd -> string -> unit +(** [symlink ~link_to dir path] creates a new symlink at [dir / path] pointing to [link_to]. *) + +val pipe : sw:Switch.t -> fd * fd +(** [pipe ~sw] returns a pair [r, w] with the readable and writeable ends of a new pipe. *) + +val read_dir : fd -> string list +(** [read_dir dir] reads all directory entries from [dir]. + The entries are not returned in any particular order + (not even necessarily the order in which Linux returns them). *) + +val lseek : fd -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t +(** Set and/or get the current file position. + + Like {!Unix.lseek}. *) + +val fsync : fd -> unit +(** Flush file buffers to disk. + + Like {!Unix.fsync}. *) + +val ftruncate : fd -> Optint.Int63.t -> unit +(** Set the length of a file. + + Like {!Unix.ftruncate}. *) + +(** {1 Sockets} *) + +val accept : sw:Switch.t -> fd -> (fd * Unix.sockaddr) +(** [accept ~sw t] blocks until a new connection is received on listening socket [t]. + + It returns the new connection and the address of the connecting peer. + The new connection has the close-on-exec flag set automatically. + The new connection is attached to [sw] and will be closed when that finishes, if + not already closed manually by then. *) + +val shutdown : fd -> Unix.shutdown_command -> unit +(** Like {!Unix.shutdown}. *) + +val send_msg : fd -> ?fds:fd list -> ?dst:Unix.sockaddr -> Cstruct.t list -> int +(** [send_msg socket bufs] is like [writev socket bufs], but also allows setting the destination address + (for unconnected sockets) and attaching FDs (for Unix-domain sockets). *) + +val recv_msg : fd -> Cstruct.t list -> Uring.Sockaddr.t * int +(** [recv_msg socket bufs] is like [readv socket bufs] but also returns the address of the sender. *) + +val recv_msg_with_fds : sw:Switch.t -> max_fds:int -> fd -> Cstruct.t list -> Uring.Sockaddr.t * int * fd list +(** [recv_msg_with_fds] is like [recv_msg] but also allows receiving up to [max_fds] file descriptors + (sent using SCM_RIGHTS over a Unix domain socket). *) + +(** {1 Randomness} *) + +val getrandom : Cstruct.t -> unit +(**[getrandom buf] fills [buf] with random bytes. + + It uses Linux's [getrandom] call, which is like reading from /dev/urandom + except that it will block (the whole domain) if used at early boot + when the random system hasn't been initialised yet. *) + +(** {1 DNS functions} *) + +val getaddrinfo : service:string -> string -> Eio.Net.Sockaddr.t list +(** [getaddrinfo host] returns a list of IP addresses for [host]. [host] is either a domain name or + an ipaddress. *) + +(** {1 Processes} *) + +module Process : sig + type t + (** A child process. *) + + module Fork_action = Eio_unix.Private.Fork_action + (** Setup actions to perform in the child process. *) + + val spawn : sw:Switch.t -> Fork_action.t list -> t + (** [spawn ~sw actions] forks a child process, which executes [actions]. + The last action should be {!Fork_action.execve}. + + You will typically want to do [Promise.await (exit_status child)] after this. + + @param sw The child will be sent {!Sys.sigkill} if [sw] finishes. *) + + val signal : t -> int -> unit + (** [signal t x] sends signal [x] to [t]. + + This is similar to doing [Unix.kill t.pid x], + except that it ensures no signal is sent after [t] has been reaped. *) + + val pid : t -> int + + val exit_status : t -> Unix.process_status Promise.t + (** [exit_status t] is a promise for the process's exit status. *) +end diff --git a/lib_eio_linux/primitives.h b/lib_eio_linux/primitives.h index c431ce7cb..f42a4963e 100644 --- a/lib_eio_linux/primitives.h +++ b/lib_eio_linux/primitives.h @@ -1,12 +1,12 @@ -/* AUTOGENERATED FILE, DO NOT EDIT */ -#define CAML_NAME_SPACE -#define _GNU_SOURCE -#include -CAMLprim value caml_eio_eventfd(value); -CAMLprim value caml_eio_mkdirat(value, value, value); -CAMLprim value caml_eio_renameat(value, value, value, value); -CAMLprim value caml_eio_symlinkat(value, value, value); -CAMLprim value caml_eio_getrandom(value, value, value); -CAMLprim value caml_eio_getdents(value); -CAMLprim value caml_eio_clone3(value, value); -CAMLprim value caml_eio_pidfd_send_signal(value, value); +/* AUTOGENERATED FILE, DO NOT EDIT */ +#define CAML_NAME_SPACE +#define _GNU_SOURCE +#include +CAMLprim value caml_eio_eventfd(value); +CAMLprim value caml_eio_mkdirat(value, value, value); +CAMLprim value caml_eio_renameat(value, value, value, value); +CAMLprim value caml_eio_symlinkat(value, value, value); +CAMLprim value caml_eio_getrandom(value, value, value); +CAMLprim value caml_eio_getdents(value); +CAMLprim value caml_eio_clone3(value, value); +CAMLprim value caml_eio_pidfd_send_signal(value, value); diff --git a/lib_eio_linux/sched.ml b/lib_eio_linux/sched.ml index 3abd4be37..bb4bb1936 100644 --- a/lib_eio_linux/sched.ml +++ b/lib_eio_linux/sched.ml @@ -1,557 +1,557 @@ -[@@@alert "-unstable"] - -open Eio.Std - -module Fiber_context = Eio.Private.Fiber_context -module Trace = Eio.Private.Trace - -module Suspended = Eio_utils.Suspended -module Zzz = Eio_utils.Zzz -module Lf_queue = Eio_utils.Lf_queue - -let statx_works = ref false (* Before Linux 5.18, statx is unreliable *) - -type exit = [`Exit_scheduler] - -type file_offset = [ - | `Pos of Optint.Int63.t - | `Seekable_current - | `Nonseekable_current -] - -type amount = Exactly of int | Upto of int - -type rw_req = { - op : [`R|`W]; - file_offset : file_offset; (* Read from here + cur_off (unless using current pos) *) - fd : Unix.file_descr; - len : amount; - buf : Uring.Region.chunk; - mutable cur_off : int; - action : int Suspended.t; -} - -(* Type of user-data attached to jobs. *) -type io_job = - | Read : rw_req -> io_job - | Job_no_cancel : int Suspended.t -> io_job - | Cancel_job : io_job - | Job : int Suspended.t -> io_job (* A negative result indicates error, and may report cancellation *) - | Write : rw_req -> io_job - | Job_fn : 'a Suspended.t * (int -> [`Exit_scheduler]) -> io_job - (* When done, remove the cancel_fn from [Suspended.t] and call the callback (unless cancelled). *) - -type runnable = - | IO : runnable - | Thread : 'a Suspended.t * 'a -> runnable - | Failed_thread : 'a Suspended.t * exn -> runnable - -type t = { - uring: io_job Uring.t; - mem: Uring.Region.t option; - io_q: (t -> unit) Queue.t; (* waiting for room on [uring] *) - mem_q : Uring.Region.chunk Eio.Private.Single_waiter.t Lwt_dllist.t; - - (* The queue of runnable fibers ready to be resumed. Note: other domains can also add work items here. *) - run_q : runnable Lf_queue.t; - - (* When adding to [run_q] from another domain, this domain may be sleeping and so won't see the event. - In that case, [need_wakeup = true] and you must signal using [eventfd]. *) - eventfd : Eio_unix.Private.Rcfd.t; - - (* If [false], the main thread will check [run_q] before sleeping again - (possibly because an event has been or will be sent to [eventfd]). - It can therefore be set to [false] in either of these cases: - - By the receiving thread because it will check [run_q] before sleeping, or - - By the sending thread because it will signal the main thread later *) - need_wakeup : bool Atomic.t; - - sleep_q: Zzz.t; - - thread_pool : Eio_unix.Private.Thread_pool.t; -} - -type _ Effect.t += - | Enter : (t -> 'a Suspended.t -> unit) -> 'a Effect.t - | Cancel : io_job Uring.job -> unit Effect.t - | Get : t Effect.t - -let get () = Effect.perform Get - -let wake_buffer = - let b = Bytes.create 8 in - Bytes.set_int64_ne b 0 1L; - b - -(* This can be called from any systhread (including ones not running Eio), - and also from signal handlers or GC finalizers. It must not take any locks. *) -let wakeup t = - Atomic.set t.need_wakeup false; (* [t] will check [run_q] after getting the event below *) - Eio_unix.Private.Rcfd.use t.eventfd - (fun fd -> - let sent = Unix.single_write fd wake_buffer 0 8 in - assert (sent = 8) - ) - ~if_closed:ignore (* Domain has shut down (presumably after handling the event) *) - -(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) -let enqueue_thread st k x = - Lf_queue.push st.run_q (Thread (k, x)); - if Atomic.get st.need_wakeup then wakeup st - -(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) -let enqueue_failed_thread st k ex = - Lf_queue.push st.run_q (Failed_thread (k, ex)); - if Atomic.get st.need_wakeup then wakeup st - -(* Can only be called from our own domain, so no need to check for wakeup. *) -let enqueue_at_head st k x = - Lf_queue.push_head st.run_q (Thread (k, x)) - -let enter op fn = - Trace.suspend_fiber op; - Effect.perform (Enter fn) - -let submit uring = - if Uring.sqe_ready uring > 0 then - Trace.with_span "submit" (fun () -> Uring.submit uring) - else - 0 - -let rec enqueue_job t fn = - match fn () with - | Some _ as r -> r - | None -> - if submit t.uring > 0 then enqueue_job t fn - else None - -(* Cancellations always come from the same domain, so no need to send wake events here. *) -let rec enqueue_cancel job t = - Trace.log "cancel"; - match enqueue_job t (fun () -> Uring.cancel t.uring job Cancel_job) with - | None -> Queue.push (fun t -> enqueue_cancel job t) t.io_q - | Some _ -> () - -let cancel job = Effect.perform (Cancel job) - -(* Cancellation - - For operations that can be cancelled we need to set the fiber's cancellation function. - The typical sequence is: - - 1. We submit an operation, getting back a uring job (needed for cancellation). - 2. We set the cancellation function. The function uses the uring job to cancel. - - When the job completes, we clear the cancellation function. The function - must have been set by this point because we don't poll for completions until - the above steps have finished. - - If the context is cancelled while the operation is running, the function will get removed and called, - which will submit a cancellation request to uring. We know the job is still valid at this point because - we clear the cancel function when it completes. - - If the operation completes before Linux processes the cancellation, we get [ENOENT], which we ignore. *) - -(* [with_cancel_hook ~action t fn] calls [fn] to create a job, - then sets the fiber's cancel function to cancel it. - If [action] is already cancelled, it schedules [action] to be discontinued. - @return Whether to retry the operation later, once there is space. *) -let with_cancel_hook ~action t fn = - match Fiber_context.get_error action.Suspended.fiber with - | Some ex -> enqueue_failed_thread t action ex; false - | None -> - match enqueue_job t fn with - | None -> true - | Some job -> - Fiber_context.set_cancel_fn action.fiber (fun _ -> cancel job); - false - -let submit_pending_io st = - match Queue.take_opt st.io_q with - | None -> () - | Some fn -> - Trace.log "submit_pending_io"; - fn st - -let rec submit_rw_req st ({op; file_offset; fd; buf; len; cur_off; action} as req) = - let {uring;io_q;_} = st in - let off = Uring.Region.to_offset buf + cur_off in - let len = match len with Exactly l | Upto l -> l in - let len = len - cur_off in - let retry = with_cancel_hook ~action st (fun () -> - let file_offset = - match file_offset with - | `Pos x -> Optint.Int63.add x (Optint.Int63.of_int cur_off) - | `Seekable_current -> Optint.Int63.minus_one - | `Nonseekable_current -> Optint.Int63.zero - in - match op with - |`R -> Uring.read_fixed uring ~file_offset fd ~off ~len (Read req) - |`W -> Uring.write_fixed uring ~file_offset fd ~off ~len (Write req) - ) - in - if retry then ( - Trace.log "await-sqe"; - (* wait until an sqe is available *) - Queue.push (fun st -> submit_rw_req st req) io_q - ) - -(* TODO bind from unixsupport *) -let errno_is_retry = function -62 | -11 | -4 -> true |_ -> false - -(* Switch control to the next ready continuation. - If none is ready, wait until we get an event to wake one and then switch. - Returns only if there is nothing to do and no queued operations. *) -let rec schedule ({run_q; sleep_q; mem_q; uring; _} as st) : [`Exit_scheduler] = - (* This is not a fair scheduler *) - (* Wakeup any paused fibers *) - match Lf_queue.pop run_q with - | None -> assert false (* We should always have an IO job, at least *) - | Some Thread (k, v) -> (* We already have a runnable task *) - Fiber_context.clear_cancel_fn k.fiber; - Suspended.continue k v - | Some Failed_thread (k, ex) -> - Fiber_context.clear_cancel_fn k.fiber; - Suspended.discontinue k ex - | Some IO -> (* Note: be sure to re-inject the IO task before continuing! *) - (* This is not a fair scheduler: timers always run before all other IO *) - let now = Mtime_clock.now () in - match Zzz.pop ~now sleep_q with - | `Due k -> - (* A sleeping task is now due *) - Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) - begin match k with - | Fiber k -> Suspended.continue k () - | Fn fn -> fn (); schedule st - end - | `Wait_until _ | `Nothing as next_due -> - (* Handle any pending events before submitting. This is faster. *) - match Uring.get_cqe_nonblocking uring with - | Some { data = runnable; result } -> - Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) - handle_complete st ~runnable result - | None -> - let timeout = - match next_due with - | `Wait_until time -> - let time = Mtime.to_uint64_ns time in - let now = Mtime.to_uint64_ns now in - let diff_ns = Int64.sub time now |> Int64.to_float in - Some (diff_ns /. 1e9) - | `Nothing -> None - in - if not (Lf_queue.is_empty st.run_q) then ( - ignore (submit uring : int); - Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) - schedule st - ) else if timeout = None && Uring.active_ops uring = 0 then ( - (* Nothing further can happen at this point. - If there are no events in progress but also still no memory available, something has gone wrong! *) - assert (Lwt_dllist.length mem_q = 0); - Lf_queue.close st.run_q; (* Just to catch bugs if something tries to enqueue later *) - `Exit_scheduler - ) else ( - Atomic.set st.need_wakeup true; - if Lf_queue.is_empty st.run_q then ( - (* At this point we're not going to check [run_q] again before sleeping. - If [need_wakeup] is still [true], this is fine because we don't promise to do that. - If [need_wakeup = false], a wake-up event will arrive and wake us up soon. *) - Trace.suspend_domain Begin; - let result = - (* Hack: liburing automatically retries [io_uring_enter] if an - interrupt is received and no timeout is set. However, we need - to return to OCaml mode so any pending signal handlers can - run. See: https://github.com/ocaml-multicore/eio/issues/732 *) - let timeout = Option.value timeout ~default:1e9 in - Uring.wait ~timeout uring - in - Trace.suspend_domain End; - Atomic.set st.need_wakeup false; - Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) - match result with - | None -> - (* Woken by a timeout, which is now due, or by a signal. *) - schedule st - | Some { data = runnable; result } -> - handle_complete st ~runnable result - ) else ( - (* Someone added a new job while we were setting [need_wakeup] to [true]. - They might or might not have seen that, so we can't be sure they'll send an event. *) - ignore (submit uring : int); - Atomic.set st.need_wakeup false; - Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) - schedule st - ) - ) -and handle_complete st ~runnable result = - submit_pending_io st; (* If something was waiting for a slot, submit it now. *) - match runnable with - | Read req -> - complete_rw_req st req result - | Write req -> - complete_rw_req st req result - | Job k -> - Fiber_context.clear_cancel_fn k.fiber; - if result >= 0 then Suspended.continue k result - else ( - match Fiber_context.get_error k.fiber with - | None -> Suspended.continue k result - | Some e -> - (* If cancelled, report that instead. *) - Suspended.discontinue k e - ) - | Job_no_cancel k -> - Suspended.continue k result - | Cancel_job -> - (* We don't care about the result of the cancel operation, and there's nowhere to send it. - The possibilities are: - 0 : Operation cancelled successfully - -2 : ENOENT - operation completed before cancel took effect - -114 : EALREADY - operation already in progress *) - schedule st - | Job_fn (k, f) -> - Fiber_context.clear_cancel_fn k.fiber; - (* Should we only do this on error, to avoid losing the return value? - We already do that with rw jobs. *) - begin match Fiber_context.get_error k.fiber with - | None -> f result - | Some e -> Suspended.discontinue k e - end -and complete_rw_req st ({len; cur_off; action; _} as req) res = - Fiber_context.clear_cancel_fn action.fiber; - match res, len with - | 0, _ -> Suspended.discontinue action End_of_file - | e, _ when e < 0 -> - begin match Fiber_context.get_error action.fiber with - | Some e -> Suspended.discontinue action e (* If cancelled, report that instead. *) - | None -> - if errno_is_retry e then ( - submit_rw_req st req; - schedule st - ) else ( - Suspended.continue action e - ) - end - | n, Exactly len when n < len - cur_off -> - req.cur_off <- req.cur_off + n; - submit_rw_req st req; - schedule st - | _, Exactly len -> Suspended.continue action len - | n, Upto _ -> Suspended.continue action n - -let rec enqueue_poll_add fd poll_mask st action = - Trace.log "poll_add"; - let retry = with_cancel_hook ~action st (fun () -> - Uring.poll_add st.uring fd poll_mask (Job action) - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_poll_add fd poll_mask st action) st.io_q - -let rec enqueue_poll_add_unix fd poll_mask st action cb = - Trace.log "poll_add"; - let retry = with_cancel_hook ~action st (fun () -> - Uring.poll_add st.uring fd poll_mask (Job_fn (action, cb)) - ) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_poll_add_unix fd poll_mask st action cb) st.io_q - -let rec enqueue_readv args st action = - let (file_offset,fd,bufs) = args in - let retry = with_cancel_hook ~action st (fun () -> - Uring.readv st.uring ~file_offset fd bufs (Job action)) - in - if retry then (* wait until an sqe is available *) - Queue.push (fun st -> enqueue_readv args st action) st.io_q - -let read_eventfd fd buf = - let res = enter "read_eventfd" (enqueue_readv (Optint.Int63.zero, fd, [buf])) in - if res < 0 then ( - raise @@ Unix.Unix_error (Uring.error_of_errno res, "readv", "") - ) else if res = 0 then ( - raise End_of_file - ) else ( - res - ) - -let monitor_event_fd t = - let buf = Cstruct.create 8 in - Eio_unix.Private.Rcfd.use ~if_closed:(fun () -> failwith "event_fd closed!") t.eventfd @@ fun fd -> - while true do - let got = read_eventfd fd buf in - assert (got = 8); - (* We just go back to sleep now, but this will cause the scheduler to look - at the run queue again and notice any new items. *) - done; - assert false - -let run ~extra_effects st main arg = - let rec fork ~new_fiber:fiber fn = - let open Effect.Deep in - Trace.fiber (Fiber_context.tid fiber); - match_with fn () - { retc = (fun () -> Fiber_context.destroy fiber; schedule st); - exnc = (fun ex -> - Fiber_context.destroy fiber; - Printexc.raise_with_backtrace ex (Printexc.get_raw_backtrace ()) - ); - effc = fun (type a) (e : a Effect.t) : ((a, _) continuation -> _) option -> - match e with - | Get -> Some (fun k -> continue k st) - | Enter fn -> Some (fun k -> - match Fiber_context.get_error fiber with - | Some e -> discontinue k e - | None -> - let k = { Suspended.k; fiber } in - fn st k; - schedule st - ) - | Cancel job -> Some (fun k -> - enqueue_cancel job st; - continue k () - ) - | Eio.Private.Effects.Get_context -> Some (fun k -> continue k fiber) - | Eio.Private.Effects.Suspend f -> Some (fun k -> - let k = { Suspended.k; fiber } in - f fiber (function - | Ok v -> enqueue_thread st k v - | Error ex -> enqueue_failed_thread st k ex - ); - schedule st - ) - | Eio.Private.Effects.Fork (new_fiber, f) -> Some (fun k -> - let k = { Suspended.k; fiber } in - enqueue_at_head st k (); - fork ~new_fiber f - ) - | Eio_unix.Private.Await_readable fd -> Some (fun k -> - match Fiber_context.get_error fiber with - | Some e -> discontinue k e - | None -> - let k = { Suspended.k; fiber } in - enqueue_poll_add_unix fd Uring.Poll_mask.(pollin + pollerr) st k (fun res -> - if res >= 0 then Suspended.continue k () - else Suspended.discontinue k (Unix.Unix_error (Uring.error_of_errno res, "await_readable", "")) - ); - schedule st - ) - | Eio_unix.Private.Await_writable fd -> Some (fun k -> - match Fiber_context.get_error fiber with - | Some e -> discontinue k e - | None -> - let k = { Suspended.k; fiber } in - enqueue_poll_add_unix fd Uring.Poll_mask.(pollout + pollerr) st k (fun res -> - if res >= 0 then Suspended.continue k () - else Suspended.discontinue k (Unix.Unix_error (Uring.error_of_errno res, "await_writable", "")) - ); - schedule st - ) - | Eio_unix.Private.Thread_pool.Run_in_systhread fn -> Some (fun k -> - let k = { Suspended.k; fiber } in - let enqueue x = enqueue_thread st k (x, st.thread_pool) in - Eio_unix.Private.Thread_pool.submit st.thread_pool ~ctx:fiber ~enqueue fn; - schedule st - ) - | e -> extra_effects.effc e - } - in - let result = ref None in - let `Exit_scheduler = - let new_fiber = Fiber_context.make_root () in - Domain_local_await.using - ~prepare_for_await:Eio_utils.Dla.prepare_for_await - ~while_running:(fun () -> - fork ~new_fiber (fun () -> - Switch.run_protected ~name:"eio_linux" (fun sw -> - Fiber.fork_daemon ~sw (fun () -> monitor_event_fd st); - match Eio_unix.Private.Thread_pool.run st.thread_pool (fun () -> main arg) with - | x -> result := Some (Ok x) - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - result := Some (Error (ex, bt)) - ) - ) - ) - in - match Option.get !result with - | Ok x -> x - | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt - -type config = { - queue_depth : int; - n_blocks : int; - block_size : int; - polling_timeout : int option; -} - -let config ?(queue_depth=64) ?n_blocks ?(block_size=4096) ?polling_timeout () = - let n_blocks = Option.value n_blocks ~default:queue_depth in - { - queue_depth; - n_blocks; - block_size; - polling_timeout; - } - -external eio_eventfd : int -> Unix.file_descr = "caml_eio_eventfd" - -let no_fallback (`Msg msg) = failwith msg - -let with_eventfd fn = - let eventfd = Eio_unix.Private.Rcfd.make (eio_eventfd 0) in - let close () = - if not (Eio_unix.Private.Rcfd.close eventfd) then failwith "eventfd already closed!" - in - match fn eventfd with - | x -> close (); x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - close (); - Printexc.raise_with_backtrace ex bt - -let with_sched ?(fallback=no_fallback) config fn = - let { queue_depth; n_blocks; block_size; polling_timeout } = config in - match Uring.create ~queue_depth ?polling_timeout () with - | exception Unix.Unix_error(ENOSYS, _, _) -> fallback (`Msg "io_uring is not available on this system") - | exception Unix.Unix_error(EPERM, _, _) -> fallback (`Msg "io_uring is not available (permission denied)") - | uring -> - let probe = Uring.get_probe uring in - if not (Uring.op_supported probe Uring.Op.mkdirat) then ( - Uring.exit uring; - fallback (`Msg "Linux >= 5.15 is required for io_uring support") - ) else ( - (* The reason for an if here is to make sure we only set it once, when - the first domain is starting. This is just to avoid a tsan warning. *) - if not !statx_works && Uring.op_supported probe Uring.Op.msg_ring then - statx_works := true; - match - let mem = - let fixed_buf_len = block_size * n_blocks in - let buf = Bigarray.(Array1.create char c_layout fixed_buf_len) in - match Uring.set_fixed_buffer uring buf with - | Ok () -> - Some (Uring.Region.init ~block_size buf n_blocks) - | Error `ENOMEM -> - None - in - let run_q = Lf_queue.create () in - Lf_queue.push run_q IO; - let sleep_q = Zzz.create () in - let io_q = Queue.create () in - let mem_q = Lwt_dllist.create () in - with_eventfd @@ fun eventfd -> - let thread_pool = Eio_unix.Private.Thread_pool.create ~sleep_q in - fn { mem; uring; run_q; io_q; mem_q; eventfd; need_wakeup = Atomic.make false; sleep_q; thread_pool } - with - | x -> Uring.exit uring; x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - begin - try Uring.exit uring - with ex2 -> - let bt2 = Printexc.get_raw_backtrace () in - raise (Eio.Exn.Multiple [(ex2, bt2); (ex, bt)]) - end; - Printexc.raise_with_backtrace ex bt - ) +[@@@alert "-unstable"] + +open Eio.Std + +module Fiber_context = Eio.Private.Fiber_context +module Trace = Eio.Private.Trace + +module Suspended = Eio_utils.Suspended +module Zzz = Eio_utils.Zzz +module Lf_queue = Eio_utils.Lf_queue + +let statx_works = ref false (* Before Linux 5.18, statx is unreliable *) + +type exit = [`Exit_scheduler] + +type file_offset = [ + | `Pos of Optint.Int63.t + | `Seekable_current + | `Nonseekable_current +] + +type amount = Exactly of int | Upto of int + +type rw_req = { + op : [`R|`W]; + file_offset : file_offset; (* Read from here + cur_off (unless using current pos) *) + fd : Unix.file_descr; + len : amount; + buf : Uring.Region.chunk; + mutable cur_off : int; + action : int Suspended.t; +} + +(* Type of user-data attached to jobs. *) +type io_job = + | Read : rw_req -> io_job + | Job_no_cancel : int Suspended.t -> io_job + | Cancel_job : io_job + | Job : int Suspended.t -> io_job (* A negative result indicates error, and may report cancellation *) + | Write : rw_req -> io_job + | Job_fn : 'a Suspended.t * (int -> [`Exit_scheduler]) -> io_job + (* When done, remove the cancel_fn from [Suspended.t] and call the callback (unless cancelled). *) + +type runnable = + | IO : runnable + | Thread : 'a Suspended.t * 'a -> runnable + | Failed_thread : 'a Suspended.t * exn -> runnable + +type t = { + uring: io_job Uring.t; + mem: Uring.Region.t option; + io_q: (t -> unit) Queue.t; (* waiting for room on [uring] *) + mem_q : Uring.Region.chunk Eio.Private.Single_waiter.t Lwt_dllist.t; + + (* The queue of runnable fibers ready to be resumed. Note: other domains can also add work items here. *) + run_q : runnable Lf_queue.t; + + (* When adding to [run_q] from another domain, this domain may be sleeping and so won't see the event. + In that case, [need_wakeup = true] and you must signal using [eventfd]. *) + eventfd : Eio_unix.Private.Rcfd.t; + + (* If [false], the main thread will check [run_q] before sleeping again + (possibly because an event has been or will be sent to [eventfd]). + It can therefore be set to [false] in either of these cases: + - By the receiving thread because it will check [run_q] before sleeping, or + - By the sending thread because it will signal the main thread later *) + need_wakeup : bool Atomic.t; + + sleep_q: Zzz.t; + + thread_pool : Eio_unix.Private.Thread_pool.t; +} + +type _ Effect.t += + | Enter : (t -> 'a Suspended.t -> unit) -> 'a Effect.t + | Cancel : io_job Uring.job -> unit Effect.t + | Get : t Effect.t + +let get () = Effect.perform Get + +let wake_buffer = + let b = Bytes.create 8 in + Bytes.set_int64_ne b 0 1L; + b + +(* This can be called from any systhread (including ones not running Eio), + and also from signal handlers or GC finalizers. It must not take any locks. *) +let wakeup t = + Atomic.set t.need_wakeup false; (* [t] will check [run_q] after getting the event below *) + Eio_unix.Private.Rcfd.use t.eventfd + (fun fd -> + let sent = Unix.single_write fd wake_buffer 0 8 in + assert (sent = 8) + ) + ~if_closed:ignore (* Domain has shut down (presumably after handling the event) *) + +(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) +let enqueue_thread st k x = + Lf_queue.push st.run_q (Thread (k, x)); + if Atomic.get st.need_wakeup then wakeup st + +(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) +let enqueue_failed_thread st k ex = + Lf_queue.push st.run_q (Failed_thread (k, ex)); + if Atomic.get st.need_wakeup then wakeup st + +(* Can only be called from our own domain, so no need to check for wakeup. *) +let enqueue_at_head st k x = + Lf_queue.push_head st.run_q (Thread (k, x)) + +let enter op fn = + Trace.suspend_fiber op; + Effect.perform (Enter fn) + +let submit uring = + if Uring.sqe_ready uring > 0 then + Trace.with_span "submit" (fun () -> Uring.submit uring) + else + 0 + +let rec enqueue_job t fn = + match fn () with + | Some _ as r -> r + | None -> + if submit t.uring > 0 then enqueue_job t fn + else None + +(* Cancellations always come from the same domain, so no need to send wake events here. *) +let rec enqueue_cancel job t = + Trace.log "cancel"; + match enqueue_job t (fun () -> Uring.cancel t.uring job Cancel_job) with + | None -> Queue.push (fun t -> enqueue_cancel job t) t.io_q + | Some _ -> () + +let cancel job = Effect.perform (Cancel job) + +(* Cancellation + + For operations that can be cancelled we need to set the fiber's cancellation function. + The typical sequence is: + + 1. We submit an operation, getting back a uring job (needed for cancellation). + 2. We set the cancellation function. The function uses the uring job to cancel. + + When the job completes, we clear the cancellation function. The function + must have been set by this point because we don't poll for completions until + the above steps have finished. + + If the context is cancelled while the operation is running, the function will get removed and called, + which will submit a cancellation request to uring. We know the job is still valid at this point because + we clear the cancel function when it completes. + + If the operation completes before Linux processes the cancellation, we get [ENOENT], which we ignore. *) + +(* [with_cancel_hook ~action t fn] calls [fn] to create a job, + then sets the fiber's cancel function to cancel it. + If [action] is already cancelled, it schedules [action] to be discontinued. + @return Whether to retry the operation later, once there is space. *) +let with_cancel_hook ~action t fn = + match Fiber_context.get_error action.Suspended.fiber with + | Some ex -> enqueue_failed_thread t action ex; false + | None -> + match enqueue_job t fn with + | None -> true + | Some job -> + Fiber_context.set_cancel_fn action.fiber (fun _ -> cancel job); + false + +let submit_pending_io st = + match Queue.take_opt st.io_q with + | None -> () + | Some fn -> + Trace.log "submit_pending_io"; + fn st + +let rec submit_rw_req st ({op; file_offset; fd; buf; len; cur_off; action} as req) = + let {uring;io_q;_} = st in + let off = Uring.Region.to_offset buf + cur_off in + let len = match len with Exactly l | Upto l -> l in + let len = len - cur_off in + let retry = with_cancel_hook ~action st (fun () -> + let file_offset = + match file_offset with + | `Pos x -> Optint.Int63.add x (Optint.Int63.of_int cur_off) + | `Seekable_current -> Optint.Int63.minus_one + | `Nonseekable_current -> Optint.Int63.zero + in + match op with + |`R -> Uring.read_fixed uring ~file_offset fd ~off ~len (Read req) + |`W -> Uring.write_fixed uring ~file_offset fd ~off ~len (Write req) + ) + in + if retry then ( + Trace.log "await-sqe"; + (* wait until an sqe is available *) + Queue.push (fun st -> submit_rw_req st req) io_q + ) + +(* TODO bind from unixsupport *) +let errno_is_retry = function -62 | -11 | -4 -> true |_ -> false + +(* Switch control to the next ready continuation. + If none is ready, wait until we get an event to wake one and then switch. + Returns only if there is nothing to do and no queued operations. *) +let rec schedule ({run_q; sleep_q; mem_q; uring; _} as st) : [`Exit_scheduler] = + (* This is not a fair scheduler *) + (* Wakeup any paused fibers *) + match Lf_queue.pop run_q with + | None -> assert false (* We should always have an IO job, at least *) + | Some Thread (k, v) -> (* We already have a runnable task *) + Fiber_context.clear_cancel_fn k.fiber; + Suspended.continue k v + | Some Failed_thread (k, ex) -> + Fiber_context.clear_cancel_fn k.fiber; + Suspended.discontinue k ex + | Some IO -> (* Note: be sure to re-inject the IO task before continuing! *) + (* This is not a fair scheduler: timers always run before all other IO *) + let now = Mtime_clock.now () in + match Zzz.pop ~now sleep_q with + | `Due k -> + (* A sleeping task is now due *) + Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) + begin match k with + | Fiber k -> Suspended.continue k () + | Fn fn -> fn (); schedule st + end + | `Wait_until _ | `Nothing as next_due -> + (* Handle any pending events before submitting. This is faster. *) + match Uring.get_cqe_nonblocking uring with + | Some { data = runnable; result } -> + Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) + handle_complete st ~runnable result + | None -> + let timeout = + match next_due with + | `Wait_until time -> + let time = Mtime.to_uint64_ns time in + let now = Mtime.to_uint64_ns now in + let diff_ns = Int64.sub time now |> Int64.to_float in + Some (diff_ns /. 1e9) + | `Nothing -> None + in + if not (Lf_queue.is_empty st.run_q) then ( + ignore (submit uring : int); + Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) + schedule st + ) else if timeout = None && Uring.active_ops uring = 0 then ( + (* Nothing further can happen at this point. + If there are no events in progress but also still no memory available, something has gone wrong! *) + assert (Lwt_dllist.length mem_q = 0); + Lf_queue.close st.run_q; (* Just to catch bugs if something tries to enqueue later *) + `Exit_scheduler + ) else ( + Atomic.set st.need_wakeup true; + if Lf_queue.is_empty st.run_q then ( + (* At this point we're not going to check [run_q] again before sleeping. + If [need_wakeup] is still [true], this is fine because we don't promise to do that. + If [need_wakeup = false], a wake-up event will arrive and wake us up soon. *) + Trace.suspend_domain Begin; + let result = + (* Hack: liburing automatically retries [io_uring_enter] if an + interrupt is received and no timeout is set. However, we need + to return to OCaml mode so any pending signal handlers can + run. See: https://github.com/ocaml-multicore/eio/issues/732 *) + let timeout = Option.value timeout ~default:1e9 in + Uring.wait ~timeout uring + in + Trace.suspend_domain End; + Atomic.set st.need_wakeup false; + Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) + match result with + | None -> + (* Woken by a timeout, which is now due, or by a signal. *) + schedule st + | Some { data = runnable; result } -> + handle_complete st ~runnable result + ) else ( + (* Someone added a new job while we were setting [need_wakeup] to [true]. + They might or might not have seen that, so we can't be sure they'll send an event. *) + ignore (submit uring : int); + Atomic.set st.need_wakeup false; + Lf_queue.push run_q IO; (* Re-inject IO job in the run queue *) + schedule st + ) + ) +and handle_complete st ~runnable result = + submit_pending_io st; (* If something was waiting for a slot, submit it now. *) + match runnable with + | Read req -> + complete_rw_req st req result + | Write req -> + complete_rw_req st req result + | Job k -> + Fiber_context.clear_cancel_fn k.fiber; + if result >= 0 then Suspended.continue k result + else ( + match Fiber_context.get_error k.fiber with + | None -> Suspended.continue k result + | Some e -> + (* If cancelled, report that instead. *) + Suspended.discontinue k e + ) + | Job_no_cancel k -> + Suspended.continue k result + | Cancel_job -> + (* We don't care about the result of the cancel operation, and there's nowhere to send it. + The possibilities are: + 0 : Operation cancelled successfully + -2 : ENOENT - operation completed before cancel took effect + -114 : EALREADY - operation already in progress *) + schedule st + | Job_fn (k, f) -> + Fiber_context.clear_cancel_fn k.fiber; + (* Should we only do this on error, to avoid losing the return value? + We already do that with rw jobs. *) + begin match Fiber_context.get_error k.fiber with + | None -> f result + | Some e -> Suspended.discontinue k e + end +and complete_rw_req st ({len; cur_off; action; _} as req) res = + Fiber_context.clear_cancel_fn action.fiber; + match res, len with + | 0, _ -> Suspended.discontinue action End_of_file + | e, _ when e < 0 -> + begin match Fiber_context.get_error action.fiber with + | Some e -> Suspended.discontinue action e (* If cancelled, report that instead. *) + | None -> + if errno_is_retry e then ( + submit_rw_req st req; + schedule st + ) else ( + Suspended.continue action e + ) + end + | n, Exactly len when n < len - cur_off -> + req.cur_off <- req.cur_off + n; + submit_rw_req st req; + schedule st + | _, Exactly len -> Suspended.continue action len + | n, Upto _ -> Suspended.continue action n + +let rec enqueue_poll_add fd poll_mask st action = + Trace.log "poll_add"; + let retry = with_cancel_hook ~action st (fun () -> + Uring.poll_add st.uring fd poll_mask (Job action) + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_poll_add fd poll_mask st action) st.io_q + +let rec enqueue_poll_add_unix fd poll_mask st action cb = + Trace.log "poll_add"; + let retry = with_cancel_hook ~action st (fun () -> + Uring.poll_add st.uring fd poll_mask (Job_fn (action, cb)) + ) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_poll_add_unix fd poll_mask st action cb) st.io_q + +let rec enqueue_readv args st action = + let (file_offset,fd,bufs) = args in + let retry = with_cancel_hook ~action st (fun () -> + Uring.readv st.uring ~file_offset fd bufs (Job action)) + in + if retry then (* wait until an sqe is available *) + Queue.push (fun st -> enqueue_readv args st action) st.io_q + +let read_eventfd fd buf = + let res = enter "read_eventfd" (enqueue_readv (Optint.Int63.zero, fd, [buf])) in + if res < 0 then ( + raise @@ Unix.Unix_error (Uring.error_of_errno res, "readv", "") + ) else if res = 0 then ( + raise End_of_file + ) else ( + res + ) + +let monitor_event_fd t = + let buf = Cstruct.create 8 in + Eio_unix.Private.Rcfd.use ~if_closed:(fun () -> failwith "event_fd closed!") t.eventfd @@ fun fd -> + while true do + let got = read_eventfd fd buf in + assert (got = 8); + (* We just go back to sleep now, but this will cause the scheduler to look + at the run queue again and notice any new items. *) + done; + assert false + +let run ~extra_effects st main arg = + let rec fork ~new_fiber:fiber fn = + let open Effect.Deep in + Trace.fiber (Fiber_context.tid fiber); + match_with fn () + { retc = (fun () -> Fiber_context.destroy fiber; schedule st); + exnc = (fun ex -> + Fiber_context.destroy fiber; + Printexc.raise_with_backtrace ex (Printexc.get_raw_backtrace ()) + ); + effc = fun (type a) (e : a Effect.t) : ((a, _) continuation -> _) option -> + match e with + | Get -> Some (fun k -> continue k st) + | Enter fn -> Some (fun k -> + match Fiber_context.get_error fiber with + | Some e -> discontinue k e + | None -> + let k = { Suspended.k; fiber } in + fn st k; + schedule st + ) + | Cancel job -> Some (fun k -> + enqueue_cancel job st; + continue k () + ) + | Eio.Private.Effects.Get_context -> Some (fun k -> continue k fiber) + | Eio.Private.Effects.Suspend f -> Some (fun k -> + let k = { Suspended.k; fiber } in + f fiber (function + | Ok v -> enqueue_thread st k v + | Error ex -> enqueue_failed_thread st k ex + ); + schedule st + ) + | Eio.Private.Effects.Fork (new_fiber, f) -> Some (fun k -> + let k = { Suspended.k; fiber } in + enqueue_at_head st k (); + fork ~new_fiber f + ) + | Eio_unix.Private.Await_readable fd -> Some (fun k -> + match Fiber_context.get_error fiber with + | Some e -> discontinue k e + | None -> + let k = { Suspended.k; fiber } in + enqueue_poll_add_unix fd Uring.Poll_mask.(pollin + pollerr) st k (fun res -> + if res >= 0 then Suspended.continue k () + else Suspended.discontinue k (Unix.Unix_error (Uring.error_of_errno res, "await_readable", "")) + ); + schedule st + ) + | Eio_unix.Private.Await_writable fd -> Some (fun k -> + match Fiber_context.get_error fiber with + | Some e -> discontinue k e + | None -> + let k = { Suspended.k; fiber } in + enqueue_poll_add_unix fd Uring.Poll_mask.(pollout + pollerr) st k (fun res -> + if res >= 0 then Suspended.continue k () + else Suspended.discontinue k (Unix.Unix_error (Uring.error_of_errno res, "await_writable", "")) + ); + schedule st + ) + | Eio_unix.Private.Thread_pool.Run_in_systhread fn -> Some (fun k -> + let k = { Suspended.k; fiber } in + let enqueue x = enqueue_thread st k (x, st.thread_pool) in + Eio_unix.Private.Thread_pool.submit st.thread_pool ~ctx:fiber ~enqueue fn; + schedule st + ) + | e -> extra_effects.effc e + } + in + let result = ref None in + let `Exit_scheduler = + let new_fiber = Fiber_context.make_root () in + Domain_local_await.using + ~prepare_for_await:Eio_utils.Dla.prepare_for_await + ~while_running:(fun () -> + fork ~new_fiber (fun () -> + Switch.run_protected ~name:"eio_linux" (fun sw -> + Fiber.fork_daemon ~sw (fun () -> monitor_event_fd st); + match Eio_unix.Private.Thread_pool.run st.thread_pool (fun () -> main arg) with + | x -> result := Some (Ok x) + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + result := Some (Error (ex, bt)) + ) + ) + ) + in + match Option.get !result with + | Ok x -> x + | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt + +type config = { + queue_depth : int; + n_blocks : int; + block_size : int; + polling_timeout : int option; +} + +let config ?(queue_depth=64) ?n_blocks ?(block_size=4096) ?polling_timeout () = + let n_blocks = Option.value n_blocks ~default:queue_depth in + { + queue_depth; + n_blocks; + block_size; + polling_timeout; + } + +external eio_eventfd : int -> Unix.file_descr = "caml_eio_eventfd" + +let no_fallback (`Msg msg) = failwith msg + +let with_eventfd fn = + let eventfd = Eio_unix.Private.Rcfd.make (eio_eventfd 0) in + let close () = + if not (Eio_unix.Private.Rcfd.close eventfd) then failwith "eventfd already closed!" + in + match fn eventfd with + | x -> close (); x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + close (); + Printexc.raise_with_backtrace ex bt + +let with_sched ?(fallback=no_fallback) config fn = + let { queue_depth; n_blocks; block_size; polling_timeout } = config in + match Uring.create ~queue_depth ?polling_timeout () with + | exception Unix.Unix_error(ENOSYS, _, _) -> fallback (`Msg "io_uring is not available on this system") + | exception Unix.Unix_error(EPERM, _, _) -> fallback (`Msg "io_uring is not available (permission denied)") + | uring -> + let probe = Uring.get_probe uring in + if not (Uring.op_supported probe Uring.Op.mkdirat) then ( + Uring.exit uring; + fallback (`Msg "Linux >= 5.15 is required for io_uring support") + ) else ( + (* The reason for an if here is to make sure we only set it once, when + the first domain is starting. This is just to avoid a tsan warning. *) + if not !statx_works && Uring.op_supported probe Uring.Op.msg_ring then + statx_works := true; + match + let mem = + let fixed_buf_len = block_size * n_blocks in + let buf = Bigarray.(Array1.create char c_layout fixed_buf_len) in + match Uring.set_fixed_buffer uring buf with + | Ok () -> + Some (Uring.Region.init ~block_size buf n_blocks) + | Error `ENOMEM -> + None + in + let run_q = Lf_queue.create () in + Lf_queue.push run_q IO; + let sleep_q = Zzz.create () in + let io_q = Queue.create () in + let mem_q = Lwt_dllist.create () in + with_eventfd @@ fun eventfd -> + let thread_pool = Eio_unix.Private.Thread_pool.create ~sleep_q in + fn { mem; uring; run_q; io_q; mem_q; eventfd; need_wakeup = Atomic.make false; sleep_q; thread_pool } + with + | x -> Uring.exit uring; x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + begin + try Uring.exit uring + with ex2 -> + let bt2 = Printexc.get_raw_backtrace () in + raise (Eio.Exn.Multiple [(ex2, bt2); (ex, bt)]) + end; + Printexc.raise_with_backtrace ex bt + ) diff --git a/lib_eio_linux/tests/basic_eio_linux.ml b/lib_eio_linux/tests/basic_eio_linux.ml index c1ff8b175..450a93ed6 100644 --- a/lib_eio_linux/tests/basic_eio_linux.ml +++ b/lib_eio_linux/tests/basic_eio_linux.ml @@ -1,38 +1,38 @@ -(* basic tests using effects *) - -open Eio_linux.Low_level -open Eio.Std -module Int63 = Optint.Int63 - -let setup_log level = - Fmt_tty.setup_std_outputs (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ()) - -let () = - setup_log (Some Logs.Debug); - Eio_linux.run @@ fun _stdenv -> - Switch.run @@ fun sw -> - let fd = - openat2 "test.txt" - ~sw - ~access:`R - ~perm:0 - ~flags:Uring.Open_flags.empty - ~resolve:Uring.Resolve.empty -in - let buf = alloc_fixed_or_wait () in - let _ = read_exactly fd buf 5 in - print_endline (Uring.Region.to_string ~len:5 buf); - let _ = read_exactly fd ~file_offset:(Int63.of_int 3) buf 3 in - print_endline (Uring.Region.to_string ~len:3 buf); - free_fixed buf; - (* With a sleep: *) - let buf = alloc_fixed_or_wait () in - let _ = read_exactly fd buf 5 in - Logs.debug (fun l -> l "sleeping at %f" (Unix.gettimeofday ())); - sleep_until (Mtime.add_span (Mtime_clock.now ()) Mtime.Span.s |> Option.get); - print_endline (Uring.Region.to_string ~len:5 buf); - let _ = read_exactly fd ~file_offset:(Int63.of_int 3) buf 3 in - print_endline (Uring.Region.to_string ~len:3 buf); - free_fixed buf +(* basic tests using effects *) + +open Eio_linux.Low_level +open Eio.Std +module Int63 = Optint.Int63 + +let setup_log level = + Fmt_tty.setup_std_outputs (); + Logs.set_level level; + Logs.set_reporter (Logs_fmt.reporter ()) + +let () = + setup_log (Some Logs.Debug); + Eio_linux.run @@ fun _stdenv -> + Switch.run @@ fun sw -> + let fd = + openat2 "test.txt" + ~sw + ~access:`R + ~perm:0 + ~flags:Uring.Open_flags.empty + ~resolve:Uring.Resolve.empty +in + let buf = alloc_fixed_or_wait () in + let _ = read_exactly fd buf 5 in + print_endline (Uring.Region.to_string ~len:5 buf); + let _ = read_exactly fd ~file_offset:(Int63.of_int 3) buf 3 in + print_endline (Uring.Region.to_string ~len:3 buf); + free_fixed buf; + (* With a sleep: *) + let buf = alloc_fixed_or_wait () in + let _ = read_exactly fd buf 5 in + Logs.debug (fun l -> l "sleeping at %f" (Unix.gettimeofday ())); + sleep_until (Mtime.add_span (Mtime_clock.now ()) Mtime.Span.s |> Option.get); + print_endline (Uring.Region.to_string ~len:5 buf); + let _ = read_exactly fd ~file_offset:(Int63.of_int 3) buf 3 in + print_endline (Uring.Region.to_string ~len:3 buf); + free_fixed buf diff --git a/lib_eio_linux/tests/bench_noop.ml b/lib_eio_linux/tests/bench_noop.ml index 92e157ddb..71150e0a2 100644 --- a/lib_eio_linux/tests/bench_noop.ml +++ b/lib_eio_linux/tests/bench_noop.ml @@ -1,32 +1,32 @@ -open Eio.Std - -let n_fibers = [1; 2; 3; 4; 5; 10; 20; 30; 40; 50; 100; 500; 1000; 10000] - -let main ~clock = - Printf.printf "n_fibers, ns/iter, promoted/iter\n%!"; - n_fibers |> List.iter (fun n_fibers -> - let n_iters = 1000000 / n_fibers in - Gc.full_major (); - let _minor0, prom0, _major0 = Gc.counters () in - let t0 = Eio.Time.now clock in - Switch.run (fun sw -> - for _ = 1 to n_fibers do - Fiber.fork ~sw (fun () -> - for _ = 1 to n_iters do - Eio_linux.Low_level.noop () - done - ) - done - ); - let t1 = Eio.Time.now clock in - let time_total = t1 -. t0 in - let n_total = n_fibers * n_iters in - let time_per_iter = time_total /. float n_total in - let _minor1, prom1, _major1 = Gc.counters () in - let prom = prom1 -. prom0 in - Printf.printf "%5d, %.2f, %7.4f\n%!" n_fibers (1e9 *. time_per_iter) (prom /. float n_total) - ) - -let () = - Eio_linux.run @@ fun env -> - main ~clock:(Eio.Stdenv.clock env) +open Eio.Std + +let n_fibers = [1; 2; 3; 4; 5; 10; 20; 30; 40; 50; 100; 500; 1000; 10000] + +let main ~clock = + Printf.printf "n_fibers, ns/iter, promoted/iter\n%!"; + n_fibers |> List.iter (fun n_fibers -> + let n_iters = 1000000 / n_fibers in + Gc.full_major (); + let _minor0, prom0, _major0 = Gc.counters () in + let t0 = Eio.Time.now clock in + Switch.run (fun sw -> + for _ = 1 to n_fibers do + Fiber.fork ~sw (fun () -> + for _ = 1 to n_iters do + Eio_linux.Low_level.noop () + done + ) + done + ); + let t1 = Eio.Time.now clock in + let time_total = t1 -. t0 in + let n_total = n_fibers * n_iters in + let time_per_iter = time_total /. float n_total in + let _minor1, prom1, _major1 = Gc.counters () in + let prom = prom1 -. prom0 in + Printf.printf "%5d, %.2f, %7.4f\n%!" n_fibers (1e9 *. time_per_iter) (prom /. float n_total) + ) + +let () = + Eio_linux.run @@ fun env -> + main ~clock:(Eio.Stdenv.clock env) diff --git a/lib_eio_linux/tests/dune b/lib_eio_linux/tests/dune index 4634dd1ec..03c8b2fb6 100644 --- a/lib_eio_linux/tests/dune +++ b/lib_eio_linux/tests/dune @@ -1,59 +1,59 @@ -(library - (name eurcp_lib) - (enabled_if ; See https://github.com/ocaml/dune/issues/4895 - (or (= %{system} "linux") ; Historically, just Linux-x86 - (= %{system} "linux_eabihf") ; Historically, Linux-arm32 - (= %{system} "linux_elf") ; Historically, Linux-x86_32 - (= %{system} "elf"))) ; Historically, Linux-ppc64 - (modules eurcp_lib) - (libraries eio_linux logs)) - -(executable - (name eurcp) - (enabled_if ; See https://github.com/ocaml/dune/issues/4895 - (or (= %{system} "linux") ; Historically, just Linux-x86 - (= %{system} "linux_eabihf") ; Historically, Linux-arm32 - (= %{system} "linux_elf") ; Historically, Linux-x86_32 - (= %{system} "elf"))) ; Historically, Linux-ppc64 - (modules eurcp) - (libraries cmdliner logs.cli logs.fmt fmt.tty fmt.cli eurcp_lib)) - -(executable - (name basic_eio_linux) - (enabled_if ; See https://github.com/ocaml/dune/issues/4895 - (or (= %{system} "linux") ; Historically, just Linux-x86 - (= %{system} "linux_eabihf") ; Historically, Linux-arm32 - (= %{system} "linux_elf") ; Historically, Linux-x86_32 - (= %{system} "elf"))) ; Historically, Linux-ppc64 - (modules basic_eio_linux) - (libraries logs.fmt fmt.tty eurcp_lib)) - -(executables - (names bench_noop) - (enabled_if ; See https://github.com/ocaml/dune/issues/4895 - (or (= %{system} "linux") ; Historically, just Linux-x86 - (= %{system} "linux_eabihf") ; Historically, Linux-arm32 - (= %{system} "linux_elf") ; Historically, Linux-x86_32 - (= %{system} "elf"))) ; Historically, Linux-ppc64 - (modules bench_noop) - (libraries eio_linux)) - -(test - (name test) - (package eio_linux) - (build_if ; See https://github.com/ocaml/dune/issues/4895 - (or (= %{system} "linux") ; Historically, just Linux-x86 - (= %{system} "linux_eabihf") ; Historically, Linux-arm32 - (= %{system} "linux_elf") ; Historically, Linux-x86_32 - (= %{system} "elf"))) ; Historically, Linux-ppc64 - (modules test) - (libraries alcotest eio_linux logs)) - -(mdx - (package eio_linux) - (enabled_if ; See https://github.com/ocaml/dune/issues/4895 - (or (= %{system} "linux") ; Historically, just Linux-x86 - (= %{system} "linux_eabihf") ; Historically, Linux-arm32 - (= %{system} "linux_elf") ; Historically, Linux-x86_32 - (= %{system} "elf"))) ; Historically, Linux-ppc64 - (deps (package eio_linux))) +(library + (name eurcp_lib) + (enabled_if ; See https://github.com/ocaml/dune/issues/4895 + (or (= %{system} "linux") ; Historically, just Linux-x86 + (= %{system} "linux_eabihf") ; Historically, Linux-arm32 + (= %{system} "linux_elf") ; Historically, Linux-x86_32 + (= %{system} "elf"))) ; Historically, Linux-ppc64 + (modules eurcp_lib) + (libraries eio_linux logs)) + +(executable + (name eurcp) + (enabled_if ; See https://github.com/ocaml/dune/issues/4895 + (or (= %{system} "linux") ; Historically, just Linux-x86 + (= %{system} "linux_eabihf") ; Historically, Linux-arm32 + (= %{system} "linux_elf") ; Historically, Linux-x86_32 + (= %{system} "elf"))) ; Historically, Linux-ppc64 + (modules eurcp) + (libraries cmdliner logs.cli logs.fmt fmt.tty fmt.cli eurcp_lib)) + +(executable + (name basic_eio_linux) + (enabled_if ; See https://github.com/ocaml/dune/issues/4895 + (or (= %{system} "linux") ; Historically, just Linux-x86 + (= %{system} "linux_eabihf") ; Historically, Linux-arm32 + (= %{system} "linux_elf") ; Historically, Linux-x86_32 + (= %{system} "elf"))) ; Historically, Linux-ppc64 + (modules basic_eio_linux) + (libraries logs.fmt fmt.tty eurcp_lib)) + +(executables + (names bench_noop) + (enabled_if ; See https://github.com/ocaml/dune/issues/4895 + (or (= %{system} "linux") ; Historically, just Linux-x86 + (= %{system} "linux_eabihf") ; Historically, Linux-arm32 + (= %{system} "linux_elf") ; Historically, Linux-x86_32 + (= %{system} "elf"))) ; Historically, Linux-ppc64 + (modules bench_noop) + (libraries eio_linux)) + +(test + (name test) + (package eio_linux) + (build_if ; See https://github.com/ocaml/dune/issues/4895 + (or (= %{system} "linux") ; Historically, just Linux-x86 + (= %{system} "linux_eabihf") ; Historically, Linux-arm32 + (= %{system} "linux_elf") ; Historically, Linux-x86_32 + (= %{system} "elf"))) ; Historically, Linux-ppc64 + (modules test) + (libraries alcotest eio_linux logs)) + +(mdx + (package eio_linux) + (enabled_if ; See https://github.com/ocaml/dune/issues/4895 + (or (= %{system} "linux") ; Historically, just Linux-x86 + (= %{system} "linux_eabihf") ; Historically, Linux-arm32 + (= %{system} "linux_elf") ; Historically, Linux-x86_32 + (= %{system} "elf"))) ; Historically, Linux-ppc64 + (deps (package eio_linux))) diff --git a/lib_eio_linux/tests/eurcp.ml b/lib_eio_linux/tests/eurcp.ml index b38663870..a50cd8d6d 100644 --- a/lib_eio_linux/tests/eurcp.ml +++ b/lib_eio_linux/tests/eurcp.ml @@ -1,36 +1,36 @@ -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ()) - -open Cmdliner - -let cmd = - let setup_log = - Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) in - let infile = - let doc = "Source filename to copy from" in - Arg.(required & pos 0 (some file) None & info [] ~docv:"SOURCE_FILE" ~doc) in - let outfile = - let doc = "Target filename to copy to" in - Arg.(required & pos 1 (some string) None & info [] ~docv:"TARGET_FILE" ~doc) in - let block_size = - let doc = "Block size per chunk in bytes" in - Arg.(value & opt int (32 * 1024) & info ["block-size"] ~docv:"BYTES" ~doc) in - let queue_depth = - let doc = "Number of async requests in parallel" in - Arg.(value & opt int 64 & info ["queue-depth"] ~docv:"ENTRIES" ~doc) in - let doc = "copy a file using async effect-based io_uring" in - let man = - [ - `S "DESCRIPTION"; - `P "$(tname) copies a file using Linux io_uring."; - ] - in - let info = Cmd.info "eurcp" ~version:"1.0.0" ~doc ~man in - Cmd.v info Term.(const Eurcp_lib.run_cp $ block_size $ queue_depth $ infile $ outfile $ setup_log) - -let () = - match Cmd.eval cmd with - | 0 -> exit (if Logs.err_count () > 0 then 1 else 0) - | _ -> exit 1 +let setup_log style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (Logs_fmt.reporter ()) + +open Cmdliner + +let cmd = + let setup_log = + Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) in + let infile = + let doc = "Source filename to copy from" in + Arg.(required & pos 0 (some file) None & info [] ~docv:"SOURCE_FILE" ~doc) in + let outfile = + let doc = "Target filename to copy to" in + Arg.(required & pos 1 (some string) None & info [] ~docv:"TARGET_FILE" ~doc) in + let block_size = + let doc = "Block size per chunk in bytes" in + Arg.(value & opt int (32 * 1024) & info ["block-size"] ~docv:"BYTES" ~doc) in + let queue_depth = + let doc = "Number of async requests in parallel" in + Arg.(value & opt int 64 & info ["queue-depth"] ~docv:"ENTRIES" ~doc) in + let doc = "copy a file using async effect-based io_uring" in + let man = + [ + `S "DESCRIPTION"; + `P "$(tname) copies a file using Linux io_uring."; + ] + in + let info = Cmd.info "eurcp" ~version:"1.0.0" ~doc ~man in + Cmd.v info Term.(const Eurcp_lib.run_cp $ block_size $ queue_depth $ infile $ outfile $ setup_log) + +let () = + match Cmd.eval cmd with + | 0 -> exit (if Logs.err_count () > 0 then 1 else 0) + | _ -> exit 1 diff --git a/lib_eio_linux/tests/eurcp_lib.ml b/lib_eio_linux/tests/eurcp_lib.ml index aba0cd739..5ce60ed21 100644 --- a/lib_eio_linux/tests/eurcp_lib.ml +++ b/lib_eio_linux/tests/eurcp_lib.ml @@ -1,56 +1,56 @@ -(* cp(1) built with effects. *) - -open Eio.Std - -module U = Eio_linux.Low_level -module Int63 = Optint.Int63 - -let read_then_write_chunk infd outfd file_offset len = - let buf = U.alloc_fixed_or_wait () in - Logs.debug (fun l -> l "r/w start %a (%d)" Int63.pp file_offset len); - U.read_exactly ~file_offset infd buf len; - U.write ~file_offset outfd buf len; - Logs.debug (fun l -> l "r/w done %a (%d)" Int63.pp file_offset len); - U.free_fixed buf - -let copy_file infd outfd insize block_size = - Switch.run @@ fun sw -> - let rec copy_block file_offset = - let remaining = Int63.(sub insize file_offset) in - if remaining <> Int63.zero then ( - let len = Int63.to_int (min (Int63.of_int block_size) remaining) in - Fiber.fork ~sw (fun () -> read_then_write_chunk infd outfd file_offset len); - copy_block Int63.(add file_offset (of_int len)) - ) - in - copy_block Int63.zero - -let run_cp block_size queue_depth infile outfile () = - Eio_linux.run ~queue_depth ~n_blocks:queue_depth ~block_size @@ fun _stdenv -> - Switch.run @@ fun sw -> - let infd = - U.openat2 infile - ~sw ~seekable:true - ~access:`R - ~flags:Uring.Open_flags.empty - ~perm:0 - ~resolve:Uring.Resolve.empty - in - let outfd = - U.openat2 outfile - ~sw - ~seekable:true - ~access:`RW - ~flags:Uring.Open_flags.(creat + trunc) - ~resolve:Uring.Resolve.empty - ~perm:0o644 - in - let insize = (U.fstat infd).size in - Logs.debug (fun l -> l "eurcp: %s -> %s size %a queue %d bs %d" - infile - outfile - Int63.pp insize - queue_depth - block_size); - copy_file infd outfd insize block_size; - Logs.debug (fun l -> l "eurcp: done") +(* cp(1) built with effects. *) + +open Eio.Std + +module U = Eio_linux.Low_level +module Int63 = Optint.Int63 + +let read_then_write_chunk infd outfd file_offset len = + let buf = U.alloc_fixed_or_wait () in + Logs.debug (fun l -> l "r/w start %a (%d)" Int63.pp file_offset len); + U.read_exactly ~file_offset infd buf len; + U.write ~file_offset outfd buf len; + Logs.debug (fun l -> l "r/w done %a (%d)" Int63.pp file_offset len); + U.free_fixed buf + +let copy_file infd outfd insize block_size = + Switch.run @@ fun sw -> + let rec copy_block file_offset = + let remaining = Int63.(sub insize file_offset) in + if remaining <> Int63.zero then ( + let len = Int63.to_int (min (Int63.of_int block_size) remaining) in + Fiber.fork ~sw (fun () -> read_then_write_chunk infd outfd file_offset len); + copy_block Int63.(add file_offset (of_int len)) + ) + in + copy_block Int63.zero + +let run_cp block_size queue_depth infile outfile () = + Eio_linux.run ~queue_depth ~n_blocks:queue_depth ~block_size @@ fun _stdenv -> + Switch.run @@ fun sw -> + let infd = + U.openat2 infile + ~sw ~seekable:true + ~access:`R + ~flags:Uring.Open_flags.empty + ~perm:0 + ~resolve:Uring.Resolve.empty + in + let outfd = + U.openat2 outfile + ~sw + ~seekable:true + ~access:`RW + ~flags:Uring.Open_flags.(creat + trunc) + ~resolve:Uring.Resolve.empty + ~perm:0o644 + in + let insize = (U.fstat infd).size in + Logs.debug (fun l -> l "eurcp: %s -> %s size %a queue %d bs %d" + infile + outfile + Int63.pp insize + queue_depth + block_size); + copy_file infd outfd insize block_size; + Logs.debug (fun l -> l "eurcp: done") diff --git a/lib_eio_linux/tests/fd_sharing.md b/lib_eio_linux/tests/fd_sharing.md index bf8230b94..1c5541614 100644 --- a/lib_eio_linux/tests/fd_sharing.md +++ b/lib_eio_linux/tests/fd_sharing.md @@ -1,61 +1,61 @@ -# Setting up the environment - -```ocaml -# #require "eio_linux";; -``` - -```ocaml -open Eio.Std -``` - -# Tests - -One domain closes an FD after another domain has enqueued a uring operation mentioning it. - -```ocaml -# Eio_linux.run @@ fun env -> - let dm = env#domain_mgr in - Switch.run @@ fun sw -> - let m = Mutex.create () in - Mutex.lock m; - let r, w = Eio_unix.pipe sw in - let ready, set_ready = Promise.create () in - Fiber.both - (fun () -> - Eio.Domain_manager.run dm (fun () -> - Fiber.both - (fun () -> - traceln "Domain 1 enqueuing read on FD"; - let buf = Cstruct.create 1 in - match Eio.Flow.single_read r buf with - | _ -> assert false - | exception End_of_file -> traceln "Read EOF" - ) - (fun () -> - (* We have enqueued a read request, but not yet submitted it to Linux. - Wait for [m] to prevent submission until the main domain is ready. *) - traceln "Waiting for domain 0..."; - Promise.resolve set_ready (); - Mutex.lock m; - traceln "Domain 1 flushing queue" - ) - ) - ) - (fun () -> - Promise.await ready; - traceln "Domain 0 closing FD"; - Eio.Flow.close r; - Fiber.yield (); - traceln "Domain 0 closed FD; waking domain 1"; - Mutex.unlock m; - (* Allow the read to complete. *) - Eio.Flow.close w - );; -+Domain 1 enqueuing read on FD -+Waiting for domain 0... -+Domain 0 closing FD -+Domain 0 closed FD; waking domain 1 -+Domain 1 flushing queue -+Read EOF -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_linux";; +``` + +```ocaml +open Eio.Std +``` + +# Tests + +One domain closes an FD after another domain has enqueued a uring operation mentioning it. + +```ocaml +# Eio_linux.run @@ fun env -> + let dm = env#domain_mgr in + Switch.run @@ fun sw -> + let m = Mutex.create () in + Mutex.lock m; + let r, w = Eio_unix.pipe sw in + let ready, set_ready = Promise.create () in + Fiber.both + (fun () -> + Eio.Domain_manager.run dm (fun () -> + Fiber.both + (fun () -> + traceln "Domain 1 enqueuing read on FD"; + let buf = Cstruct.create 1 in + match Eio.Flow.single_read r buf with + | _ -> assert false + | exception End_of_file -> traceln "Read EOF" + ) + (fun () -> + (* We have enqueued a read request, but not yet submitted it to Linux. + Wait for [m] to prevent submission until the main domain is ready. *) + traceln "Waiting for domain 0..."; + Promise.resolve set_ready (); + Mutex.lock m; + traceln "Domain 1 flushing queue" + ) + ) + ) + (fun () -> + Promise.await ready; + traceln "Domain 0 closing FD"; + Eio.Flow.close r; + Fiber.yield (); + traceln "Domain 0 closed FD; waking domain 1"; + Mutex.unlock m; + (* Allow the read to complete. *) + Eio.Flow.close w + );; ++Domain 1 enqueuing read on FD ++Waiting for domain 0... ++Domain 0 closing FD ++Domain 0 closed FD; waking domain 1 ++Domain 1 flushing queue ++Read EOF +- : unit = () +``` diff --git a/lib_eio_linux/tests/spawn.md b/lib_eio_linux/tests/spawn.md index 8d4521142..e712760b3 100644 --- a/lib_eio_linux/tests/spawn.md +++ b/lib_eio_linux/tests/spawn.md @@ -1,138 +1,138 @@ -```ocaml -# #require "eio_linux";; -``` - -```ocaml -open Eio.Std - -module Process = Eio_linux.Low_level.Process -``` - -## Spawning processes - -Setting environment variables: - -```ocaml -# Eio_linux.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = Process.spawn ~sw Process.Fork_action.[ - execve "/usr/bin/env" - ~argv:[| "env" |] - ~env:[| "FOO=bar" |]; - ] in - Promise.await (Process.exit_status child);; -FOO=bar -- : Unix.process_status = Unix.WEXITED 0 -``` - -Changing directory: - -```ocaml -# Eio_linux.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = Process.spawn ~sw Process.Fork_action.[ - chdir "/"; - execve "/usr/bin/env" - ~argv:[| "env"; "pwd" |] - ~env:(Unix.environment ()) - ] in - Promise.await (Process.exit_status child);; -/ -- : Unix.process_status = Unix.WEXITED 0 -``` - -Changing directory using a file descriptor: - -```ocaml -# Eio_linux.run @@ fun _env -> - Switch.run @@ fun sw -> - let root = - Eio_linux.Low_level.openat2 ~sw "/" - ~seekable:false - ~access:`R - ~perm:0 - ~resolve:Uring.Resolve.empty - ~flags:Uring.Open_flags.(cloexec + path + directory) - in - let child = Process.spawn ~sw Process.Fork_action.[ - fchdir root; - execve "/usr/bin/env" - ~argv:[| "env"; "pwd" |] - ~env:(Unix.environment ()) - ] in - Promise.await (Process.exit_status child);; -/ -- : Unix.process_status = Unix.WEXITED 0 -``` - -Exit status: - -```ocaml -# Eio_linux.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = Process.spawn ~sw Process.Fork_action.[ - execve "/usr/bin/env" - ~argv:[| "env"; "false" |] - ~env:(Unix.environment ()) - ] in - Promise.await (Process.exit_status child);; -- : Unix.process_status = Unix.WEXITED 1 -``` - -Failure starting child: - -```ocaml -# Eio_linux.run @@ fun _env -> - Switch.run @@ fun sw -> - try - let _child = - Process.spawn ~sw Process.Fork_action.[ - chdir "/idontexist"; - execve "/usr/bin/env" - ~argv:[| "env"; "pwd" |] - ~env:(Unix.environment ()) - ] - in - assert false - with Failure ex -> - String.sub ex 0 7 -- : string = "chdir: " -``` - -Signalling a running child: - -```ocaml -# Eio_linux.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = - Process.spawn ~sw Process.Fork_action.[ - execve "/usr/bin/env" - ~argv:[| "env"; "sleep"; "1000" |] - ~env:(Unix.environment ()) - ] - in - Process.signal child Sys.sigkill; - match Promise.await (Process.exit_status child) with - | Unix.WSIGNALED x when x = Sys.sigkill -> traceln "Child got SIGKILL" - | _ -> assert false;; -+Child got SIGKILL -- : unit = () -``` - -Signalling an exited child does nothing: - -```ocaml -# Eio_linux.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = - Process.spawn ~sw Process.Fork_action.[ - execve "/usr/bin/env" - ~argv:[| "env" |] - ~env:[| "FOO=bar" |]; - ] - in - ignore (Promise.await (Process.exit_status child) : Unix.process_status); - Process.signal child Sys.sigkill;; -FOO=bar -- : unit = () -``` +```ocaml +# #require "eio_linux";; +``` + +```ocaml +open Eio.Std + +module Process = Eio_linux.Low_level.Process +``` + +## Spawning processes + +Setting environment variables: + +```ocaml +# Eio_linux.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = Process.spawn ~sw Process.Fork_action.[ + execve "/usr/bin/env" + ~argv:[| "env" |] + ~env:[| "FOO=bar" |]; + ] in + Promise.await (Process.exit_status child);; +FOO=bar +- : Unix.process_status = Unix.WEXITED 0 +``` + +Changing directory: + +```ocaml +# Eio_linux.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = Process.spawn ~sw Process.Fork_action.[ + chdir "/"; + execve "/usr/bin/env" + ~argv:[| "env"; "pwd" |] + ~env:(Unix.environment ()) + ] in + Promise.await (Process.exit_status child);; +/ +- : Unix.process_status = Unix.WEXITED 0 +``` + +Changing directory using a file descriptor: + +```ocaml +# Eio_linux.run @@ fun _env -> + Switch.run @@ fun sw -> + let root = + Eio_linux.Low_level.openat2 ~sw "/" + ~seekable:false + ~access:`R + ~perm:0 + ~resolve:Uring.Resolve.empty + ~flags:Uring.Open_flags.(cloexec + path + directory) + in + let child = Process.spawn ~sw Process.Fork_action.[ + fchdir root; + execve "/usr/bin/env" + ~argv:[| "env"; "pwd" |] + ~env:(Unix.environment ()) + ] in + Promise.await (Process.exit_status child);; +/ +- : Unix.process_status = Unix.WEXITED 0 +``` + +Exit status: + +```ocaml +# Eio_linux.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = Process.spawn ~sw Process.Fork_action.[ + execve "/usr/bin/env" + ~argv:[| "env"; "false" |] + ~env:(Unix.environment ()) + ] in + Promise.await (Process.exit_status child);; +- : Unix.process_status = Unix.WEXITED 1 +``` + +Failure starting child: + +```ocaml +# Eio_linux.run @@ fun _env -> + Switch.run @@ fun sw -> + try + let _child = + Process.spawn ~sw Process.Fork_action.[ + chdir "/idontexist"; + execve "/usr/bin/env" + ~argv:[| "env"; "pwd" |] + ~env:(Unix.environment ()) + ] + in + assert false + with Failure ex -> + String.sub ex 0 7 +- : string = "chdir: " +``` + +Signalling a running child: + +```ocaml +# Eio_linux.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = + Process.spawn ~sw Process.Fork_action.[ + execve "/usr/bin/env" + ~argv:[| "env"; "sleep"; "1000" |] + ~env:(Unix.environment ()) + ] + in + Process.signal child Sys.sigkill; + match Promise.await (Process.exit_status child) with + | Unix.WSIGNALED x when x = Sys.sigkill -> traceln "Child got SIGKILL" + | _ -> assert false;; ++Child got SIGKILL +- : unit = () +``` + +Signalling an exited child does nothing: + +```ocaml +# Eio_linux.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = + Process.spawn ~sw Process.Fork_action.[ + execve "/usr/bin/env" + ~argv:[| "env" |] + ~env:[| "FOO=bar" |]; + ] + in + ignore (Promise.await (Process.exit_status child) : Unix.process_status); + Process.signal child Sys.sigkill;; +FOO=bar +- : unit = () +``` diff --git a/lib_eio_linux/tests/test.ml b/lib_eio_linux/tests/test.ml index 238f909ad..a020633c7 100644 --- a/lib_eio_linux/tests/test.ml +++ b/lib_eio_linux/tests/test.ml @@ -19,7 +19,7 @@ let read_one_byte ~sw r = ) let test_poll_add () = - Eio_linux.run @@ fun _stdenv -> + Eio_linux.run ~fallback:skip (fun _stdenv -> Switch.run @@ fun sw -> let r, w = Eio_unix.pipe sw in let thread = read_one_byte ~sw r in @@ -32,9 +32,10 @@ let test_poll_add () = assert (sent = 1); let result = Promise.await_exn thread in Alcotest.(check string) "Received data" "!" result + ) let test_poll_add_busy () = - Eio_linux.run ~queue_depth:2 @@ fun _stdenv -> + Eio_linux.run ~fallback:skip (fun _stdenv -> Switch.run @@ fun sw -> let r, w = Eio_unix.pipe sw in let a = read_one_byte ~sw r in @@ -50,6 +51,7 @@ let test_poll_add_busy () = Alcotest.(check string) "Received data" "!" a; let b = Promise.await_exn b in Alcotest.(check string) "Received data" "!" b + ) (* Write a string to a pipe and read it out again. *) let test_copy () = diff --git a/lib_eio_posix/domain_mgr.ml b/lib_eio_posix/domain_mgr.ml index f4bc98b9b..9985a62bf 100644 --- a/lib_eio_posix/domain_mgr.ml +++ b/lib_eio_posix/domain_mgr.ml @@ -1,127 +1,127 @@ -(* - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Eio.Std - -[@@@alert "-unstable"] - -module Fd = Eio_unix.Fd -module Trace = Eio.Private.Trace - -let socketpair k ~sw ~domain ~ty ~protocol wrap_a wrap_b = - let open Effect.Deep in - match - let unix_a, unix_b = Unix.socketpair ~cloexec:true domain ty protocol in - let a = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_a in - let b = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_b in - Unix.set_nonblock unix_a; - Unix.set_nonblock unix_b; - (wrap_a a, wrap_b b) - with - | r -> continue k r - | exception Unix.Unix_error (code, name, arg) -> - discontinue k (Err.wrap code name arg) - -(* Run an event loop in the current domain, using [fn x] as the root fiber. *) -let run_event_loop fn x = - Sched.with_sched @@ fun sched -> - let open Effect.Deep in - let extra_effects : _ effect_handler = { - effc = fun (type a) (e : a Effect.t) : ((a, Sched.exit) continuation -> Sched.exit) option -> - match e with - | Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k Time.mono_clock) - | Eio_unix.Net.Import_socket_stream (sw, close_unix, unix_fd) -> Some (fun k -> - let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in - Unix.set_nonblock unix_fd; - continue k (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) - ) - | Eio_unix.Net.Import_socket_listening (sw, close_unix, unix_fd) -> Some (fun k -> - let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in - Unix.set_nonblock unix_fd; - continue k (Net.listening_socket ~hook:Switch.null_hook fd) - ) - | Eio_unix.Net.Import_socket_datagram (sw, close_unix, unix_fd) -> Some (fun k -> - let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in - Unix.set_nonblock unix_fd; - continue k (Net.datagram_socket fd) - ) - | Eio_unix.Net.Socketpair_stream (sw, domain, protocol) -> Some (fun k -> - let wrap fd = (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) in - socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_STREAM wrap wrap - ) - | Eio_unix.Net.Socketpair_datagram (sw, domain, protocol) -> Some (fun k -> - let wrap fd = Net.datagram_socket fd in - socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_DGRAM wrap wrap - ) - | Eio_unix.Private.Pipe sw -> Some (fun k -> - match - let r, w = Low_level.pipe ~sw in - let source = Flow.of_fd r in - let sink = Flow.of_fd w in - (source, sink) - with - | r -> continue k r - | exception Unix.Unix_error (code, name, arg) -> - discontinue k (Err.wrap code name arg) - ) - | _ -> None - } - in - Sched.run ~extra_effects sched fn x - -let wrap_backtrace fn x = - match fn x with - | x -> Ok x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - Error (ex, bt) - -let unwrap_backtrace = function - | Ok x -> x - | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt - -module Impl = struct - type t = unit - - let domain_spawn ctx enqueue fn = - Domain.spawn @@ fun () -> - Trace.domain_spawn ~parent:(Eio.Private.Fiber_context.tid ctx); - Fun.protect fn ~finally:(fun () -> enqueue (Ok ())) - - let run_raw () fn = - let domain = ref None in - Eio.Private.Suspend.enter "run-domain" (fun ctx enqueue -> - domain := Some (domain_spawn ctx enqueue (wrap_backtrace fn)) - ); - Trace.with_span "Domain.join" @@ fun () -> - unwrap_backtrace (Domain.join (Option.get !domain)) - - let run () fn = - let domain = ref None in - Eio.Private.Suspend.enter "run-domain" (fun ctx enqueue -> - let cancelled, set_cancelled = Promise.create () in - Eio.Private.Fiber_context.set_cancel_fn ctx (Promise.resolve set_cancelled); - domain := Some (domain_spawn ctx enqueue (fun () -> - run_event_loop (wrap_backtrace (fun () -> fn ~cancelled)) () - )) - ); - Trace.with_span "Domain.join" @@ fun () -> - unwrap_backtrace (Domain.join (Option.get !domain)) -end - -let v = - let handler = Eio.Domain_manager.Pi.mgr (module Impl) in - Eio.Resource.T ((), handler) +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Eio.Std + +[@@@alert "-unstable"] + +module Fd = Eio_unix.Fd +module Trace = Eio.Private.Trace + +let socketpair k ~sw ~domain ~ty ~protocol wrap_a wrap_b = + let open Effect.Deep in + match + let unix_a, unix_b = Unix.socketpair ~cloexec:true domain ty protocol in + let a = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_a in + let b = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_b in + Unix.set_nonblock unix_a; + Unix.set_nonblock unix_b; + (wrap_a a, wrap_b b) + with + | r -> continue k r + | exception Unix.Unix_error (code, name, arg) -> + discontinue k (Err.wrap code name arg) + +(* Run an event loop in the current domain, using [fn x] as the root fiber. *) +let run_event_loop fn x = + Sched.with_sched @@ fun sched -> + let open Effect.Deep in + let extra_effects : _ effect_handler = { + effc = fun (type a) (e : a Effect.t) : ((a, Sched.exit) continuation -> Sched.exit) option -> + match e with + | Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k Time.mono_clock) + | Eio_unix.Net.Import_socket_stream (sw, close_unix, unix_fd) -> Some (fun k -> + let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in + Unix.set_nonblock unix_fd; + continue k (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) + ) + | Eio_unix.Net.Import_socket_listening (sw, close_unix, unix_fd) -> Some (fun k -> + let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in + Unix.set_nonblock unix_fd; + continue k (Net.listening_socket ~hook:Switch.null_hook fd) + ) + | Eio_unix.Net.Import_socket_datagram (sw, close_unix, unix_fd) -> Some (fun k -> + let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in + Unix.set_nonblock unix_fd; + continue k (Net.datagram_socket fd) + ) + | Eio_unix.Net.Socketpair_stream (sw, domain, protocol) -> Some (fun k -> + let wrap fd = (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) in + socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_STREAM wrap wrap + ) + | Eio_unix.Net.Socketpair_datagram (sw, domain, protocol) -> Some (fun k -> + let wrap fd = Net.datagram_socket fd in + socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_DGRAM wrap wrap + ) + | Eio_unix.Private.Pipe sw -> Some (fun k -> + match + let r, w = Low_level.pipe ~sw in + let source = Flow.of_fd r in + let sink = Flow.of_fd w in + (source, sink) + with + | r -> continue k r + | exception Unix.Unix_error (code, name, arg) -> + discontinue k (Err.wrap code name arg) + ) + | _ -> None + } + in + Sched.run ~extra_effects sched fn x + +let wrap_backtrace fn x = + match fn x with + | x -> Ok x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + Error (ex, bt) + +let unwrap_backtrace = function + | Ok x -> x + | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt + +module Impl = struct + type t = unit + + let domain_spawn ctx enqueue fn = + Domain.spawn @@ fun () -> + Trace.domain_spawn ~parent:(Eio.Private.Fiber_context.tid ctx); + Fun.protect fn ~finally:(fun () -> enqueue (Ok ())) + + let run_raw () fn = + let domain = ref None in + Eio.Private.Suspend.enter "run-domain" (fun ctx enqueue -> + domain := Some (domain_spawn ctx enqueue (wrap_backtrace fn)) + ); + Trace.with_span "Domain.join" @@ fun () -> + unwrap_backtrace (Domain.join (Option.get !domain)) + + let run () fn = + let domain = ref None in + Eio.Private.Suspend.enter "run-domain" (fun ctx enqueue -> + let cancelled, set_cancelled = Promise.create () in + Eio.Private.Fiber_context.set_cancel_fn ctx (Promise.resolve set_cancelled); + domain := Some (domain_spawn ctx enqueue (fun () -> + run_event_loop (wrap_backtrace (fun () -> fn ~cancelled)) () + )) + ); + Trace.with_span "Domain.join" @@ fun () -> + unwrap_backtrace (Domain.join (Option.get !domain)) +end + +let v = + let handler = Eio.Domain_manager.Pi.mgr (module Impl) in + Eio.Resource.T ((), handler) diff --git a/lib_eio_posix/dune b/lib_eio_posix/dune index eb460d7e1..0755df48c 100644 --- a/lib_eio_posix/dune +++ b/lib_eio_posix/dune @@ -1,28 +1,28 @@ -(library - (name eio_posix) - (public_name eio_posix) - (enabled_if (= %{os_type} "Unix")) - (foreign_stubs - (language c) - (flags :standard -D_LARGEFILE64_SOURCE) - (include_dirs ../lib_eio/unix/include) - (names eio_posix_stubs)) - (libraries eio eio.utils eio.unix fmt iomux)) - -(rule - (targets config.ml) - (enabled_if (= %{os_type} "Unix")) - (action (run ./include/discover.exe))) - -(rule - (enabled_if (and (= %{os_type} "Unix") %{bin-available:lintcstubs_arity_cmt})) - (action - (with-stdout-to - primitives.h.new - (run %{bin:lintcstubs_arity_cmt} %{dep:.eio_posix.objs/byte/eio_posix__Low_level.cmt})))) - -(rule - (enabled_if (and (= %{os_type} "Unix") %{bin-available:lintcstubs_arity_cmt})) - (alias runtest) - (action - (diff primitives.h primitives.h.new))) +(library + (name eio_posix) + (public_name eio_posix) + (enabled_if (= %{os_type} "Unix")) + (foreign_stubs + (language c) + (flags :standard -D_LARGEFILE64_SOURCE) + (include_dirs ../lib_eio/unix/include) + (names eio_posix_stubs)) + (libraries eio eio.utils eio.unix fmt iomux)) + +(rule + (targets config.ml) + (enabled_if (= %{os_type} "Unix")) + (action (run ./include/discover.exe))) + +(rule + (enabled_if (and (= %{os_type} "Unix") %{bin-available:lintcstubs_arity_cmt})) + (action + (with-stdout-to + primitives.h.new + (run %{bin:lintcstubs_arity_cmt} %{dep:.eio_posix.objs/byte/eio_posix__Low_level.cmt})))) + +(rule + (enabled_if (and (= %{os_type} "Unix") %{bin-available:lintcstubs_arity_cmt})) + (alias runtest) + (action + (diff primitives.h primitives.h.new))) diff --git a/lib_eio_posix/eio_posix.ml b/lib_eio_posix/eio_posix.ml index 9a838db98..3f7947cde 100644 --- a/lib_eio_posix/eio_posix.ml +++ b/lib_eio_posix/eio_posix.ml @@ -1,42 +1,42 @@ -(* - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -module Low_level = Low_level - -type stdenv = Eio_unix.Stdenv.base - -let run main = - (* SIGPIPE makes no sense in a modern application. *) - Sys.(set_signal sigpipe Signal_ignore); - Eio_unix.Process.install_sigchld_handler (); - let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> _ Eio_unix.source) in - let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> _ Eio_unix.sink) in - let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> _ Eio_unix.sink) in - Domain_mgr.run_event_loop main @@ object (_ : stdenv) - method stdin = stdin - method stdout = stdout - method stderr = stderr - method debug = Eio.Private.Debug.v - method clock = Time.clock - method mono_clock = Time.mono_clock - method net = Net.v - method process_mgr = Process.mgr - method domain_mgr = Domain_mgr.v - method cwd = ((Fs.cwd, "") :> Eio.Fs.dir_ty Eio.Path.t) - method fs = ((Fs.fs, "") :> Eio.Fs.dir_ty Eio.Path.t) - method secure_random = Flow.secure_random - method backend_id = "posix" - end +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Low_level = Low_level + +type stdenv = Eio_unix.Stdenv.base + +let run main = + (* SIGPIPE makes no sense in a modern application. *) + Sys.(set_signal sigpipe Signal_ignore); + Eio_unix.Process.install_sigchld_handler (); + let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> _ Eio_unix.source) in + let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> _ Eio_unix.sink) in + let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> _ Eio_unix.sink) in + Domain_mgr.run_event_loop main @@ object (_ : stdenv) + method stdin = stdin + method stdout = stdout + method stderr = stderr + method debug = Eio.Private.Debug.v + method clock = Time.clock + method mono_clock = Time.mono_clock + method net = Net.v + method process_mgr = Process.mgr + method domain_mgr = Domain_mgr.v + method cwd = ((Fs.cwd, "") :> Eio.Fs.dir_ty Eio.Path.t) + method fs = ((Fs.fs, "") :> Eio.Fs.dir_ty Eio.Path.t) + method secure_random = Flow.secure_random + method backend_id = "posix" + end diff --git a/lib_eio_posix/eio_posix.mli b/lib_eio_posix/eio_posix.mli index a8ca1a138..a6a05aba5 100644 --- a/lib_eio_posix/eio_posix.mli +++ b/lib_eio_posix/eio_posix.mli @@ -1,12 +1,12 @@ -(** Fallback Eio backend for POSIX systems. *) - -type stdenv = Eio_unix.Stdenv.base -(** The type of the standard set of resources available on POSIX systems. *) - -val run : (stdenv -> 'a) -> 'a -(** [run main] runs an event loop and calls [main stdenv] inside it. - - For portable code, you should use {!Eio_main.run} instead, which will call this for you if appropriate. *) - -module Low_level = Low_level -(** Low-level API for making POSIX calls directly. *) +(** Fallback Eio backend for POSIX systems. *) + +type stdenv = Eio_unix.Stdenv.base +(** The type of the standard set of resources available on POSIX systems. *) + +val run : (stdenv -> 'a) -> 'a +(** [run main] runs an event loop and calls [main stdenv] inside it. + + For portable code, you should use {!Eio_main.run} instead, which will call this for you if appropriate. *) + +module Low_level = Low_level +(** Low-level API for making POSIX calls directly. *) diff --git a/lib_eio_posix/eio_posix_stubs.c b/lib_eio_posix/eio_posix_stubs.c index a3895f48c..ce736d824 100644 --- a/lib_eio_posix/eio_posix_stubs.c +++ b/lib_eio_posix/eio_posix_stubs.c @@ -1,561 +1,561 @@ -#include "primitives.h" - -#define _FILE_OFFSET_BITS 64 - -#include -#include -#ifdef __linux__ -#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24 -#include -#else -#include -#endif -#endif -#include -#include -#include -#include -#include -#include -#include - -#include -#include -#include -#include -#include -#include -#include -#include - -#include "fork_action.h" - -#ifdef ARCH_SIXTYFOUR -#define Int63_val(v) Long_val(v) -#define caml_copy_int63(v) Val_long(v) -#else -#define Int63_val(v) (Int64_val(v)) >> 1 -#define caml_copy_int63(v) caml_copy_int64(v << 1) -#endif - -static void caml_stat_free_preserving_errno(void *ptr) { - int saved = errno; - caml_stat_free(ptr); - errno = saved; -} - -CAMLprim value caml_eio_posix_getrandom(value v_ba, value v_off, value v_len) { - CAMLparam1(v_ba); - ssize_t ret; - ssize_t off = (ssize_t)Long_val(v_off); - ssize_t len = (ssize_t)Long_val(v_len); - do { - void *buf = (uint8_t *)Caml_ba_data_val(v_ba) + off; - caml_enter_blocking_section(); -#ifdef __linux__ -#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24 - ret = getrandom(buf, len, 0); -#else - ret = syscall(SYS_getrandom, buf, len, 0); -#endif -#else - arc4random_buf(buf, len); - ret = len; -#endif - caml_leave_blocking_section(); - } while (ret == -1 && errno == EINTR); - if (ret == -1) uerror("getrandom", Nothing); - CAMLreturn(Val_long(ret)); -} - -/* Allocates an array of C iovecs using the cstructs in the array [v_bufs]. */ -static struct iovec *alloc_iov(value v_bufs) { - struct iovec *iov; - int n_bufs = Wosize_val(v_bufs); - - if (n_bufs == 0) return NULL; - iov = caml_stat_calloc_noexc(n_bufs, sizeof(struct iovec)); - if (iov == NULL) - caml_raise_out_of_memory(); - - for (int i = 0; i < n_bufs; i++) { - value v_cs = Field(v_bufs, i); - value v_ba = Field(v_cs, 0); - value v_off = Field(v_cs, 1); - value v_len = Field(v_cs, 2); - iov[i].iov_base = (uint8_t *)Caml_ba_data_val(v_ba) + Long_val(v_off); - iov[i].iov_len = Long_val(v_len); - } - return iov; -} - -CAMLprim value caml_eio_posix_readv(value v_fd, value v_bufs) { - CAMLparam1(v_bufs); - ssize_t r; - int n_bufs = Wosize_val(v_bufs); - struct iovec *iov; - - iov = alloc_iov(v_bufs); - caml_enter_blocking_section(); - r = readv(Int_val(v_fd), iov, n_bufs); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(iov); - if (r < 0) uerror("readv", Nothing); - - CAMLreturn(Val_long(r)); -} - -CAMLprim value caml_eio_posix_writev(value v_fd, value v_bufs) { - CAMLparam1(v_bufs); - ssize_t r; - int n_bufs = Wosize_val(v_bufs); - struct iovec *iov; - - iov = alloc_iov(v_bufs); - caml_enter_blocking_section(); - r = writev(Int_val(v_fd), iov, n_bufs); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(iov); - if (r < 0) uerror("writev", Nothing); - - CAMLreturn(Val_long(r)); -} - -CAMLprim value caml_eio_posix_preadv(value v_fd, value v_bufs, value v_offset) { - CAMLparam2(v_bufs, v_offset); - ssize_t r; - int n_bufs = Wosize_val(v_bufs); - struct iovec *iov; - off_t offset = Int63_val(v_offset); - - iov = alloc_iov(v_bufs); - caml_enter_blocking_section(); - r = preadv(Int_val(v_fd), iov, n_bufs, offset); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(iov); - if (r < 0) uerror("preadv", Nothing); - - CAMLreturn(Val_long(r)); -} - -CAMLprim value caml_eio_posix_pwritev(value v_fd, value v_bufs, value v_offset) { - CAMLparam2(v_bufs, v_offset); - ssize_t r; - int n_bufs = Wosize_val(v_bufs); - struct iovec *iov; - off_t offset = Int63_val(v_offset); - - iov = alloc_iov(v_bufs); - caml_enter_blocking_section(); - r = pwritev(Int_val(v_fd), iov, n_bufs, offset); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(iov); - if (r < 0) uerror("pwritev", Nothing); - - CAMLreturn(Val_long(r)); -} - -CAMLprim value caml_eio_posix_openat(value v_dirfd, value v_pathname, value v_flags, value v_mode) { - CAMLparam1(v_pathname); - char* pathname; - int r; - - caml_unix_check_path(v_pathname, "openat"); - pathname = caml_stat_strdup(String_val(v_pathname)); - - caml_enter_blocking_section(); - r = openat(Int_val(v_dirfd), pathname, Int_val(v_flags), Int_val(v_mode)); - caml_leave_blocking_section(); - - caml_stat_free_preserving_errno(pathname); - if (r < 0) uerror("openat", v_pathname); - CAMLreturn(Val_int(r)); -} - -CAMLprim value caml_eio_posix_mkdirat(value v_fd, value v_path, value v_perm) { - CAMLparam1(v_path); - char *path; - int ret; - caml_unix_check_path(v_path, "mkdirat"); - path = caml_stat_strdup(String_val(v_path)); - caml_enter_blocking_section(); - ret = mkdirat(Int_val(v_fd), path, Int_val(v_perm)); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(path); - if (ret == -1) uerror("mkdirat", v_path); - CAMLreturn(Val_unit); -} - -#define Stat_val(v) (*((struct stat **) Data_custom_val(v))) - -static void finalize_stat(value v) { - caml_stat_free(Stat_val(v)); - Stat_val(v) = NULL; -} - -static struct custom_operations stat_ops = { - "eio_posix.stat", - finalize_stat, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default, - custom_compare_ext_default, - custom_fixed_length_default -}; - -value -caml_eio_posix_make_stat(value v_unit) { - CAMLparam0(); - CAMLlocal1(v); - struct stat *data; - v = caml_alloc_custom_mem(&stat_ops, sizeof(struct stat *), sizeof(struct stat)); - Stat_val(v) = NULL; - data = (struct stat *) caml_stat_alloc(sizeof(struct stat)); - Stat_val(v) = data; - CAMLreturn(v); -} - -static value get_file_type_variant(struct stat *sb) { - int filetype = sb->st_mode & S_IFMT; - switch (filetype) { - case S_IFREG: - return caml_hash_variant("Regular_file"); - case S_IFSOCK: - return caml_hash_variant("Socket"); - case S_IFLNK: - return caml_hash_variant("Symbolic_link"); - case S_IFBLK: - return caml_hash_variant("Block_device"); - case S_IFDIR: - return caml_hash_variant("Directory"); - case S_IFCHR: - return caml_hash_variant("Character_special"); - case S_IFIFO: - return caml_hash_variant("Fifo"); - default: - return caml_hash_variant("Unknown"); - } -} - -CAMLprim value caml_eio_posix_fstatat(value v_stat, value v_fd, value v_path, value v_flags) { - CAMLparam2(v_stat, v_path); - char *path; - int ret; - struct stat *statbuf = Stat_val(v_stat); - bzero(statbuf, sizeof(struct stat)); - caml_unix_check_path(v_path, "fstatat"); - path = caml_stat_strdup(String_val(v_path)); - caml_enter_blocking_section(); - ret = fstatat(Int_val(v_fd), path, statbuf, Int_val(v_flags)); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(path); - if (ret == -1) uerror("fstatat", v_path); - CAMLreturn(Val_unit); -} - -CAMLprim value caml_eio_posix_fstat(value v_stat, value v_fd) { - CAMLparam1(v_stat); - int ret; - struct stat *statbuf = Stat_val(v_stat); - bzero(statbuf, sizeof(struct stat)); - caml_enter_blocking_section(); - ret = fstat(Int_val(v_fd), statbuf); - caml_leave_blocking_section(); - if (ret == -1) uerror("fstat", Nothing); - CAMLreturn(Val_unit); -} - -// Non-allocating (for native mode) accessors for struct stat -#define STAT_GETTER(field, return_type, ocaml_value_maker) \ -return_type ocaml_eio_posix_stat_##field##_native(value v_stat) { \ - struct stat *s = Stat_val(v_stat); \ - return s->st_##field; \ -} \ -value ocaml_eio_posix_stat_ ## field ## _bytes(value v_stat) { \ - return ocaml_value_maker(ocaml_eio_posix_stat_##field##_native(v_stat)); \ -} - -STAT_GETTER(blksize, int64_t, caml_copy_int64) -STAT_GETTER(nlink, int64_t, caml_copy_int64) -STAT_GETTER(uid, int64_t, caml_copy_int64) -STAT_GETTER(gid, int64_t, caml_copy_int64) -STAT_GETTER(ino, int64_t, caml_copy_int64) -STAT_GETTER(size, int64_t, caml_copy_int64) -STAT_GETTER(blocks, int64_t, caml_copy_int64) -STAT_GETTER(mode, intnat, Val_int) - -#define STAT_TIME_GETTER(name,field) \ -int64_t ocaml_eio_posix_stat_##name##_sec_native(value v_stat) { \ - struct stat *s = Stat_val(v_stat); \ - return s->st_##field.tv_sec; \ -} \ -value ocaml_eio_posix_stat_##name##_sec_bytes(value v_stat) { \ - return caml_copy_int64(ocaml_eio_posix_stat_##name##_sec_native(v_stat)); \ -} \ -value ocaml_eio_posix_stat_##name##_nsec(value v_stat) { \ - struct stat *s = Stat_val(v_stat); \ - return Val_int(s->st_##field.tv_nsec); \ -} - -#ifdef __APPLE__ -STAT_TIME_GETTER(atime,atimespec) -STAT_TIME_GETTER(ctime,ctimespec) -STAT_TIME_GETTER(mtime,mtimespec) -#else -STAT_TIME_GETTER(atime,atim) -STAT_TIME_GETTER(ctime,ctim) -STAT_TIME_GETTER(mtime,mtim) -#endif - -intnat -ocaml_eio_posix_stat_perm_native(value v_stat) { - struct stat *s = Stat_val(v_stat); - return (s->st_mode & ~S_IFMT); -} - -value -ocaml_eio_posix_stat_perm_bytes(value v_stat) { - return Val_int(ocaml_eio_posix_stat_perm_native(v_stat)); -} - -value -ocaml_eio_posix_stat_kind(value v_stat) { - struct stat *s = Stat_val(v_stat); - return get_file_type_variant(s); -} - -int64_t -ocaml_eio_posix_stat_rdev_native(value v_stat) { - struct stat *s = Stat_val(v_stat); - return s->st_rdev; -} - -value -ocaml_eio_posix_stat_rdev_bytes(value v_stat) { - return caml_copy_int64(ocaml_eio_posix_stat_rdev_native(v_stat)); -} - -int64_t -ocaml_eio_posix_stat_dev_native(value v_stat) { - struct stat *s = Stat_val(v_stat); - return s->st_dev; -} - -value -ocaml_eio_posix_stat_dev_bytes(value v_stat) { - return caml_copy_int64(ocaml_eio_posix_stat_dev_native(v_stat)); -} - -CAMLprim value caml_eio_posix_unlinkat(value v_fd, value v_path, value v_dir) { - CAMLparam1(v_path); - char *path; - int flags = Bool_val(v_dir) ? AT_REMOVEDIR : 0; - int ret; - caml_unix_check_path(v_path, "unlinkat"); - path = caml_stat_strdup(String_val(v_path)); - caml_enter_blocking_section(); - ret = unlinkat(Int_val(v_fd), path, flags); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(path); - if (ret == -1) uerror("unlinkat", v_path); - CAMLreturn(Val_unit); -} - -CAMLprim value caml_eio_posix_renameat(value v_old_fd, value v_old_path, value v_new_fd, value v_new_path) { - CAMLparam2(v_old_path, v_new_path); - size_t old_path_len = caml_string_length(v_old_path); - size_t new_path_len = caml_string_length(v_new_path); - char *old_path; - char *new_path; - int ret; - caml_unix_check_path(v_old_path, "renameat-old"); - caml_unix_check_path(v_new_path, "renameat-new"); - old_path = caml_stat_alloc(old_path_len + new_path_len + 2); - new_path = old_path + old_path_len + 1; - memcpy(old_path, String_val(v_old_path), old_path_len + 1); - memcpy(new_path, String_val(v_new_path), new_path_len + 1); - caml_enter_blocking_section(); - ret = renameat(Int_val(v_old_fd), old_path, - Int_val(v_new_fd), new_path); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(old_path); - if (ret == -1) uerror("renameat", v_old_path); - CAMLreturn(Val_unit); -} - -CAMLprim value caml_eio_posix_symlinkat(value v_old_path, value v_new_fd, value v_new_path) { - CAMLparam2(v_old_path, v_new_path); - size_t old_path_len = caml_string_length(v_old_path); - size_t new_path_len = caml_string_length(v_new_path); - char *old_path; - char *new_path; - int ret; - caml_unix_check_path(v_old_path, "symlinkat-old"); - caml_unix_check_path(v_new_path, "symlinkat-new"); - old_path = caml_stat_alloc(old_path_len + new_path_len + 2); - new_path = old_path + old_path_len + 1; - memcpy(old_path, String_val(v_old_path), old_path_len + 1); - memcpy(new_path, String_val(v_new_path), new_path_len + 1); - caml_enter_blocking_section(); - ret = symlinkat(old_path, Int_val(v_new_fd), new_path); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(old_path); - if (ret == -1) uerror("symlinkat", v_old_path); - CAMLreturn(Val_unit); -} - -CAMLprim value caml_eio_posix_spawn(value v_errors, value v_actions) { - CAMLparam1(v_actions); - pid_t child_pid; - - child_pid = fork(); - if (child_pid == 0) { - eio_unix_run_fork_actions(Int_val(v_errors), v_actions); - } else if (child_pid < 0) { - uerror("fork", Nothing); - } - - CAMLreturn(Val_long(child_pid)); -} - -/* Copy [n_fds] from [v_fds] to [msg]. */ -static void fill_fds(struct msghdr *msg, int n_fds, value v_fds) { - if (n_fds > 0) { - int i; - struct cmsghdr *cm; - cm = CMSG_FIRSTHDR(msg); - cm->cmsg_level = SOL_SOCKET; - cm->cmsg_type = SCM_RIGHTS; - cm->cmsg_len = CMSG_LEN(n_fds * sizeof(int)); - for (i = 0; i < n_fds; i++) { - int fd = -1; - if (Is_block(v_fds)) { - fd = Int_val(Field(v_fds, 0)); - v_fds = Field(v_fds, 1); - } - ((int *)CMSG_DATA(cm))[i] = fd; - } - } -} - -CAMLprim value caml_eio_posix_send_msg(value v_fd, value v_n_fds, value v_fds, value v_dst_opt, value v_bufs) { - CAMLparam3(v_fds, v_dst_opt, v_bufs); - int n_bufs = Wosize_val(v_bufs); - int n_fds = Int_val(v_n_fds); - union sock_addr_union dst_addr; - struct iovec *iov; - int controllen = n_fds > 0 ? CMSG_SPACE(sizeof(int) * n_fds) : 0; - char cmsg[controllen]; - struct msghdr msg = { - .msg_iovlen = n_bufs, - .msg_control = n_fds > 0 ? cmsg : NULL, - .msg_controllen = controllen, - }; - ssize_t r; - - memset(cmsg, 0, controllen); - - if (Is_some(v_dst_opt)) { - caml_unix_get_sockaddr(Some_val(v_dst_opt), &dst_addr, &msg.msg_namelen); - msg.msg_name = &dst_addr; - } - - iov = alloc_iov(v_bufs); - msg.msg_iov = iov; - fill_fds(&msg, n_fds, v_fds); - - caml_enter_blocking_section(); - r = sendmsg(Int_val(v_fd), &msg, 0); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(iov); - if (r < 0) uerror("send_msg", Nothing); - - CAMLreturn(Val_long(r)); -} - -static value get_msghdr_fds(struct msghdr *msg) { - CAMLparam0(); - CAMLlocal2(v_list, v_cons); - struct cmsghdr *cm; - v_list = Val_int(0); - for (cm = CMSG_FIRSTHDR(msg); cm; cm = CMSG_NXTHDR(msg, cm)) { - if (cm->cmsg_level == SOL_SOCKET && cm->cmsg_type == SCM_RIGHTS) { - int *fds = (int *) CMSG_DATA(cm); - int n_fds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int); - int i; - for (i = n_fds - 1; i >= 0; i--) { - value fd = Val_int(fds[i]); - v_cons = caml_alloc_tuple(2); - Store_field(v_cons, 0, fd); - Store_field(v_cons, 1, v_list); - v_list = v_cons; - } - } - } - CAMLreturn(v_list); -} - -/* Work-around for https://github.com/ocaml/ocaml/issues/12796 */ -static value safe_caml_unix_alloc_sockaddr(union sock_addr_union *adr, socklen_param_type adr_len, int close_on_error) { - struct sockaddr_un empty = { - .sun_family = AF_UNIX, - .sun_path = "", - }; - - if (adr_len < offsetof(struct sockaddr, sa_data)) { - adr = (union sock_addr_union *) ∅ - adr_len = offsetof(struct sockaddr, sa_data); - } - - return caml_unix_alloc_sockaddr(adr, adr_len, close_on_error); -} - -CAMLprim value caml_eio_posix_recv_msg(value v_fd, value v_max_fds, value v_bufs) { - CAMLparam1(v_bufs); - CAMLlocal2(v_result, v_addr); - int max_fds = Int_val(v_max_fds); - int n_bufs = Wosize_val(v_bufs); - struct iovec *iov; - union sock_addr_union source_addr; - int controllen = max_fds > 0 ? CMSG_SPACE(sizeof(int) * max_fds) : 0; - char cmsg[controllen]; - struct msghdr msg = { - .msg_name = &source_addr, - .msg_namelen = sizeof(source_addr), - .msg_iovlen = n_bufs, - .msg_control = max_fds > 0 ? cmsg : NULL, - .msg_controllen = controllen, - }; - ssize_t r; - - memset(cmsg, 0, controllen); - - iov = alloc_iov(v_bufs); - msg.msg_iov = iov; - - caml_enter_blocking_section(); - r = recvmsg(Int_val(v_fd), &msg, 0); - caml_leave_blocking_section(); - caml_stat_free_preserving_errno(iov); - if (r < 0) uerror("recv_msg", Nothing); - - v_addr = safe_caml_unix_alloc_sockaddr(&source_addr, msg.msg_namelen, -1); - - v_result = caml_alloc_tuple(3); - Store_field(v_result, 0, v_addr); - Store_field(v_result, 1, Val_long(r)); - Store_field(v_result, 2, get_msghdr_fds(&msg)); - - CAMLreturn(v_result); -} - -CAMLprim value caml_eio_posix_fdopendir(value v_fd) { - DIR *d = fdopendir(Int_val(v_fd)); - if (!d) - caml_uerror("fdopendir", Nothing); - - value v_result = caml_alloc_small(1, Abstract_tag); - DIR_Val(v_result) = d; - return v_result; -} +#include "primitives.h" + +#define _FILE_OFFSET_BITS 64 + +#include +#include +#ifdef __linux__ +#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24 +#include +#else +#include +#endif +#endif +#include +#include +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +#include "fork_action.h" + +#ifdef ARCH_SIXTYFOUR +#define Int63_val(v) Long_val(v) +#define caml_copy_int63(v) Val_long(v) +#else +#define Int63_val(v) (Int64_val(v)) >> 1 +#define caml_copy_int63(v) caml_copy_int64(v << 1) +#endif + +static void caml_stat_free_preserving_errno(void *ptr) { + int saved = errno; + caml_stat_free(ptr); + errno = saved; +} + +CAMLprim value caml_eio_posix_getrandom(value v_ba, value v_off, value v_len) { + CAMLparam1(v_ba); + ssize_t ret; + ssize_t off = (ssize_t)Long_val(v_off); + ssize_t len = (ssize_t)Long_val(v_len); + do { + void *buf = (uint8_t *)Caml_ba_data_val(v_ba) + off; + caml_enter_blocking_section(); +#ifdef __linux__ +#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24 + ret = getrandom(buf, len, 0); +#else + ret = syscall(SYS_getrandom, buf, len, 0); +#endif +#else + arc4random_buf(buf, len); + ret = len; +#endif + caml_leave_blocking_section(); + } while (ret == -1 && errno == EINTR); + if (ret == -1) uerror("getrandom", Nothing); + CAMLreturn(Val_long(ret)); +} + +/* Allocates an array of C iovecs using the cstructs in the array [v_bufs]. */ +static struct iovec *alloc_iov(value v_bufs) { + struct iovec *iov; + int n_bufs = Wosize_val(v_bufs); + + if (n_bufs == 0) return NULL; + iov = caml_stat_calloc_noexc(n_bufs, sizeof(struct iovec)); + if (iov == NULL) + caml_raise_out_of_memory(); + + for (int i = 0; i < n_bufs; i++) { + value v_cs = Field(v_bufs, i); + value v_ba = Field(v_cs, 0); + value v_off = Field(v_cs, 1); + value v_len = Field(v_cs, 2); + iov[i].iov_base = (uint8_t *)Caml_ba_data_val(v_ba) + Long_val(v_off); + iov[i].iov_len = Long_val(v_len); + } + return iov; +} + +CAMLprim value caml_eio_posix_readv(value v_fd, value v_bufs) { + CAMLparam1(v_bufs); + ssize_t r; + int n_bufs = Wosize_val(v_bufs); + struct iovec *iov; + + iov = alloc_iov(v_bufs); + caml_enter_blocking_section(); + r = readv(Int_val(v_fd), iov, n_bufs); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(iov); + if (r < 0) uerror("readv", Nothing); + + CAMLreturn(Val_long(r)); +} + +CAMLprim value caml_eio_posix_writev(value v_fd, value v_bufs) { + CAMLparam1(v_bufs); + ssize_t r; + int n_bufs = Wosize_val(v_bufs); + struct iovec *iov; + + iov = alloc_iov(v_bufs); + caml_enter_blocking_section(); + r = writev(Int_val(v_fd), iov, n_bufs); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(iov); + if (r < 0) uerror("writev", Nothing); + + CAMLreturn(Val_long(r)); +} + +CAMLprim value caml_eio_posix_preadv(value v_fd, value v_bufs, value v_offset) { + CAMLparam2(v_bufs, v_offset); + ssize_t r; + int n_bufs = Wosize_val(v_bufs); + struct iovec *iov; + off_t offset = Int63_val(v_offset); + + iov = alloc_iov(v_bufs); + caml_enter_blocking_section(); + r = preadv(Int_val(v_fd), iov, n_bufs, offset); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(iov); + if (r < 0) uerror("preadv", Nothing); + + CAMLreturn(Val_long(r)); +} + +CAMLprim value caml_eio_posix_pwritev(value v_fd, value v_bufs, value v_offset) { + CAMLparam2(v_bufs, v_offset); + ssize_t r; + int n_bufs = Wosize_val(v_bufs); + struct iovec *iov; + off_t offset = Int63_val(v_offset); + + iov = alloc_iov(v_bufs); + caml_enter_blocking_section(); + r = pwritev(Int_val(v_fd), iov, n_bufs, offset); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(iov); + if (r < 0) uerror("pwritev", Nothing); + + CAMLreturn(Val_long(r)); +} + +CAMLprim value caml_eio_posix_openat(value v_dirfd, value v_pathname, value v_flags, value v_mode) { + CAMLparam1(v_pathname); + char* pathname; + int r; + + caml_unix_check_path(v_pathname, "openat"); + pathname = caml_stat_strdup(String_val(v_pathname)); + + caml_enter_blocking_section(); + r = openat(Int_val(v_dirfd), pathname, Int_val(v_flags), Int_val(v_mode)); + caml_leave_blocking_section(); + + caml_stat_free_preserving_errno(pathname); + if (r < 0) uerror("openat", v_pathname); + CAMLreturn(Val_int(r)); +} + +CAMLprim value caml_eio_posix_mkdirat(value v_fd, value v_path, value v_perm) { + CAMLparam1(v_path); + char *path; + int ret; + caml_unix_check_path(v_path, "mkdirat"); + path = caml_stat_strdup(String_val(v_path)); + caml_enter_blocking_section(); + ret = mkdirat(Int_val(v_fd), path, Int_val(v_perm)); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(path); + if (ret == -1) uerror("mkdirat", v_path); + CAMLreturn(Val_unit); +} + +#define Stat_val(v) (*((struct stat **) Data_custom_val(v))) + +static void finalize_stat(value v) { + caml_stat_free(Stat_val(v)); + Stat_val(v) = NULL; +} + +static struct custom_operations stat_ops = { + "eio_posix.stat", + finalize_stat, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default, + custom_compare_ext_default, + custom_fixed_length_default +}; + +value +caml_eio_posix_make_stat(value v_unit) { + CAMLparam0(); + CAMLlocal1(v); + struct stat *data; + v = caml_alloc_custom_mem(&stat_ops, sizeof(struct stat *), sizeof(struct stat)); + Stat_val(v) = NULL; + data = (struct stat *) caml_stat_alloc(sizeof(struct stat)); + Stat_val(v) = data; + CAMLreturn(v); +} + +static value get_file_type_variant(struct stat *sb) { + int filetype = sb->st_mode & S_IFMT; + switch (filetype) { + case S_IFREG: + return caml_hash_variant("Regular_file"); + case S_IFSOCK: + return caml_hash_variant("Socket"); + case S_IFLNK: + return caml_hash_variant("Symbolic_link"); + case S_IFBLK: + return caml_hash_variant("Block_device"); + case S_IFDIR: + return caml_hash_variant("Directory"); + case S_IFCHR: + return caml_hash_variant("Character_special"); + case S_IFIFO: + return caml_hash_variant("Fifo"); + default: + return caml_hash_variant("Unknown"); + } +} + +CAMLprim value caml_eio_posix_fstatat(value v_stat, value v_fd, value v_path, value v_flags) { + CAMLparam2(v_stat, v_path); + char *path; + int ret; + struct stat *statbuf = Stat_val(v_stat); + bzero(statbuf, sizeof(struct stat)); + caml_unix_check_path(v_path, "fstatat"); + path = caml_stat_strdup(String_val(v_path)); + caml_enter_blocking_section(); + ret = fstatat(Int_val(v_fd), path, statbuf, Int_val(v_flags)); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(path); + if (ret == -1) uerror("fstatat", v_path); + CAMLreturn(Val_unit); +} + +CAMLprim value caml_eio_posix_fstat(value v_stat, value v_fd) { + CAMLparam1(v_stat); + int ret; + struct stat *statbuf = Stat_val(v_stat); + bzero(statbuf, sizeof(struct stat)); + caml_enter_blocking_section(); + ret = fstat(Int_val(v_fd), statbuf); + caml_leave_blocking_section(); + if (ret == -1) uerror("fstat", Nothing); + CAMLreturn(Val_unit); +} + +// Non-allocating (for native mode) accessors for struct stat +#define STAT_GETTER(field, return_type, ocaml_value_maker) \ +return_type ocaml_eio_posix_stat_##field##_native(value v_stat) { \ + struct stat *s = Stat_val(v_stat); \ + return s->st_##field; \ +} \ +value ocaml_eio_posix_stat_ ## field ## _bytes(value v_stat) { \ + return ocaml_value_maker(ocaml_eio_posix_stat_##field##_native(v_stat)); \ +} + +STAT_GETTER(blksize, int64_t, caml_copy_int64) +STAT_GETTER(nlink, int64_t, caml_copy_int64) +STAT_GETTER(uid, int64_t, caml_copy_int64) +STAT_GETTER(gid, int64_t, caml_copy_int64) +STAT_GETTER(ino, int64_t, caml_copy_int64) +STAT_GETTER(size, int64_t, caml_copy_int64) +STAT_GETTER(blocks, int64_t, caml_copy_int64) +STAT_GETTER(mode, intnat, Val_int) + +#define STAT_TIME_GETTER(name,field) \ +int64_t ocaml_eio_posix_stat_##name##_sec_native(value v_stat) { \ + struct stat *s = Stat_val(v_stat); \ + return s->st_##field.tv_sec; \ +} \ +value ocaml_eio_posix_stat_##name##_sec_bytes(value v_stat) { \ + return caml_copy_int64(ocaml_eio_posix_stat_##name##_sec_native(v_stat)); \ +} \ +value ocaml_eio_posix_stat_##name##_nsec(value v_stat) { \ + struct stat *s = Stat_val(v_stat); \ + return Val_int(s->st_##field.tv_nsec); \ +} + +#ifdef __APPLE__ +STAT_TIME_GETTER(atime,atimespec) +STAT_TIME_GETTER(ctime,ctimespec) +STAT_TIME_GETTER(mtime,mtimespec) +#else +STAT_TIME_GETTER(atime,atim) +STAT_TIME_GETTER(ctime,ctim) +STAT_TIME_GETTER(mtime,mtim) +#endif + +intnat +ocaml_eio_posix_stat_perm_native(value v_stat) { + struct stat *s = Stat_val(v_stat); + return (s->st_mode & ~S_IFMT); +} + +value +ocaml_eio_posix_stat_perm_bytes(value v_stat) { + return Val_int(ocaml_eio_posix_stat_perm_native(v_stat)); +} + +value +ocaml_eio_posix_stat_kind(value v_stat) { + struct stat *s = Stat_val(v_stat); + return get_file_type_variant(s); +} + +int64_t +ocaml_eio_posix_stat_rdev_native(value v_stat) { + struct stat *s = Stat_val(v_stat); + return s->st_rdev; +} + +value +ocaml_eio_posix_stat_rdev_bytes(value v_stat) { + return caml_copy_int64(ocaml_eio_posix_stat_rdev_native(v_stat)); +} + +int64_t +ocaml_eio_posix_stat_dev_native(value v_stat) { + struct stat *s = Stat_val(v_stat); + return s->st_dev; +} + +value +ocaml_eio_posix_stat_dev_bytes(value v_stat) { + return caml_copy_int64(ocaml_eio_posix_stat_dev_native(v_stat)); +} + +CAMLprim value caml_eio_posix_unlinkat(value v_fd, value v_path, value v_dir) { + CAMLparam1(v_path); + char *path; + int flags = Bool_val(v_dir) ? AT_REMOVEDIR : 0; + int ret; + caml_unix_check_path(v_path, "unlinkat"); + path = caml_stat_strdup(String_val(v_path)); + caml_enter_blocking_section(); + ret = unlinkat(Int_val(v_fd), path, flags); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(path); + if (ret == -1) uerror("unlinkat", v_path); + CAMLreturn(Val_unit); +} + +CAMLprim value caml_eio_posix_renameat(value v_old_fd, value v_old_path, value v_new_fd, value v_new_path) { + CAMLparam2(v_old_path, v_new_path); + size_t old_path_len = caml_string_length(v_old_path); + size_t new_path_len = caml_string_length(v_new_path); + char *old_path; + char *new_path; + int ret; + caml_unix_check_path(v_old_path, "renameat-old"); + caml_unix_check_path(v_new_path, "renameat-new"); + old_path = caml_stat_alloc(old_path_len + new_path_len + 2); + new_path = old_path + old_path_len + 1; + memcpy(old_path, String_val(v_old_path), old_path_len + 1); + memcpy(new_path, String_val(v_new_path), new_path_len + 1); + caml_enter_blocking_section(); + ret = renameat(Int_val(v_old_fd), old_path, + Int_val(v_new_fd), new_path); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(old_path); + if (ret == -1) uerror("renameat", v_old_path); + CAMLreturn(Val_unit); +} + +CAMLprim value caml_eio_posix_symlinkat(value v_old_path, value v_new_fd, value v_new_path) { + CAMLparam2(v_old_path, v_new_path); + size_t old_path_len = caml_string_length(v_old_path); + size_t new_path_len = caml_string_length(v_new_path); + char *old_path; + char *new_path; + int ret; + caml_unix_check_path(v_old_path, "symlinkat-old"); + caml_unix_check_path(v_new_path, "symlinkat-new"); + old_path = caml_stat_alloc(old_path_len + new_path_len + 2); + new_path = old_path + old_path_len + 1; + memcpy(old_path, String_val(v_old_path), old_path_len + 1); + memcpy(new_path, String_val(v_new_path), new_path_len + 1); + caml_enter_blocking_section(); + ret = symlinkat(old_path, Int_val(v_new_fd), new_path); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(old_path); + if (ret == -1) uerror("symlinkat", v_old_path); + CAMLreturn(Val_unit); +} + +CAMLprim value caml_eio_posix_spawn(value v_errors, value v_actions) { + CAMLparam1(v_actions); + pid_t child_pid; + + child_pid = fork(); + if (child_pid == 0) { + eio_unix_run_fork_actions(Int_val(v_errors), v_actions); + } else if (child_pid < 0) { + uerror("fork", Nothing); + } + + CAMLreturn(Val_long(child_pid)); +} + +/* Copy [n_fds] from [v_fds] to [msg]. */ +static void fill_fds(struct msghdr *msg, int n_fds, value v_fds) { + if (n_fds > 0) { + int i; + struct cmsghdr *cm; + cm = CMSG_FIRSTHDR(msg); + cm->cmsg_level = SOL_SOCKET; + cm->cmsg_type = SCM_RIGHTS; + cm->cmsg_len = CMSG_LEN(n_fds * sizeof(int)); + for (i = 0; i < n_fds; i++) { + int fd = -1; + if (Is_block(v_fds)) { + fd = Int_val(Field(v_fds, 0)); + v_fds = Field(v_fds, 1); + } + ((int *)CMSG_DATA(cm))[i] = fd; + } + } +} + +CAMLprim value caml_eio_posix_send_msg(value v_fd, value v_n_fds, value v_fds, value v_dst_opt, value v_bufs) { + CAMLparam3(v_fds, v_dst_opt, v_bufs); + int n_bufs = Wosize_val(v_bufs); + int n_fds = Int_val(v_n_fds); + union sock_addr_union dst_addr; + struct iovec *iov; + int controllen = n_fds > 0 ? CMSG_SPACE(sizeof(int) * n_fds) : 0; + char cmsg[controllen]; + struct msghdr msg = { + .msg_iovlen = n_bufs, + .msg_control = n_fds > 0 ? cmsg : NULL, + .msg_controllen = controllen, + }; + ssize_t r; + + memset(cmsg, 0, controllen); + + if (Is_some(v_dst_opt)) { + caml_unix_get_sockaddr(Some_val(v_dst_opt), &dst_addr, &msg.msg_namelen); + msg.msg_name = &dst_addr; + } + + iov = alloc_iov(v_bufs); + msg.msg_iov = iov; + fill_fds(&msg, n_fds, v_fds); + + caml_enter_blocking_section(); + r = sendmsg(Int_val(v_fd), &msg, 0); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(iov); + if (r < 0) uerror("send_msg", Nothing); + + CAMLreturn(Val_long(r)); +} + +static value get_msghdr_fds(struct msghdr *msg) { + CAMLparam0(); + CAMLlocal2(v_list, v_cons); + struct cmsghdr *cm; + v_list = Val_int(0); + for (cm = CMSG_FIRSTHDR(msg); cm; cm = CMSG_NXTHDR(msg, cm)) { + if (cm->cmsg_level == SOL_SOCKET && cm->cmsg_type == SCM_RIGHTS) { + int *fds = (int *) CMSG_DATA(cm); + int n_fds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int); + int i; + for (i = n_fds - 1; i >= 0; i--) { + value fd = Val_int(fds[i]); + v_cons = caml_alloc_tuple(2); + Store_field(v_cons, 0, fd); + Store_field(v_cons, 1, v_list); + v_list = v_cons; + } + } + } + CAMLreturn(v_list); +} + +/* Work-around for https://github.com/ocaml/ocaml/issues/12796 */ +static value safe_caml_unix_alloc_sockaddr(union sock_addr_union *adr, socklen_param_type adr_len, int close_on_error) { + struct sockaddr_un empty = { + .sun_family = AF_UNIX, + .sun_path = "", + }; + + if (adr_len < offsetof(struct sockaddr, sa_data)) { + adr = (union sock_addr_union *) ∅ + adr_len = offsetof(struct sockaddr, sa_data); + } + + return caml_unix_alloc_sockaddr(adr, adr_len, close_on_error); +} + +CAMLprim value caml_eio_posix_recv_msg(value v_fd, value v_max_fds, value v_bufs) { + CAMLparam1(v_bufs); + CAMLlocal2(v_result, v_addr); + int max_fds = Int_val(v_max_fds); + int n_bufs = Wosize_val(v_bufs); + struct iovec *iov; + union sock_addr_union source_addr; + int controllen = max_fds > 0 ? CMSG_SPACE(sizeof(int) * max_fds) : 0; + char cmsg[controllen]; + struct msghdr msg = { + .msg_name = &source_addr, + .msg_namelen = sizeof(source_addr), + .msg_iovlen = n_bufs, + .msg_control = max_fds > 0 ? cmsg : NULL, + .msg_controllen = controllen, + }; + ssize_t r; + + memset(cmsg, 0, controllen); + + iov = alloc_iov(v_bufs); + msg.msg_iov = iov; + + caml_enter_blocking_section(); + r = recvmsg(Int_val(v_fd), &msg, 0); + caml_leave_blocking_section(); + caml_stat_free_preserving_errno(iov); + if (r < 0) uerror("recv_msg", Nothing); + + v_addr = safe_caml_unix_alloc_sockaddr(&source_addr, msg.msg_namelen, -1); + + v_result = caml_alloc_tuple(3); + Store_field(v_result, 0, v_addr); + Store_field(v_result, 1, Val_long(r)); + Store_field(v_result, 2, get_msghdr_fds(&msg)); + + CAMLreturn(v_result); +} + +CAMLprim value caml_eio_posix_fdopendir(value v_fd) { + DIR *d = fdopendir(Int_val(v_fd)); + if (!d) + caml_uerror("fdopendir", Nothing); + + value v_result = caml_alloc_small(1, Abstract_tag); + DIR_Val(v_result) = d; + return v_result; +} diff --git a/lib_eio_posix/err.ml b/lib_eio_posix/err.ml index 00017155f..81c501020 100644 --- a/lib_eio_posix/err.ml +++ b/lib_eio_posix/err.ml @@ -1,29 +1,29 @@ -type Eio.Exn.Backend.t += - | Outside_sandbox of string - | Absolute_path - | Invalid_leaf of string - -let unclassified_error e = Eio.Exn.create (Eio.Exn.X e) - -let () = - Eio.Exn.Backend.register_pp (fun f -> function - | Outside_sandbox path -> Fmt.pf f "Outside_sandbox (%S)" path; true - | Absolute_path -> Fmt.pf f "Absolute_path"; true - | Invalid_leaf x -> Fmt.pf f "Invalid_leaf %S" x; true - | _ -> false - ) - -let wrap code name arg = - let e = Eio_unix.Unix_error (code, name, arg) in - match code with - | EEXIST -> Eio.Fs.err (Already_exists e) - | ENOENT -> Eio.Fs.err (Not_found e) - | EXDEV | EACCES | EPERM -> Eio.Fs.err (Permission_denied e) - | ECONNREFUSED -> Eio.Net.err (Connection_failure (Refused e)) - | ECONNRESET | EPIPE -> Eio.Net.err (Connection_reset e) - | _ -> unclassified_error e - -let run fn x = - try fn x - with Unix.Unix_error (code, name, arg) -> - raise (wrap code name arg) +type Eio.Exn.Backend.t += + | Outside_sandbox of string + | Absolute_path + | Invalid_leaf of string + +let unclassified_error e = Eio.Exn.create (Eio.Exn.X e) + +let () = + Eio.Exn.Backend.register_pp (fun f -> function + | Outside_sandbox path -> Fmt.pf f "Outside_sandbox (%S)" path; true + | Absolute_path -> Fmt.pf f "Absolute_path"; true + | Invalid_leaf x -> Fmt.pf f "Invalid_leaf %S" x; true + | _ -> false + ) + +let wrap code name arg = + let e = Eio_unix.Unix_error (code, name, arg) in + match code with + | EEXIST -> Eio.Fs.err (Already_exists e) + | ENOENT -> Eio.Fs.err (Not_found e) + | EXDEV | EACCES | EPERM -> Eio.Fs.err (Permission_denied e) + | ECONNREFUSED -> Eio.Net.err (Connection_failure (Refused e)) + | ECONNRESET | EPIPE -> Eio.Net.err (Connection_reset e) + | _ -> unclassified_error e + +let run fn x = + try fn x + with Unix.Unix_error (code, name, arg) -> + raise (wrap code name arg) diff --git a/lib_eio_posix/flow.ml b/lib_eio_posix/flow.ml index 89f663375..fa1ab9a2e 100644 --- a/lib_eio_posix/flow.ml +++ b/lib_eio_posix/flow.ml @@ -1,144 +1,144 @@ -open Eio.Std - -module Fd = Eio_unix.Fd - -let float_of_time s ns = - let s = Int64.to_float s in - let f = s +. (float ns /. 1e9) in - (* It's possible that we might round up to the next second. - Since some algorithms only care about the seconds part, - make sure the integer part is always [s]: *) - if floor f = s then f - else Float.pred f - -let eio_of_stat x = - { Eio.File.Stat. - dev = Low_level.dev x; - ino = Low_level.ino x; - kind = Low_level.kind x; - perm = Low_level.perm x; - nlink = Low_level.nlink x; - uid = Low_level.uid x; - gid = Low_level.gid x; - rdev = Low_level.rdev x; - size = Low_level.size x |> Optint.Int63.of_int64; - atime = float_of_time (Low_level.atime_sec x) (Low_level.atime_nsec x); - mtime = float_of_time (Low_level.mtime_sec x) (Low_level.mtime_nsec x); - ctime = float_of_time (Low_level.ctime_sec x) (Low_level.ctime_nsec x); - } - -let truncate_to_iomax xs = - let rec count i = function - | [] -> i - | _ when i = Config.iov_max -> Config.iov_max - | _ :: xs -> count (i + 1) xs - in - let len = count 0 xs in - let arr = Array.make len Cstruct.empty in - let rec fill i xs = - if i = len then arr - else ( - match xs with - | x :: xs -> - Array.set arr i x; - fill (i + 1) xs - | [] -> assert false - ) in - fill 0 xs - -module Impl = struct - type tag = [`Generic | `Unix] - - type t = Eio_unix.Fd.t - - let stat t = - try - let x = Low_level.create_stat () in - Low_level.fstat ~buf:x t; - eio_of_stat x - with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg - - let single_write t bufs = - try - Low_level.writev t (truncate_to_iomax bufs) - with Unix.Unix_error (code, name, arg) -> - raise (Err.wrap code name arg) - - (* Copy using the [Read_source_buffer] optimisation. - Avoids a copy if the source already has the data. *) - let copy_with_rsb rsb dst = - try - while true do rsb (single_write dst) done - with End_of_file -> () - - let copy t ~src = - let Eio.Resource.T (src_t, ops) = src in - let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in - let rec aux = function - | Eio.Flow.Read_source_buffer rsb :: _ -> copy_with_rsb (rsb src_t) t - | _ :: xs -> aux xs - | [] -> Eio.Flow.Pi.simple_copy ~single_write t ~src - in - aux Src.read_methods - - let single_read t buf = - match Low_level.readv t [| buf |] with - | 0 -> raise End_of_file - | got -> got - | exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg) - - let shutdown t cmd = - try - Low_level.shutdown t @@ match cmd with - | `Receive -> Unix.SHUTDOWN_RECEIVE - | `Send -> Unix.SHUTDOWN_SEND - | `All -> Unix.SHUTDOWN_ALL - with - | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () - | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - - let read_methods = [] - - let pread t ~file_offset bufs = - let got = Low_level.preadv ~file_offset t (truncate_to_iomax bufs) in - if got = 0 then raise End_of_file - else got - - let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (truncate_to_iomax bufs) - - let send_msg t ~fds data = - Low_level.send_msg ~fds t (truncate_to_iomax data) - - let recv_msg_with_fds t ~sw ~max_fds data = - let _addr, n, fds = Low_level.recv_msg_with_fds t ~sw ~max_fds (truncate_to_iomax data) in - n, fds - - let seek = Low_level.lseek - let sync = Low_level.fsync - let truncate = Low_level.ftruncate - - let fd t = t - - let close = Eio_unix.Fd.close -end - -let handler = Eio_unix.Pi.flow_handler (module Impl) - -let of_fd fd = - let r = Eio.Resource.T (fd, handler) in - (r : [`Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :> - [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r) - -module Secure_random = struct - type t = unit - - let single_read () buf = - Low_level.getrandom buf; - Cstruct.length buf - - let read_methods = [] -end - -let secure_random = - let ops = Eio.Flow.Pi.source (module Secure_random) in - Eio.Resource.T ((), ops) +open Eio.Std + +module Fd = Eio_unix.Fd + +let float_of_time s ns = + let s = Int64.to_float s in + let f = s +. (float ns /. 1e9) in + (* It's possible that we might round up to the next second. + Since some algorithms only care about the seconds part, + make sure the integer part is always [s]: *) + if floor f = s then f + else Float.pred f + +let eio_of_stat x = + { Eio.File.Stat. + dev = Low_level.dev x; + ino = Low_level.ino x; + kind = Low_level.kind x; + perm = Low_level.perm x; + nlink = Low_level.nlink x; + uid = Low_level.uid x; + gid = Low_level.gid x; + rdev = Low_level.rdev x; + size = Low_level.size x |> Optint.Int63.of_int64; + atime = float_of_time (Low_level.atime_sec x) (Low_level.atime_nsec x); + mtime = float_of_time (Low_level.mtime_sec x) (Low_level.mtime_nsec x); + ctime = float_of_time (Low_level.ctime_sec x) (Low_level.ctime_nsec x); + } + +let truncate_to_iomax xs = + let rec count i = function + | [] -> i + | _ when i = Config.iov_max -> Config.iov_max + | _ :: xs -> count (i + 1) xs + in + let len = count 0 xs in + let arr = Array.make len Cstruct.empty in + let rec fill i xs = + if i = len then arr + else ( + match xs with + | x :: xs -> + Array.set arr i x; + fill (i + 1) xs + | [] -> assert false + ) in + fill 0 xs + +module Impl = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t + + let stat t = + try + let x = Low_level.create_stat () in + Low_level.fstat ~buf:x t; + eio_of_stat x + with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg + + let single_write t bufs = + try + Low_level.writev t (truncate_to_iomax bufs) + with Unix.Unix_error (code, name, arg) -> + raise (Err.wrap code name arg) + + (* Copy using the [Read_source_buffer] optimisation. + Avoids a copy if the source already has the data. *) + let copy_with_rsb rsb dst = + try + while true do rsb (single_write dst) done + with End_of_file -> () + + let copy t ~src = + let Eio.Resource.T (src_t, ops) = src in + let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in + let rec aux = function + | Eio.Flow.Read_source_buffer rsb :: _ -> copy_with_rsb (rsb src_t) t + | _ :: xs -> aux xs + | [] -> Eio.Flow.Pi.simple_copy ~single_write t ~src + in + aux Src.read_methods + + let single_read t buf = + match Low_level.readv t [| buf |] with + | 0 -> raise End_of_file + | got -> got + | exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg) + + let shutdown t cmd = + try + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL + with + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () + | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) + + let read_methods = [] + + let pread t ~file_offset bufs = + let got = Low_level.preadv ~file_offset t (truncate_to_iomax bufs) in + if got = 0 then raise End_of_file + else got + + let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (truncate_to_iomax bufs) + + let send_msg t ~fds data = + Low_level.send_msg ~fds t (truncate_to_iomax data) + + let recv_msg_with_fds t ~sw ~max_fds data = + let _addr, n, fds = Low_level.recv_msg_with_fds t ~sw ~max_fds (truncate_to_iomax data) in + n, fds + + let seek = Low_level.lseek + let sync = Low_level.fsync + let truncate = Low_level.ftruncate + + let fd t = t + + let close = Eio_unix.Fd.close +end + +let handler = Eio_unix.Pi.flow_handler (module Impl) + +let of_fd fd = + let r = Eio.Resource.T (fd, handler) in + (r : [`Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :> + [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r) + +module Secure_random = struct + type t = unit + + let single_read () buf = + Low_level.getrandom buf; + Cstruct.length buf + + let read_methods = [] +end + +let secure_random = + let ops = Eio.Flow.Pi.source (module Secure_random) in + Eio.Resource.T ((), ops) diff --git a/lib_eio_posix/fs.ml b/lib_eio_posix/fs.ml index 1a20523a0..439c6b6e3 100644 --- a/lib_eio_posix/fs.ml +++ b/lib_eio_posix/fs.ml @@ -1,136 +1,136 @@ -(* - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -(* This module provides (optional) sandboxing, allowing operations to be restricted to a subtree. - - On FreeBSD we use O_RESOLVE_BENEATH and let the OS handle everything for us. - On other systems we resolve one path component at a time. *) - -open Eio.Std - -module Fd = Eio_unix.Fd - -(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check - that the new location is within its sandbox. *) -type (_, _, _) Eio.Resource.pi += Posix_dir : ('t, 't -> Low_level.dir_fd, [> `Posix_dir]) Eio.Resource.pi - -let as_posix_dir (Eio.Resource.T (t, ops)) = - match Eio.Resource.get_opt ops Posix_dir with - | None -> None - | Some fn -> Some (fn t) - -module rec Dir : sig - include Eio.Fs.Pi.DIR - - val v : label:string -> path:string -> Low_level.dir_fd -> t - - val fd : t -> Low_level.dir_fd -end = struct - type t = { - fd : Low_level.dir_fd; - dir_path : string; - label : string; - } - - let fd t = t.fd - - let v ~label ~path:dir_path fd = { fd; dir_path; label } - - let open_in t ~sw path = - let fd = Err.run (Low_level.openat ~mode:0 ~sw t.fd path) Low_level.Open_flags.rdonly in - (Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t) - - let open_out t ~sw ~append ~create path = - let mode, flags = - match create with - | `Never -> 0, Low_level.Open_flags.empty - | `If_missing perm -> perm, Low_level.Open_flags.creat - | `Or_truncate perm -> perm, Low_level.Open_flags.(creat + trunc) - | `Exclusive perm -> perm, Low_level.Open_flags.(creat + excl) - in - let flags = if append then Low_level.Open_flags.(flags + append) else flags in - let flags = Low_level.Open_flags.(flags + rdwr) in - match Low_level.openat ~sw ~mode t.fd path flags with - | fd -> (Flow.of_fd fd :> Eio.File.rw_ty r) - | exception Unix.Unix_error (code, name, arg) -> - raise (Err.wrap code name arg) - - let mkdir t ~perm path = - Err.run (Low_level.mkdir ~mode:perm t.fd) path - - let unlink t path = - Err.run (Low_level.unlink ~dir:false t.fd) path - - let rmdir t path = - Err.run (Low_level.unlink ~dir:true t.fd) path - - let stat t ~follow path = - let buf = Low_level.create_stat () in - Err.run (Low_level.fstatat ~buf ~follow t.fd) path; - Flow.eio_of_stat buf - - let read_dir t path = - Err.run (Low_level.readdir t.fd) path - |> Array.to_list - - let read_link t path = - Err.run (Low_level.read_link t.fd) path - - let rename t old_path new_dir new_path = - match as_posix_dir new_dir with - | None -> invalid_arg "Target is not an eio_posix directory!" - | Some new_dir -> Err.run (Low_level.rename t.fd old_path new_dir) new_path - - let symlink ~link_to t path = - Err.run (Low_level.symlink ~link_to t.fd) path - - let open_dir t ~sw path = - let flags = Low_level.Open_flags.(rdonly + directory +? path) in - let fd = Err.run (Low_level.openat ~sw ~mode:0 t.fd path) flags in - let label = Filename.basename path in - let full_path = if Filename.is_relative path then Filename.concat t.dir_path path else path in - let d = v ~label ~path:full_path (Fd fd) in - Eio.Resource.T (d, Handler.v) - - let pp f t = Fmt.string f (String.escaped t.label) - - let native_internal t path = - if Filename.is_relative path then ( - let p = - if t.dir_path = "." then path - else Filename.concat t.dir_path path - in - if p = "" then "." - else if p = "." then p - else if Filename.is_implicit p then "./" ^ p - else p - ) else path - - let native t path = - Some (native_internal t path) -end -and Handler : sig - val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler -end = struct - let v = Eio.Resource.handler [ - H (Eio.Fs.Pi.Dir, (module Dir)); - H (Posix_dir, Dir.fd); - ] -end - -(* Full access to the filesystem. *) -let fs = Eio.Resource.T (Dir.v ~label:"fs" ~path:"." Fs, Handler.v) -let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~path:"." Cwd, Handler.v) +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* This module provides (optional) sandboxing, allowing operations to be restricted to a subtree. + + On FreeBSD we use O_RESOLVE_BENEATH and let the OS handle everything for us. + On other systems we resolve one path component at a time. *) + +open Eio.Std + +module Fd = Eio_unix.Fd + +(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check + that the new location is within its sandbox. *) +type (_, _, _) Eio.Resource.pi += Posix_dir : ('t, 't -> Low_level.dir_fd, [> `Posix_dir]) Eio.Resource.pi + +let as_posix_dir (Eio.Resource.T (t, ops)) = + match Eio.Resource.get_opt ops Posix_dir with + | None -> None + | Some fn -> Some (fn t) + +module rec Dir : sig + include Eio.Fs.Pi.DIR + + val v : label:string -> path:string -> Low_level.dir_fd -> t + + val fd : t -> Low_level.dir_fd +end = struct + type t = { + fd : Low_level.dir_fd; + dir_path : string; + label : string; + } + + let fd t = t.fd + + let v ~label ~path:dir_path fd = { fd; dir_path; label } + + let open_in t ~sw path = + let fd = Err.run (Low_level.openat ~mode:0 ~sw t.fd path) Low_level.Open_flags.rdonly in + (Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t) + + let open_out t ~sw ~append ~create path = + let mode, flags = + match create with + | `Never -> 0, Low_level.Open_flags.empty + | `If_missing perm -> perm, Low_level.Open_flags.creat + | `Or_truncate perm -> perm, Low_level.Open_flags.(creat + trunc) + | `Exclusive perm -> perm, Low_level.Open_flags.(creat + excl) + in + let flags = if append then Low_level.Open_flags.(flags + append) else flags in + let flags = Low_level.Open_flags.(flags + rdwr) in + match Low_level.openat ~sw ~mode t.fd path flags with + | fd -> (Flow.of_fd fd :> Eio.File.rw_ty r) + | exception Unix.Unix_error (code, name, arg) -> + raise (Err.wrap code name arg) + + let mkdir t ~perm path = + Err.run (Low_level.mkdir ~mode:perm t.fd) path + + let unlink t path = + Err.run (Low_level.unlink ~dir:false t.fd) path + + let rmdir t path = + Err.run (Low_level.unlink ~dir:true t.fd) path + + let stat t ~follow path = + let buf = Low_level.create_stat () in + Err.run (Low_level.fstatat ~buf ~follow t.fd) path; + Flow.eio_of_stat buf + + let read_dir t path = + Err.run (Low_level.readdir t.fd) path + |> Array.to_list + + let read_link t path = + Err.run (Low_level.read_link t.fd) path + + let rename t old_path new_dir new_path = + match as_posix_dir new_dir with + | None -> invalid_arg "Target is not an eio_posix directory!" + | Some new_dir -> Err.run (Low_level.rename t.fd old_path new_dir) new_path + + let symlink ~link_to t path = + Err.run (Low_level.symlink ~link_to t.fd) path + + let open_dir t ~sw path = + let flags = Low_level.Open_flags.(rdonly + directory +? path) in + let fd = Err.run (Low_level.openat ~sw ~mode:0 t.fd path) flags in + let label = Filename.basename path in + let full_path = if Filename.is_relative path then Filename.concat t.dir_path path else path in + let d = v ~label ~path:full_path (Fd fd) in + Eio.Resource.T (d, Handler.v) + + let pp f t = Fmt.string f (String.escaped t.label) + + let native_internal t path = + if Filename.is_relative path then ( + let p = + if t.dir_path = "." then path + else Filename.concat t.dir_path path + in + if p = "" then "." + else if p = "." then p + else if Filename.is_implicit p then "./" ^ p + else p + ) else path + + let native t path = + Some (native_internal t path) +end +and Handler : sig + val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler +end = struct + let v = Eio.Resource.handler [ + H (Eio.Fs.Pi.Dir, (module Dir)); + H (Posix_dir, Dir.fd); + ] +end + +(* Full access to the filesystem. *) +let fs = Eio.Resource.T (Dir.v ~label:"fs" ~path:"." Fs, Handler.v) +let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~path:"." Cwd, Handler.v) diff --git a/lib_eio_posix/include/discover.ml b/lib_eio_posix/include/discover.ml index 6baa8c080..73b431bdc 100644 --- a/lib_eio_posix/include/discover.ml +++ b/lib_eio_posix/include/discover.ml @@ -1,57 +1,57 @@ -module C = Configurator.V1 - -let optional_flags = [ - "O_DSYNC"; - "O_RESOLVE_BENEATH"; - "O_PATH"; -] - -let () = - C.main ~name:"discover" (fun c -> - let c_flags = ["-D_LARGEFILE64_SOURCE"; "-D_XOPEN_SOURCE=700"; "-D_DARWIN_C_SOURCE"; "-D_GNU_SOURCE"; "-D_BSD_SOURCE"] in - let includes = ["sys/types.h"; "sys/stat.h"; "fcntl.h"] in - let extra_flags, missing_defs = - C.C_define.import c ~c_flags ~includes - C.C_define.Type.(List.map (fun name -> name, Switch) optional_flags) - |> List.partition_map (function - | name, C.C_define.Value.Switch true -> Left (name, C.C_define.Type.Int) - | name, Switch false -> - Right (Printf.sprintf "let %s = None" (String.lowercase_ascii name)) - | _ -> assert false - ) - in - let present_defs = - C.C_define.import c ~c_flags - ~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"; "limits.h"] - C.C_define.Type.(extra_flags @ [ - "O_RDONLY", Int; - "O_RDWR", Int; - "O_WRONLY", Int; - - "O_APPEND", Int; - "O_CLOEXEC", Int; - "O_CREAT", Int; - "O_DIRECTORY", Int; - "O_EXCL", Int; - "O_NOCTTY", Int; - "O_NOFOLLOW", Int; - "O_NONBLOCK", Int; - "O_SYNC", Int; - "O_TRUNC", Int; - - "AT_FDCWD", Int; - "AT_SYMLINK_NOFOLLOW", Int; - - "IOV_MAX", Int; - ]) - |> List.map (function - | name, C.C_define.Value.Int v when List.mem name optional_flags -> - Printf.sprintf "let %s = Some 0x%x" (String.lowercase_ascii name) v - | name, C.C_define.Value.Int v -> - Printf.sprintf "let %s = 0x%x" (String.lowercase_ascii name) v - | _ -> assert false - ) - in - let defs = present_defs @ missing_defs in - C.Flags.write_lines "config.ml" defs - ) +module C = Configurator.V1 + +let optional_flags = [ + "O_DSYNC"; + "O_RESOLVE_BENEATH"; + "O_PATH"; +] + +let () = + C.main ~name:"discover" (fun c -> + let c_flags = ["-D_LARGEFILE64_SOURCE"; "-D_XOPEN_SOURCE=700"; "-D_DARWIN_C_SOURCE"; "-D_GNU_SOURCE"; "-D_BSD_SOURCE"] in + let includes = ["sys/types.h"; "sys/stat.h"; "fcntl.h"] in + let extra_flags, missing_defs = + C.C_define.import c ~c_flags ~includes + C.C_define.Type.(List.map (fun name -> name, Switch) optional_flags) + |> List.partition_map (function + | name, C.C_define.Value.Switch true -> Left (name, C.C_define.Type.Int) + | name, Switch false -> + Right (Printf.sprintf "let %s = None" (String.lowercase_ascii name)) + | _ -> assert false + ) + in + let present_defs = + C.C_define.import c ~c_flags + ~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"; "limits.h"] + C.C_define.Type.(extra_flags @ [ + "O_RDONLY", Int; + "O_RDWR", Int; + "O_WRONLY", Int; + + "O_APPEND", Int; + "O_CLOEXEC", Int; + "O_CREAT", Int; + "O_DIRECTORY", Int; + "O_EXCL", Int; + "O_NOCTTY", Int; + "O_NOFOLLOW", Int; + "O_NONBLOCK", Int; + "O_SYNC", Int; + "O_TRUNC", Int; + + "AT_FDCWD", Int; + "AT_SYMLINK_NOFOLLOW", Int; + + "IOV_MAX", Int; + ]) + |> List.map (function + | name, C.C_define.Value.Int v when List.mem name optional_flags -> + Printf.sprintf "let %s = Some 0x%x" (String.lowercase_ascii name) v + | name, C.C_define.Value.Int v -> + Printf.sprintf "let %s = 0x%x" (String.lowercase_ascii name) v + | _ -> assert false + ) + in + let defs = present_defs @ missing_defs in + C.Flags.write_lines "config.ml" defs + ) diff --git a/lib_eio_posix/include/dune b/lib_eio_posix/include/dune index db98d61d5..187737d3c 100644 --- a/lib_eio_posix/include/dune +++ b/lib_eio_posix/include/dune @@ -1,4 +1,4 @@ -(executable - (name discover) - (modules discover) - (libraries dune-configurator)) +(executable + (name discover) + (modules discover) + (libraries dune-configurator)) diff --git a/lib_eio_posix/low_level.ml b/lib_eio_posix/low_level.ml index 6026993d1..722665126 100644 --- a/lib_eio_posix/low_level.ml +++ b/lib_eio_posix/low_level.ml @@ -1,586 +1,586 @@ -open Eio.Std - -(* There are some things that should be improved here: - - - Blocking FDs (e.g. stdout) wait for the FD to become ready and then do a blocking operation. - This might not succeed, and will block the whole domain in that case. - Ideally, all blocking operations should happen in a sys-thread instead. - - - Various other operations, such as listing a directory, should also be done in a sys-thread - to avoid high latencies in the main domain. *) - -type ty = Read | Write - -module Fd = Eio_unix.Fd -module Trace = Eio.Private.Trace -module Fiber_context = Eio.Private.Fiber_context - -type dir_fd = - | Fd of Fd.t - | Cwd (* Confined to "." *) - | Fs (* Unconfined "."; also allows absolute paths *) - -let in_worker_thread label = Eio_unix.run_in_systhread ~label - -let await_readable op fd = - Fd.use_exn "await_readable" fd @@ fun fd -> - Sched.enter op @@ fun t k -> - Sched.await_readable t k fd - -let await_writable op fd = - Fd.use_exn "await_writable" fd @@ fun fd -> - Sched.enter op @@ fun t k -> - Sched.await_writable t k fd - -let rec do_nonblocking ty op fn fd = - try fn fd with - | Unix.Unix_error (EINTR, _, _) -> do_nonblocking ty op fn fd (* Just in case *) - | Unix.Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - Sched.enter op (fun t k -> - match ty with - | Read -> Sched.await_readable t k fd - | Write -> Sched.await_writable t k fd - ); - do_nonblocking ty op fn fd - -let do_nonblocking ty op fn fd = - Fiber.yield (); - Trace.with_span op (fun () -> do_nonblocking ty op fn fd) - -let read fd buf start len = - if Fd.is_blocking fd then await_readable "read" fd; - Fd.use_exn "read" fd @@ fun fd -> - do_nonblocking Read "read" (fun fd -> Unix.read fd buf start len) fd - -let write fd buf start len = - if Fd.is_blocking fd then await_writable "write" fd; - Fd.use_exn "write" fd @@ fun fd -> - do_nonblocking Write "write" (fun fd -> Unix.write fd buf start len) fd - -let sleep_until time = - Sched.enter "sleep" @@ fun t k -> - Sched.await_timeout t k time - -let socket ~sw socket_domain socket_type protocol = - Switch.check sw; - let sock_unix = Unix.socket ~cloexec:true socket_domain socket_type protocol in - Unix.set_nonblock sock_unix; - Fd.of_unix ~sw ~blocking:false ~close_unix:true sock_unix - -let connect fd addr = - try - Fd.use_exn "connect" fd (fun fd -> Unix.connect fd addr) - with - | Unix.Unix_error ((EINTR | EAGAIN | EWOULDBLOCK | EINPROGRESS), _, _) -> - await_writable "connect" fd; - match Fd.use_exn "connect" fd Unix.getsockopt_error with - | None -> () - | Some code -> raise (Err.wrap code "connect-in-progress" "") - -let accept ~sw sock = - Fd.use_exn "accept" sock @@ fun sock -> - let client, addr = - do_nonblocking Read "accept" (fun fd -> Switch.check sw; Unix.accept ~cloexec:true fd) sock - in - Unix.set_nonblock client; - Fd.of_unix ~sw ~blocking:false ~close_unix:true client, addr - -let shutdown sock cmd = - Fd.use_exn "shutdown" sock (fun fd -> Unix.shutdown fd cmd) - -external eio_send_msg : Unix.file_descr -> int -> Unix.file_descr list -> Unix.sockaddr option -> Cstruct.t array -> int = "caml_eio_posix_send_msg" -external eio_recv_msg : Unix.file_descr -> int -> Cstruct.t array -> Unix.sockaddr * int * Unix.file_descr list = "caml_eio_posix_recv_msg" - -let send_msg fd ?(fds = []) ?dst buf = - Fd.use_exn "send_msg" fd @@ fun fd -> - Fd.use_exn_list "send_msg" fds @@ fun fds -> - do_nonblocking Write "send_msg" (fun fd -> eio_send_msg fd (List.length fds) fds dst buf) fd - -let recv_msg fd buf = - let addr, got, _ = - Fd.use_exn "recv_msg" fd @@ fun fd -> - do_nonblocking Read "recv_msg" (fun fd -> eio_recv_msg fd 0 buf) fd - in - (addr, got) - -let recv_msg_with_fds ~sw ~max_fds fd buf = - let addr, got, fds = - Fd.use_exn "recv_msg" fd @@ fun fd -> - do_nonblocking Read "recv_msg" (fun fd -> eio_recv_msg fd max_fds buf) fd - in - (addr, got, Eio_unix.Fd.of_unix_list ~sw fds) - -external eio_getrandom : Cstruct.buffer -> int -> int -> int = "caml_eio_posix_getrandom" - -let getrandom { Cstruct.buffer; off; len } = - let rec loop n = - if n = len then - () - else - loop (n + eio_getrandom buffer (off + n) (len - n)) - in - in_worker_thread "getrandom" @@ fun () -> - loop 0 - -let realpath path = - in_worker_thread "realpath" @@ fun () -> - Unix.realpath path - -let read_entries h = - let rec aux acc = - match Unix.readdir h with - | "." | ".." -> aux acc - | leaf -> aux (leaf :: acc) - | exception End_of_file -> Array.of_list acc - in - aux [] - -external eio_readv : Unix.file_descr -> Cstruct.t array -> int = "caml_eio_posix_readv" -external eio_writev : Unix.file_descr -> Cstruct.t array -> int = "caml_eio_posix_writev" - -external eio_preadv : Unix.file_descr -> Cstruct.t array -> Optint.Int63.t -> int = "caml_eio_posix_preadv" -external eio_pwritev : Unix.file_descr -> Cstruct.t array -> Optint.Int63.t -> int = "caml_eio_posix_pwritev" - -let readv fd bufs = - if Fd.is_blocking fd then await_readable "readv" fd; - Fd.use_exn "readv" fd @@ fun fd -> - do_nonblocking Read "readv" (fun fd -> eio_readv fd bufs) fd - -let writev fd bufs = - if Fd.is_blocking fd then await_writable "writev" fd; - Fd.use_exn "writev" fd @@ fun fd -> - do_nonblocking Write "writev" (fun fd -> eio_writev fd bufs) fd - -let preadv ~file_offset fd bufs = - if Fd.is_blocking fd then await_readable "preadv" fd; - Fd.use_exn "preadv" fd @@ fun fd -> - do_nonblocking Read "preadv" (fun fd -> eio_preadv fd bufs file_offset) fd - -let pwritev ~file_offset fd bufs = - if Fd.is_blocking fd then await_writable "pwritev" fd; - Fd.use_exn "pwritev" fd @@ fun fd -> - do_nonblocking Write "pwritev" (fun fd -> eio_pwritev fd bufs file_offset) fd - -module Open_flags = struct - type t = int - - let rdonly = Config.o_rdonly - let rdwr = Config.o_rdwr - let wronly = Config.o_wronly - let append = Config.o_append - let cloexec = Config.o_cloexec - let creat = Config.o_creat - let directory = Config.o_directory - let dsync = Config.o_dsync - let excl = Config.o_excl - let noctty = Config.o_noctty - let nofollow = Config.o_nofollow - let nonblock = Config.o_nonblock - let sync = Config.o_sync - let trunc = Config.o_trunc - let resolve_beneath = Config.o_resolve_beneath - let path = Config.o_path - - let empty = 0 - let ( + ) = ( lor ) - - let ( +? ) x = function - | None -> x - | Some y -> x + y -end - -let at_fdcwd : Unix.file_descr = Obj.magic Config.at_fdcwd - -external eio_openat : Unix.file_descr -> string -> Open_flags.t -> int -> Unix.file_descr = "caml_eio_posix_openat" -let eio_openat fd path flags mode = - let fd = Option.value fd ~default:at_fdcwd in - eio_openat fd path Open_flags.(flags + cloexec) mode - -module Resolve = struct - (** Resolve a path one step at a time. - This simulates how the kernel does path resolution using O_RESOLVE_BENEATH, - for kernels that don't support it. - - These functions should be called from a worker sys-thread, since lookups can - be slow, especially on network file-systems and user-space mounts. - - When doing lookups, we cannot ask the kernel to follow ".." links, since the - directory might get moved during the operation. e.g. - - Process 1: openat [/tmp/sandbox/] "foo/../bar" - Process 2: mv /tmp/sandbox/foo /var/foo - - Process 1 starts by opening "foo", then process 2 moves it, then process 1 - follows the "../bar", opening /var/bar, to which it should not have access. - Instead, we keep a stack of opened directories and pop one when we see "..". - todo: possibly we should check we have search permission on ".." before - doing this. - *) - - type dir_stack = - | Base of Unix.file_descr option (* Base dir from user (do not close). None if cwd *) - | Tmp of Unix.file_descr * dir_stack (* Will be closed if in [dir_stack] at end. *) - - type state = { - mutable dir_stack : dir_stack; (* Directories already opened, for ".." *) - mutable max_follows : int; (* Max symlinks before reporting ELOOP *) - } - - let current_dir state = - match state.dir_stack with - | Base b -> b - | Tmp (x, _) -> Some x - - let parse_rel s = - match Path.parse s with - | Relative r -> r - | Absolute _ -> raise @@ Eio.Fs.err (Eio.Fs.Permission_denied (Err.Absolute_path)) - - let decr_max_follows state x = - if state.max_follows > 0 then - state.max_follows <- state.max_follows - 1 - else - raise (Unix.Unix_error (ELOOP, "resolve", x)) - - (* Fallback for systems without O_RESOLVE_BENEATH: *) - let rec resolve state (path : Path.Rel.t) = - (* traceln "Consider %a" Path.Rel.dump path; *) - match path with - | Leaf { basename; trailing_slash } -> if trailing_slash then basename ^ "/" else basename - | Self -> "." - | Parent xs -> - begin match state.dir_stack with - | Base _ -> - raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (Path.Rel.to_string path))) - | Tmp (p, ps) -> - Unix.close p; - state.dir_stack <- ps; - resolve state xs - end - | Child (x, xs) -> - let base = current_dir state in - match eio_openat base x Open_flags.(nofollow + directory +? path) 0 with - | new_base -> - state.dir_stack <- Tmp (new_base, state.dir_stack); - resolve state xs - | exception (Unix.Unix_error ((ELOOP | ENOTDIR | EMLINK | EUNKNOWNERR _), _, _) as e) -> - (* Note: Linux uses ELOOP or ENOTDIR. FreeBSD uses EMLINK. NetBSD uses EFTYPE. *) - match Eio_unix.Private.read_link_unix base x with - | target -> - decr_max_follows state x; - resolve state (Path.Rel.concat (parse_rel target) xs) - | exception Unix.Unix_error _ -> raise e (* Not a symlink; report original error instead *) - - let close_tmp state = - let rec aux = function - | Base _ -> () - | Tmp (x, xs) -> Unix.close x; aux xs - in - aux state.dir_stack - - let with_state base fn = - (* [max_follows] matches Linux's value; see path_resolution(7) *) - let state = { dir_stack = Base base; max_follows = 40 } in - match fn state with - | x -> close_tmp state; x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - close_tmp state; - Printexc.raise_with_backtrace ex bt - - let trailing_slash x = - x <> "" && x.[String.length x - 1] = '/' - - let open_beneath_fallback ?dirfd:base ~sw ~mode path flags = - let path = parse_rel path in - with_state base @@ fun state -> - (* Resolve the parent, then try to open the last component with [flags + nofollow]. - If it's a symlink, retry with the target. *) - let rec aux leaf = - let base = current_dir state in - let flags = if trailing_slash leaf then Open_flags.(flags + directory) else flags in - match eio_openat base leaf Open_flags.(flags + nofollow) mode with - | fd -> Fd.of_unix fd ~sw ~blocking:false ~close_unix:true - | exception (Unix.Unix_error ((ELOOP | ENOTDIR | EMLINK | EUNKNOWNERR _), _, _) as e) -> - (* Note: Linux uses ELOOP or ENOTDIR. FreeBSD uses EMLINK. NetBSD uses EFTYPE. *) - match Eio_unix.Private.read_link_unix base leaf with - | target -> - decr_max_follows state leaf; - aux (resolve state (parse_rel target)) - | exception Unix.Unix_error _ -> raise e - in - aux (resolve state path) - - (* Resolve until the last component and call [fn dir leaf]. - That returns [Error `Symlink] if [leaf] is a symlink, in - which case we read its target and continue. *) - let with_parent_loop ?dirfd:base path fn = - let path = parse_rel path in - with_state base @@ fun state -> - let rec aux leaf = - let base = current_dir state in - match fn base leaf with - | Ok x -> x - | Error (`Symlink e) -> - decr_max_follows state leaf; - match Eio_unix.Private.read_link_unix base leaf with - | target -> aux (resolve state (parse_rel target)) - | exception Unix.Unix_error _ when Option.is_some e -> raise (Option.get e) - in - aux (resolve state path) - - (* If confined, resolve until the last component and call [fn dir leaf]. - If unconfined, just call [fn None path]. - If you need to follow [leaf] if it turns out to be a symlink, - use [with_parent_loop] instead. *) - let with_parent op fd path fn = (* todo: use o_resolve_beneath if available *) - match fd with - | Fs -> fn None path - | Cwd -> with_parent_loop path (fun x y -> Ok (fn x y)) - | Fd dirfd -> - Fd.use_exn op dirfd @@ fun dirfd -> - with_parent_loop ~dirfd path (fun x y -> Ok (fn x y)) - - let open_unconfined ~sw ~mode dirfd path flags = - let flags = if trailing_slash path then Open_flags.(flags + directory) else flags in - Fd.use_exn_opt "openat" dirfd @@ fun dirfd -> - eio_openat dirfd path Open_flags.(flags + nonblock) mode - |> Fd.of_unix ~sw ~blocking:false ~close_unix:true - - let open_beneath ?dirfd ~sw ~mode path flags = - match Open_flags.resolve_beneath with - | Some o_resolve_beneath -> - open_unconfined ~sw ~mode dirfd path Open_flags.(flags + o_resolve_beneath) - | None -> - Fd.use_exn_opt "open_beneath" dirfd @@ fun dirfd -> - open_beneath_fallback ?dirfd ~sw ~mode path flags -end - -let openat ~sw ~mode fd path flags = - let path = if path = "" then "." else path in - in_worker_thread "openat" @@ fun () -> - match fd with - | Fs -> Resolve.open_unconfined ~sw ~mode None path flags - | Cwd -> Resolve.open_beneath ~sw ~mode ?dirfd:None path flags - | Fd dirfd -> Resolve.open_beneath ~sw ~mode ~dirfd path flags - -external eio_fdopendir : Unix.file_descr -> Unix.dir_handle = "caml_eio_posix_fdopendir" - -let readdir dirfd path = - in_worker_thread "readdir" @@ fun () -> - let use h = - match read_entries h with - | r -> Unix.closedir h; r - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - Unix.closedir h; - Printexc.raise_with_backtrace ex bt - in - let use_confined dirfd = - Resolve.with_parent_loop ?dirfd path @@ fun dirfd path -> - match eio_openat dirfd path Open_flags.(rdonly + directory + nofollow) 0 with - | fd -> Ok (use (eio_fdopendir fd)) - | exception (Unix.Unix_error ((ELOOP | ENOTDIR | EMLINK | EUNKNOWNERR _), _, _) as e) -> Error (`Symlink (Some e)) - in - match dirfd with - | Fs -> use (Unix.opendir path) - | Cwd -> use_confined None - | Fd dirfd -> - Fd.use_exn "readdir" dirfd @@ fun dirfd -> - use_confined (Some dirfd) - -external eio_mkdirat : Unix.file_descr -> string -> Unix.file_perm -> unit = "caml_eio_posix_mkdirat" - -let mkdir ~mode dirfd path = - in_worker_thread "mkdir" @@ fun () -> - Resolve.with_parent "mkdir" dirfd path @@ fun dirfd path -> - let dirfd = Option.value dirfd ~default:at_fdcwd in - eio_mkdirat dirfd path mode - -external eio_unlinkat : Unix.file_descr -> string -> bool -> unit = "caml_eio_posix_unlinkat" - -let unlink ~dir dirfd path = - in_worker_thread "unlink" @@ fun () -> - Resolve.with_parent "unlink" dirfd path @@ fun dirfd path -> - let dirfd = Option.value dirfd ~default:at_fdcwd in - eio_unlinkat dirfd path dir - -external eio_renameat : Unix.file_descr -> string -> Unix.file_descr -> string -> unit = "caml_eio_posix_renameat" - -let rename old_dir old_path new_dir new_path = - in_worker_thread "rename" @@ fun () -> - Resolve.with_parent "rename-old" old_dir old_path @@ fun old_dir old_path -> - Resolve.with_parent "rename-new" new_dir new_path @@ fun new_dir new_path -> - let old_dir = Option.value old_dir ~default:at_fdcwd in - let new_dir = Option.value new_dir ~default:at_fdcwd in - eio_renameat old_dir old_path new_dir new_path - -external eio_symlinkat : string -> Unix.file_descr -> string -> unit = "caml_eio_posix_symlinkat" - -let symlink ~link_to new_dir new_path = - in_worker_thread "symlink" @@ fun () -> - Resolve.with_parent "symlink-new" new_dir new_path @@ fun new_dir new_path -> - let new_dir = Option.value new_dir ~default:at_fdcwd in - eio_symlinkat link_to new_dir new_path - -let read_link dirfd path = - in_worker_thread "read_link" @@ fun () -> - Resolve.with_parent "read_link" dirfd path @@ fun dirfd path -> - Eio_unix.Private.read_link_unix dirfd path - -type stat -external create_stat : unit -> stat = "caml_eio_posix_make_stat" -external eio_fstatat : stat -> Unix.file_descr -> string -> int -> unit = "caml_eio_posix_fstatat" -external eio_fstat : stat -> Unix.file_descr -> unit = "caml_eio_posix_fstat" - -external blksize : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_blksize_bytes" "ocaml_eio_posix_stat_blksize_native" [@@noalloc] -external nlink : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_nlink_bytes" "ocaml_eio_posix_stat_nlink_native" [@@noalloc] -external uid : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_uid_bytes" "ocaml_eio_posix_stat_uid_native" [@@noalloc] -external gid : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_gid_bytes" "ocaml_eio_posix_stat_gid_native" [@@noalloc] -external ino : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_ino_bytes" "ocaml_eio_posix_stat_ino_native" [@@noalloc] -external size : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_size_bytes" "ocaml_eio_posix_stat_size_native" [@@noalloc] -external rdev : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_rdev_bytes" "ocaml_eio_posix_stat_rdev_native" [@@noalloc] -external dev : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_dev_bytes" "ocaml_eio_posix_stat_dev_native" [@@noalloc] -external perm : stat -> (int [@untagged]) = "ocaml_eio_posix_stat_perm_bytes" "ocaml_eio_posix_stat_perm_native" [@@noalloc] -external mode : stat -> (int [@untagged]) = "ocaml_eio_posix_stat_mode_bytes" "ocaml_eio_posix_stat_mode_native" [@@noalloc] -external kind : stat -> Eio.File.Stat.kind = "ocaml_eio_posix_stat_kind" - -external atime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_atime_sec_bytes" "ocaml_eio_posix_stat_atime_sec_native" [@@noalloc] -external ctime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_ctime_sec_bytes" "ocaml_eio_posix_stat_ctime_sec_native" [@@noalloc] -external mtime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_mtime_sec_bytes" "ocaml_eio_posix_stat_mtime_sec_native" [@@noalloc] - -external atime_nsec : stat -> int = "ocaml_eio_posix_stat_atime_nsec" [@@noalloc] -external ctime_nsec : stat -> int = "ocaml_eio_posix_stat_ctime_nsec" [@@noalloc] -external mtime_nsec : stat -> int = "ocaml_eio_posix_stat_mtime_nsec" [@@noalloc] - -let fstat ~buf fd = - Fd.use_exn "fstat" fd @@ fun fd -> - eio_fstat buf fd - -let fstatat_confined ~buf ~follow dirfd path = - Resolve.with_parent_loop ?dirfd path @@ fun dirfd path -> - let dirfd = Option.value dirfd ~default:at_fdcwd in - eio_fstatat buf dirfd path Config.at_symlink_nofollow; - if follow && kind buf = `Symbolic_link then Error (`Symlink None) else Ok () - -let fstatat ~buf ~follow dirfd path = - in_worker_thread "fstat" @@ fun () -> - match dirfd with - | Fs -> - let flags = if follow then 0 else Config.at_symlink_nofollow in - eio_fstatat buf at_fdcwd path flags - | Cwd -> fstatat_confined ~buf ~follow None path - | Fd dirfd -> - Fd.use_exn "fstat" dirfd @@ fun dirfd -> - fstatat_confined ~buf ~follow (Some dirfd) path - -let lseek fd off cmd = - Fd.use_exn "lseek" fd @@ fun fd -> - let cmd = - match cmd with - | `Set -> Unix.SEEK_SET - | `Cur -> Unix.SEEK_CUR - | `End -> Unix.SEEK_END - in - Unix.LargeFile.lseek fd (Optint.Int63.to_int64 off) cmd - |> Optint.Int63.of_int64 - -let fsync fd = - Eio_unix.run_in_systhread ~label:"fsync" @@ fun () -> - Fd.use_exn "fsync" fd Unix.fsync - -let ftruncate fd len = - Eio_unix.run_in_systhread ~label:"ftruncate" @@ fun () -> - Fd.use_exn "ftruncate" fd @@ fun fd -> - Unix.LargeFile.ftruncate fd (Optint.Int63.to_int64 len) - -let pipe ~sw = - let unix_r, unix_w = Unix.pipe ~cloexec:true () in - let r = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_r in - let w = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_w in - Unix.set_nonblock unix_r; - Unix.set_nonblock unix_w; - r, w - -module Process = struct - type t = { - pid : int; - exit_status : Unix.process_status Promise.t; - lock : Mutex.t; - } - (* When [lock] is unlocked, [exit_status] is resolved iff the process has been reaped. *) - - let exit_status t = t.exit_status - let pid t = t.pid - - module Fork_action = Eio_unix.Private.Fork_action - - (* Read a (typically short) error message from a child process. *) - let rec read_response fd = - let buf = Bytes.create 256 in - match read fd buf 0 (Bytes.length buf) with - | 0 -> "" - | n -> Bytes.sub_string buf 0 n ^ read_response fd - - let with_pipe fn = - Switch.run @@ fun sw -> - let r, w = pipe ~sw in - fn r w - - let signal t signal = - (* We need the lock here so that one domain can't signal the process exactly as another is reaping it. *) - Mutex.lock t.lock; - Fun.protect ~finally:(fun () -> Mutex.unlock t.lock) @@ fun () -> - if not (Promise.is_resolved t.exit_status) then ( - Unix.kill t.pid signal - ) (* else process has been reaped and t.pid is invalid *) - - external eio_spawn : Unix.file_descr -> Eio_unix.Private.Fork_action.c_action list -> int = "caml_eio_posix_spawn" - - (* Wait for [pid] to exit and then resolve [exit_status] to its status. *) - let reap t exit_status = - Eio.Condition.loop_no_mutex Eio_unix.Process.sigchld (fun () -> - Mutex.lock t.lock; - match Unix.waitpid [WNOHANG] t.pid with - | 0, _ -> Mutex.unlock t.lock; None (* Not ready; wait for next SIGCHLD *) - | p, status -> - assert (p = t.pid); - Promise.resolve exit_status status; - Mutex.unlock t.lock; - Some () - ) - - let spawn ~sw actions = - with_pipe @@ fun errors_r errors_w -> - Eio_unix.Private.Fork_action.with_actions actions @@ fun c_actions -> - Switch.check sw; - let exit_status, set_exit_status = Promise.create () in - let t = - let pid = - Fd.use_exn "errors-w" errors_w @@ fun errors_w -> - Eio.Private.Trace.with_span "spawn" @@ fun () -> - eio_spawn errors_w c_actions - in - Fd.close errors_w; - { pid; exit_status; lock = Mutex.create () } - in - let hook = Switch.on_release_cancellable sw (fun () -> - (* Kill process (if still running) *) - signal t Sys.sigkill; - (* The switch is being released, so either the daemon fiber got - cancelled or it hasn't started yet (and never will start). *) - if not (Promise.is_resolved t.exit_status) then ( - (* Do a (non-cancellable) waitpid here to reap the child. *) - reap t set_exit_status - ) - ) in - Fiber.fork_daemon ~sw (fun () -> - reap t set_exit_status; - Switch.remove_hook hook; - `Stop_daemon - ); - (* Check for errors starting the process. *) - match read_response errors_r with - | "" -> t (* Success! Execing the child closed [errors_w] and we got EOF. *) - | err -> failwith err -end +open Eio.Std + +(* There are some things that should be improved here: + + - Blocking FDs (e.g. stdout) wait for the FD to become ready and then do a blocking operation. + This might not succeed, and will block the whole domain in that case. + Ideally, all blocking operations should happen in a sys-thread instead. + + - Various other operations, such as listing a directory, should also be done in a sys-thread + to avoid high latencies in the main domain. *) + +type ty = Read | Write + +module Fd = Eio_unix.Fd +module Trace = Eio.Private.Trace +module Fiber_context = Eio.Private.Fiber_context + +type dir_fd = + | Fd of Fd.t + | Cwd (* Confined to "." *) + | Fs (* Unconfined "."; also allows absolute paths *) + +let in_worker_thread label = Eio_unix.run_in_systhread ~label + +let await_readable op fd = + Fd.use_exn "await_readable" fd @@ fun fd -> + Sched.enter op @@ fun t k -> + Sched.await_readable t k fd + +let await_writable op fd = + Fd.use_exn "await_writable" fd @@ fun fd -> + Sched.enter op @@ fun t k -> + Sched.await_writable t k fd + +let rec do_nonblocking ty op fn fd = + try fn fd with + | Unix.Unix_error (EINTR, _, _) -> do_nonblocking ty op fn fd (* Just in case *) + | Unix.Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> + Sched.enter op (fun t k -> + match ty with + | Read -> Sched.await_readable t k fd + | Write -> Sched.await_writable t k fd + ); + do_nonblocking ty op fn fd + +let do_nonblocking ty op fn fd = + Fiber.yield (); + Trace.with_span op (fun () -> do_nonblocking ty op fn fd) + +let read fd buf start len = + if Fd.is_blocking fd then await_readable "read" fd; + Fd.use_exn "read" fd @@ fun fd -> + do_nonblocking Read "read" (fun fd -> Unix.read fd buf start len) fd + +let write fd buf start len = + if Fd.is_blocking fd then await_writable "write" fd; + Fd.use_exn "write" fd @@ fun fd -> + do_nonblocking Write "write" (fun fd -> Unix.write fd buf start len) fd + +let sleep_until time = + Sched.enter "sleep" @@ fun t k -> + Sched.await_timeout t k time + +let socket ~sw socket_domain socket_type protocol = + Switch.check sw; + let sock_unix = Unix.socket ~cloexec:true socket_domain socket_type protocol in + Unix.set_nonblock sock_unix; + Fd.of_unix ~sw ~blocking:false ~close_unix:true sock_unix + +let connect fd addr = + try + Fd.use_exn "connect" fd (fun fd -> Unix.connect fd addr) + with + | Unix.Unix_error ((EINTR | EAGAIN | EWOULDBLOCK | EINPROGRESS), _, _) -> + await_writable "connect" fd; + match Fd.use_exn "connect" fd Unix.getsockopt_error with + | None -> () + | Some code -> raise (Err.wrap code "connect-in-progress" "") + +let accept ~sw sock = + Fd.use_exn "accept" sock @@ fun sock -> + let client, addr = + do_nonblocking Read "accept" (fun fd -> Switch.check sw; Unix.accept ~cloexec:true fd) sock + in + Unix.set_nonblock client; + Fd.of_unix ~sw ~blocking:false ~close_unix:true client, addr + +let shutdown sock cmd = + Fd.use_exn "shutdown" sock (fun fd -> Unix.shutdown fd cmd) + +external eio_send_msg : Unix.file_descr -> int -> Unix.file_descr list -> Unix.sockaddr option -> Cstruct.t array -> int = "caml_eio_posix_send_msg" +external eio_recv_msg : Unix.file_descr -> int -> Cstruct.t array -> Unix.sockaddr * int * Unix.file_descr list = "caml_eio_posix_recv_msg" + +let send_msg fd ?(fds = []) ?dst buf = + Fd.use_exn "send_msg" fd @@ fun fd -> + Fd.use_exn_list "send_msg" fds @@ fun fds -> + do_nonblocking Write "send_msg" (fun fd -> eio_send_msg fd (List.length fds) fds dst buf) fd + +let recv_msg fd buf = + let addr, got, _ = + Fd.use_exn "recv_msg" fd @@ fun fd -> + do_nonblocking Read "recv_msg" (fun fd -> eio_recv_msg fd 0 buf) fd + in + (addr, got) + +let recv_msg_with_fds ~sw ~max_fds fd buf = + let addr, got, fds = + Fd.use_exn "recv_msg" fd @@ fun fd -> + do_nonblocking Read "recv_msg" (fun fd -> eio_recv_msg fd max_fds buf) fd + in + (addr, got, Eio_unix.Fd.of_unix_list ~sw fds) + +external eio_getrandom : Cstruct.buffer -> int -> int -> int = "caml_eio_posix_getrandom" + +let getrandom { Cstruct.buffer; off; len } = + let rec loop n = + if n = len then + () + else + loop (n + eio_getrandom buffer (off + n) (len - n)) + in + in_worker_thread "getrandom" @@ fun () -> + loop 0 + +let realpath path = + in_worker_thread "realpath" @@ fun () -> + Unix.realpath path + +let read_entries h = + let rec aux acc = + match Unix.readdir h with + | "." | ".." -> aux acc + | leaf -> aux (leaf :: acc) + | exception End_of_file -> Array.of_list acc + in + aux [] + +external eio_readv : Unix.file_descr -> Cstruct.t array -> int = "caml_eio_posix_readv" +external eio_writev : Unix.file_descr -> Cstruct.t array -> int = "caml_eio_posix_writev" + +external eio_preadv : Unix.file_descr -> Cstruct.t array -> Optint.Int63.t -> int = "caml_eio_posix_preadv" +external eio_pwritev : Unix.file_descr -> Cstruct.t array -> Optint.Int63.t -> int = "caml_eio_posix_pwritev" + +let readv fd bufs = + if Fd.is_blocking fd then await_readable "readv" fd; + Fd.use_exn "readv" fd @@ fun fd -> + do_nonblocking Read "readv" (fun fd -> eio_readv fd bufs) fd + +let writev fd bufs = + if Fd.is_blocking fd then await_writable "writev" fd; + Fd.use_exn "writev" fd @@ fun fd -> + do_nonblocking Write "writev" (fun fd -> eio_writev fd bufs) fd + +let preadv ~file_offset fd bufs = + if Fd.is_blocking fd then await_readable "preadv" fd; + Fd.use_exn "preadv" fd @@ fun fd -> + do_nonblocking Read "preadv" (fun fd -> eio_preadv fd bufs file_offset) fd + +let pwritev ~file_offset fd bufs = + if Fd.is_blocking fd then await_writable "pwritev" fd; + Fd.use_exn "pwritev" fd @@ fun fd -> + do_nonblocking Write "pwritev" (fun fd -> eio_pwritev fd bufs file_offset) fd + +module Open_flags = struct + type t = int + + let rdonly = Config.o_rdonly + let rdwr = Config.o_rdwr + let wronly = Config.o_wronly + let append = Config.o_append + let cloexec = Config.o_cloexec + let creat = Config.o_creat + let directory = Config.o_directory + let dsync = Config.o_dsync + let excl = Config.o_excl + let noctty = Config.o_noctty + let nofollow = Config.o_nofollow + let nonblock = Config.o_nonblock + let sync = Config.o_sync + let trunc = Config.o_trunc + let resolve_beneath = Config.o_resolve_beneath + let path = Config.o_path + + let empty = 0 + let ( + ) = ( lor ) + + let ( +? ) x = function + | None -> x + | Some y -> x + y +end + +let at_fdcwd : Unix.file_descr = Obj.magic Config.at_fdcwd + +external eio_openat : Unix.file_descr -> string -> Open_flags.t -> int -> Unix.file_descr = "caml_eio_posix_openat" +let eio_openat fd path flags mode = + let fd = Option.value fd ~default:at_fdcwd in + eio_openat fd path Open_flags.(flags + cloexec) mode + +module Resolve = struct + (** Resolve a path one step at a time. + This simulates how the kernel does path resolution using O_RESOLVE_BENEATH, + for kernels that don't support it. + + These functions should be called from a worker sys-thread, since lookups can + be slow, especially on network file-systems and user-space mounts. + + When doing lookups, we cannot ask the kernel to follow ".." links, since the + directory might get moved during the operation. e.g. + + Process 1: openat [/tmp/sandbox/] "foo/../bar" + Process 2: mv /tmp/sandbox/foo /var/foo + + Process 1 starts by opening "foo", then process 2 moves it, then process 1 + follows the "../bar", opening /var/bar, to which it should not have access. + Instead, we keep a stack of opened directories and pop one when we see "..". + todo: possibly we should check we have search permission on ".." before + doing this. + *) + + type dir_stack = + | Base of Unix.file_descr option (* Base dir from user (do not close). None if cwd *) + | Tmp of Unix.file_descr * dir_stack (* Will be closed if in [dir_stack] at end. *) + + type state = { + mutable dir_stack : dir_stack; (* Directories already opened, for ".." *) + mutable max_follows : int; (* Max symlinks before reporting ELOOP *) + } + + let current_dir state = + match state.dir_stack with + | Base b -> b + | Tmp (x, _) -> Some x + + let parse_rel s = + match Path.parse s with + | Relative r -> r + | Absolute _ -> raise @@ Eio.Fs.err (Eio.Fs.Permission_denied (Err.Absolute_path)) + + let decr_max_follows state x = + if state.max_follows > 0 then + state.max_follows <- state.max_follows - 1 + else + raise (Unix.Unix_error (ELOOP, "resolve", x)) + + (* Fallback for systems without O_RESOLVE_BENEATH: *) + let rec resolve state (path : Path.Rel.t) = + (* traceln "Consider %a" Path.Rel.dump path; *) + match path with + | Leaf { basename; trailing_slash } -> if trailing_slash then basename ^ "/" else basename + | Self -> "." + | Parent xs -> + begin match state.dir_stack with + | Base _ -> + raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (Path.Rel.to_string path))) + | Tmp (p, ps) -> + Unix.close p; + state.dir_stack <- ps; + resolve state xs + end + | Child (x, xs) -> + let base = current_dir state in + match eio_openat base x Open_flags.(nofollow + directory +? path) 0 with + | new_base -> + state.dir_stack <- Tmp (new_base, state.dir_stack); + resolve state xs + | exception (Unix.Unix_error ((ELOOP | ENOTDIR | EMLINK | EUNKNOWNERR _), _, _) as e) -> + (* Note: Linux uses ELOOP or ENOTDIR. FreeBSD uses EMLINK. NetBSD uses EFTYPE. *) + match Eio_unix.Private.read_link_unix base x with + | target -> + decr_max_follows state x; + resolve state (Path.Rel.concat (parse_rel target) xs) + | exception Unix.Unix_error _ -> raise e (* Not a symlink; report original error instead *) + + let close_tmp state = + let rec aux = function + | Base _ -> () + | Tmp (x, xs) -> Unix.close x; aux xs + in + aux state.dir_stack + + let with_state base fn = + (* [max_follows] matches Linux's value; see path_resolution(7) *) + let state = { dir_stack = Base base; max_follows = 40 } in + match fn state with + | x -> close_tmp state; x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + close_tmp state; + Printexc.raise_with_backtrace ex bt + + let trailing_slash x = + x <> "" && x.[String.length x - 1] = '/' + + let open_beneath_fallback ?dirfd:base ~sw ~mode path flags = + let path = parse_rel path in + with_state base @@ fun state -> + (* Resolve the parent, then try to open the last component with [flags + nofollow]. + If it's a symlink, retry with the target. *) + let rec aux leaf = + let base = current_dir state in + let flags = if trailing_slash leaf then Open_flags.(flags + directory) else flags in + match eio_openat base leaf Open_flags.(flags + nofollow) mode with + | fd -> Fd.of_unix fd ~sw ~blocking:false ~close_unix:true + | exception (Unix.Unix_error ((ELOOP | ENOTDIR | EMLINK | EUNKNOWNERR _), _, _) as e) -> + (* Note: Linux uses ELOOP or ENOTDIR. FreeBSD uses EMLINK. NetBSD uses EFTYPE. *) + match Eio_unix.Private.read_link_unix base leaf with + | target -> + decr_max_follows state leaf; + aux (resolve state (parse_rel target)) + | exception Unix.Unix_error _ -> raise e + in + aux (resolve state path) + + (* Resolve until the last component and call [fn dir leaf]. + That returns [Error `Symlink] if [leaf] is a symlink, in + which case we read its target and continue. *) + let with_parent_loop ?dirfd:base path fn = + let path = parse_rel path in + with_state base @@ fun state -> + let rec aux leaf = + let base = current_dir state in + match fn base leaf with + | Ok x -> x + | Error (`Symlink e) -> + decr_max_follows state leaf; + match Eio_unix.Private.read_link_unix base leaf with + | target -> aux (resolve state (parse_rel target)) + | exception Unix.Unix_error _ when Option.is_some e -> raise (Option.get e) + in + aux (resolve state path) + + (* If confined, resolve until the last component and call [fn dir leaf]. + If unconfined, just call [fn None path]. + If you need to follow [leaf] if it turns out to be a symlink, + use [with_parent_loop] instead. *) + let with_parent op fd path fn = (* todo: use o_resolve_beneath if available *) + match fd with + | Fs -> fn None path + | Cwd -> with_parent_loop path (fun x y -> Ok (fn x y)) + | Fd dirfd -> + Fd.use_exn op dirfd @@ fun dirfd -> + with_parent_loop ~dirfd path (fun x y -> Ok (fn x y)) + + let open_unconfined ~sw ~mode dirfd path flags = + let flags = if trailing_slash path then Open_flags.(flags + directory) else flags in + Fd.use_exn_opt "openat" dirfd @@ fun dirfd -> + eio_openat dirfd path Open_flags.(flags + nonblock) mode + |> Fd.of_unix ~sw ~blocking:false ~close_unix:true + + let open_beneath ?dirfd ~sw ~mode path flags = + match Open_flags.resolve_beneath with + | Some o_resolve_beneath -> + open_unconfined ~sw ~mode dirfd path Open_flags.(flags + o_resolve_beneath) + | None -> + Fd.use_exn_opt "open_beneath" dirfd @@ fun dirfd -> + open_beneath_fallback ?dirfd ~sw ~mode path flags +end + +let openat ~sw ~mode fd path flags = + let path = if path = "" then "." else path in + in_worker_thread "openat" @@ fun () -> + match fd with + | Fs -> Resolve.open_unconfined ~sw ~mode None path flags + | Cwd -> Resolve.open_beneath ~sw ~mode ?dirfd:None path flags + | Fd dirfd -> Resolve.open_beneath ~sw ~mode ~dirfd path flags + +external eio_fdopendir : Unix.file_descr -> Unix.dir_handle = "caml_eio_posix_fdopendir" + +let readdir dirfd path = + in_worker_thread "readdir" @@ fun () -> + let use h = + match read_entries h with + | r -> Unix.closedir h; r + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + Unix.closedir h; + Printexc.raise_with_backtrace ex bt + in + let use_confined dirfd = + Resolve.with_parent_loop ?dirfd path @@ fun dirfd path -> + match eio_openat dirfd path Open_flags.(rdonly + directory + nofollow) 0 with + | fd -> Ok (use (eio_fdopendir fd)) + | exception (Unix.Unix_error ((ELOOP | ENOTDIR | EMLINK | EUNKNOWNERR _), _, _) as e) -> Error (`Symlink (Some e)) + in + match dirfd with + | Fs -> use (Unix.opendir path) + | Cwd -> use_confined None + | Fd dirfd -> + Fd.use_exn "readdir" dirfd @@ fun dirfd -> + use_confined (Some dirfd) + +external eio_mkdirat : Unix.file_descr -> string -> Unix.file_perm -> unit = "caml_eio_posix_mkdirat" + +let mkdir ~mode dirfd path = + in_worker_thread "mkdir" @@ fun () -> + Resolve.with_parent "mkdir" dirfd path @@ fun dirfd path -> + let dirfd = Option.value dirfd ~default:at_fdcwd in + eio_mkdirat dirfd path mode + +external eio_unlinkat : Unix.file_descr -> string -> bool -> unit = "caml_eio_posix_unlinkat" + +let unlink ~dir dirfd path = + in_worker_thread "unlink" @@ fun () -> + Resolve.with_parent "unlink" dirfd path @@ fun dirfd path -> + let dirfd = Option.value dirfd ~default:at_fdcwd in + eio_unlinkat dirfd path dir + +external eio_renameat : Unix.file_descr -> string -> Unix.file_descr -> string -> unit = "caml_eio_posix_renameat" + +let rename old_dir old_path new_dir new_path = + in_worker_thread "rename" @@ fun () -> + Resolve.with_parent "rename-old" old_dir old_path @@ fun old_dir old_path -> + Resolve.with_parent "rename-new" new_dir new_path @@ fun new_dir new_path -> + let old_dir = Option.value old_dir ~default:at_fdcwd in + let new_dir = Option.value new_dir ~default:at_fdcwd in + eio_renameat old_dir old_path new_dir new_path + +external eio_symlinkat : string -> Unix.file_descr -> string -> unit = "caml_eio_posix_symlinkat" + +let symlink ~link_to new_dir new_path = + in_worker_thread "symlink" @@ fun () -> + Resolve.with_parent "symlink-new" new_dir new_path @@ fun new_dir new_path -> + let new_dir = Option.value new_dir ~default:at_fdcwd in + eio_symlinkat link_to new_dir new_path + +let read_link dirfd path = + in_worker_thread "read_link" @@ fun () -> + Resolve.with_parent "read_link" dirfd path @@ fun dirfd path -> + Eio_unix.Private.read_link_unix dirfd path + +type stat +external create_stat : unit -> stat = "caml_eio_posix_make_stat" +external eio_fstatat : stat -> Unix.file_descr -> string -> int -> unit = "caml_eio_posix_fstatat" +external eio_fstat : stat -> Unix.file_descr -> unit = "caml_eio_posix_fstat" + +external blksize : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_blksize_bytes" "ocaml_eio_posix_stat_blksize_native" [@@noalloc] +external nlink : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_nlink_bytes" "ocaml_eio_posix_stat_nlink_native" [@@noalloc] +external uid : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_uid_bytes" "ocaml_eio_posix_stat_uid_native" [@@noalloc] +external gid : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_gid_bytes" "ocaml_eio_posix_stat_gid_native" [@@noalloc] +external ino : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_ino_bytes" "ocaml_eio_posix_stat_ino_native" [@@noalloc] +external size : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_size_bytes" "ocaml_eio_posix_stat_size_native" [@@noalloc] +external rdev : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_rdev_bytes" "ocaml_eio_posix_stat_rdev_native" [@@noalloc] +external dev : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_dev_bytes" "ocaml_eio_posix_stat_dev_native" [@@noalloc] +external perm : stat -> (int [@untagged]) = "ocaml_eio_posix_stat_perm_bytes" "ocaml_eio_posix_stat_perm_native" [@@noalloc] +external mode : stat -> (int [@untagged]) = "ocaml_eio_posix_stat_mode_bytes" "ocaml_eio_posix_stat_mode_native" [@@noalloc] +external kind : stat -> Eio.File.Stat.kind = "ocaml_eio_posix_stat_kind" + +external atime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_atime_sec_bytes" "ocaml_eio_posix_stat_atime_sec_native" [@@noalloc] +external ctime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_ctime_sec_bytes" "ocaml_eio_posix_stat_ctime_sec_native" [@@noalloc] +external mtime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_mtime_sec_bytes" "ocaml_eio_posix_stat_mtime_sec_native" [@@noalloc] + +external atime_nsec : stat -> int = "ocaml_eio_posix_stat_atime_nsec" [@@noalloc] +external ctime_nsec : stat -> int = "ocaml_eio_posix_stat_ctime_nsec" [@@noalloc] +external mtime_nsec : stat -> int = "ocaml_eio_posix_stat_mtime_nsec" [@@noalloc] + +let fstat ~buf fd = + Fd.use_exn "fstat" fd @@ fun fd -> + eio_fstat buf fd + +let fstatat_confined ~buf ~follow dirfd path = + Resolve.with_parent_loop ?dirfd path @@ fun dirfd path -> + let dirfd = Option.value dirfd ~default:at_fdcwd in + eio_fstatat buf dirfd path Config.at_symlink_nofollow; + if follow && kind buf = `Symbolic_link then Error (`Symlink None) else Ok () + +let fstatat ~buf ~follow dirfd path = + in_worker_thread "fstat" @@ fun () -> + match dirfd with + | Fs -> + let flags = if follow then 0 else Config.at_symlink_nofollow in + eio_fstatat buf at_fdcwd path flags + | Cwd -> fstatat_confined ~buf ~follow None path + | Fd dirfd -> + Fd.use_exn "fstat" dirfd @@ fun dirfd -> + fstatat_confined ~buf ~follow (Some dirfd) path + +let lseek fd off cmd = + Fd.use_exn "lseek" fd @@ fun fd -> + let cmd = + match cmd with + | `Set -> Unix.SEEK_SET + | `Cur -> Unix.SEEK_CUR + | `End -> Unix.SEEK_END + in + Unix.LargeFile.lseek fd (Optint.Int63.to_int64 off) cmd + |> Optint.Int63.of_int64 + +let fsync fd = + Eio_unix.run_in_systhread ~label:"fsync" @@ fun () -> + Fd.use_exn "fsync" fd Unix.fsync + +let ftruncate fd len = + Eio_unix.run_in_systhread ~label:"ftruncate" @@ fun () -> + Fd.use_exn "ftruncate" fd @@ fun fd -> + Unix.LargeFile.ftruncate fd (Optint.Int63.to_int64 len) + +let pipe ~sw = + let unix_r, unix_w = Unix.pipe ~cloexec:true () in + let r = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_r in + let w = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_w in + Unix.set_nonblock unix_r; + Unix.set_nonblock unix_w; + r, w + +module Process = struct + type t = { + pid : int; + exit_status : Unix.process_status Promise.t; + lock : Mutex.t; + } + (* When [lock] is unlocked, [exit_status] is resolved iff the process has been reaped. *) + + let exit_status t = t.exit_status + let pid t = t.pid + + module Fork_action = Eio_unix.Private.Fork_action + + (* Read a (typically short) error message from a child process. *) + let rec read_response fd = + let buf = Bytes.create 256 in + match read fd buf 0 (Bytes.length buf) with + | 0 -> "" + | n -> Bytes.sub_string buf 0 n ^ read_response fd + + let with_pipe fn = + Switch.run @@ fun sw -> + let r, w = pipe ~sw in + fn r w + + let signal t signal = + (* We need the lock here so that one domain can't signal the process exactly as another is reaping it. *) + Mutex.lock t.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock t.lock) @@ fun () -> + if not (Promise.is_resolved t.exit_status) then ( + Unix.kill t.pid signal + ) (* else process has been reaped and t.pid is invalid *) + + external eio_spawn : Unix.file_descr -> Eio_unix.Private.Fork_action.c_action list -> int = "caml_eio_posix_spawn" + + (* Wait for [pid] to exit and then resolve [exit_status] to its status. *) + let reap t exit_status = + Eio.Condition.loop_no_mutex Eio_unix.Process.sigchld (fun () -> + Mutex.lock t.lock; + match Unix.waitpid [WNOHANG] t.pid with + | 0, _ -> Mutex.unlock t.lock; None (* Not ready; wait for next SIGCHLD *) + | p, status -> + assert (p = t.pid); + Promise.resolve exit_status status; + Mutex.unlock t.lock; + Some () + ) + + let spawn ~sw actions = + with_pipe @@ fun errors_r errors_w -> + Eio_unix.Private.Fork_action.with_actions actions @@ fun c_actions -> + Switch.check sw; + let exit_status, set_exit_status = Promise.create () in + let t = + let pid = + Fd.use_exn "errors-w" errors_w @@ fun errors_w -> + Eio.Private.Trace.with_span "spawn" @@ fun () -> + eio_spawn errors_w c_actions + in + Fd.close errors_w; + { pid; exit_status; lock = Mutex.create () } + in + let hook = Switch.on_release_cancellable sw (fun () -> + (* Kill process (if still running) *) + signal t Sys.sigkill; + (* The switch is being released, so either the daemon fiber got + cancelled or it hasn't started yet (and never will start). *) + if not (Promise.is_resolved t.exit_status) then ( + (* Do a (non-cancellable) waitpid here to reap the child. *) + reap t set_exit_status + ) + ) in + Fiber.fork_daemon ~sw (fun () -> + reap t set_exit_status; + Switch.remove_hook hook; + `Stop_daemon + ); + (* Check for errors starting the process. *) + match read_response errors_r with + | "" -> t (* Success! Execing the child closed [errors_w] and we got EOF. *) + | err -> failwith err +end diff --git a/lib_eio_posix/low_level.mli b/lib_eio_posix/low_level.mli index 69efe7207..a6b2fdcfc 100644 --- a/lib_eio_posix/low_level.mli +++ b/lib_eio_posix/low_level.mli @@ -1,154 +1,154 @@ -(** This module provides an effects-based API for calling POSIX functions. - - Normally it's better to use the cross-platform {!Eio} APIs instead, - which uses these functions automatically where appropriate. - - These functions mostly copy the POSIX APIs directly, except that: - - + They suspend the calling fiber instead of returning [EAGAIN] or similar. - + They handle [EINTR] by automatically restarting the call. - + They wrap {!Unix.file_descr} in {!Fd}, to avoid use-after-close bugs. - + They attach new FDs to switches, to avoid resource leaks. *) - -open Eio.Std - -type fd := Eio_unix.Fd.t - -type dir_fd = - | Fd of fd (** Confined to [fd]. *) - | Cwd (** Confined to "." *) - | Fs (** Unconfined "."; also allows absolute paths *) - -val await_readable : string -> fd -> unit -val await_writable : string -> fd -> unit - -val sleep_until : Mtime.t -> unit - -val read : fd -> bytes -> int -> int -> int -val write : fd -> bytes -> int -> int -> int - -val socket : sw:Switch.t -> Unix.socket_domain -> Unix.socket_type -> int -> fd -val connect : fd -> Unix.sockaddr -> unit -val accept : sw:Switch.t -> fd -> fd * Unix.sockaddr - -val shutdown : fd -> Unix.shutdown_command -> unit - -val recv_msg : fd -> Cstruct.t array -> Unix.sockaddr * int -val recv_msg_with_fds : sw:Switch.t -> max_fds:int -> fd -> Cstruct.t array -> Unix.sockaddr * int * fd list - -val send_msg : fd -> ?fds:fd list -> ?dst:Unix.sockaddr -> Cstruct.t array -> int - -val getrandom : Cstruct.t -> unit - -val lseek : fd -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t -val fsync : fd -> unit -val ftruncate : fd -> Optint.Int63.t -> unit - -type stat - -val create_stat : unit -> stat - -val fstat : buf:stat -> fd -> unit -val fstatat : buf:stat -> follow:bool -> dir_fd -> string -> unit - -external blksize : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_blksize_bytes" "ocaml_eio_posix_stat_blksize_native" [@@noalloc] -external nlink : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_nlink_bytes" "ocaml_eio_posix_stat_nlink_native" [@@noalloc] -external uid : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_uid_bytes" "ocaml_eio_posix_stat_uid_native" [@@noalloc] -external gid : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_gid_bytes" "ocaml_eio_posix_stat_gid_native" [@@noalloc] -external ino : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_ino_bytes" "ocaml_eio_posix_stat_ino_native" [@@noalloc] -external size : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_size_bytes" "ocaml_eio_posix_stat_size_native" [@@noalloc] -external rdev : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_rdev_bytes" "ocaml_eio_posix_stat_rdev_native" [@@noalloc] -external dev : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_dev_bytes" "ocaml_eio_posix_stat_dev_native" [@@noalloc] -external perm : stat -> (int [@untagged]) = "ocaml_eio_posix_stat_perm_bytes" "ocaml_eio_posix_stat_perm_native" [@@noalloc] -external mode : stat -> (int [@untagged]) = "ocaml_eio_posix_stat_mode_bytes" "ocaml_eio_posix_stat_mode_native" [@@noalloc] -external kind : stat -> Eio.File.Stat.kind = "ocaml_eio_posix_stat_kind" - -external atime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_atime_sec_bytes" "ocaml_eio_posix_stat_atime_sec_native" [@@noalloc] -external ctime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_ctime_sec_bytes" "ocaml_eio_posix_stat_ctime_sec_native" [@@noalloc] -external mtime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_mtime_sec_bytes" "ocaml_eio_posix_stat_mtime_sec_native" [@@noalloc] - -external atime_nsec : stat -> int = "ocaml_eio_posix_stat_atime_nsec" [@@noalloc] -external ctime_nsec : stat -> int = "ocaml_eio_posix_stat_ctime_nsec" [@@noalloc] -external mtime_nsec : stat -> int = "ocaml_eio_posix_stat_mtime_nsec" [@@noalloc] - -val realpath : string -> string -val read_link : dir_fd -> string -> string - -val mkdir : mode:int -> dir_fd -> string -> unit -val unlink : dir:bool -> dir_fd -> string -> unit -val rename : dir_fd -> string -> dir_fd -> string -> unit - -val symlink : link_to:string -> dir_fd -> string -> unit -(** [symlink ~link_to dir path] will create a new symlink at [dir / path] - linking to [link_to]. *) - -val readdir : dir_fd -> string -> string array - -val readv : fd -> Cstruct.t array -> int -val writev : fd -> Cstruct.t array -> int - -val preadv : file_offset:Optint.Int63.t -> fd -> Cstruct.t array -> int -val pwritev : file_offset:Optint.Int63.t -> fd -> Cstruct.t array -> int - -val pipe : sw:Switch.t -> fd * fd - -module Open_flags : sig - type t - - val rdonly : t - val rdwr : t - val wronly : t - val append : t - val creat : t - val directory : t - val dsync : t option - val excl : t - val noctty : t - val nofollow : t - val sync : t - val trunc : t - val resolve_beneath : t option - val path : t option - - val empty : t - val ( + ) : t -> t -> t - val ( +? ) : t -> t option -> t (** Add if available *) -end - -val openat : sw:Switch.t -> mode:int -> dir_fd -> string -> Open_flags.t -> fd -(** Note: the returned FD is always non-blocking and close-on-exec. *) - -module Process : sig - type t - (** A child process. *) - - module Fork_action = Eio_unix.Private.Fork_action - (** Setup actions to perform in the child process. *) - - val spawn : sw:Switch.t -> Fork_action.t list -> t - (** [spawn ~sw actions] forks a child process, which executes [actions]. - The last action should be {!Fork_action.execve}. - - You will typically want to do [Promise.await (exit_status child)] after this. - - @param sw The child will be sent {!Sys.sigkill} if [sw] finishes. *) - - val signal : t -> int -> unit - (** [signal t x] sends signal [x] to [t]. - - This is similar to doing [Unix.kill t.pid x], - except that it ensures no signal is sent after [t] has been reaped. *) - - val pid : t -> int - - val exit_status : t -> Unix.process_status Promise.t - (** [exit_status t] is a promise for the process's exit status. *) -end - -(**/**) -(* Exposed for testing only. *) -module Resolve : sig - val open_beneath_fallback : ?dirfd:Unix.file_descr -> sw:Switch.t -> mode:int -> string -> Open_flags.t -> fd - val open_unconfined : sw:Switch.t -> mode:int -> fd option -> string -> Open_flags.t -> fd -end -(**/**) +(** This module provides an effects-based API for calling POSIX functions. + + Normally it's better to use the cross-platform {!Eio} APIs instead, + which uses these functions automatically where appropriate. + + These functions mostly copy the POSIX APIs directly, except that: + + + They suspend the calling fiber instead of returning [EAGAIN] or similar. + + They handle [EINTR] by automatically restarting the call. + + They wrap {!Unix.file_descr} in {!Fd}, to avoid use-after-close bugs. + + They attach new FDs to switches, to avoid resource leaks. *) + +open Eio.Std + +type fd := Eio_unix.Fd.t + +type dir_fd = + | Fd of fd (** Confined to [fd]. *) + | Cwd (** Confined to "." *) + | Fs (** Unconfined "."; also allows absolute paths *) + +val await_readable : string -> fd -> unit +val await_writable : string -> fd -> unit + +val sleep_until : Mtime.t -> unit + +val read : fd -> bytes -> int -> int -> int +val write : fd -> bytes -> int -> int -> int + +val socket : sw:Switch.t -> Unix.socket_domain -> Unix.socket_type -> int -> fd +val connect : fd -> Unix.sockaddr -> unit +val accept : sw:Switch.t -> fd -> fd * Unix.sockaddr + +val shutdown : fd -> Unix.shutdown_command -> unit + +val recv_msg : fd -> Cstruct.t array -> Unix.sockaddr * int +val recv_msg_with_fds : sw:Switch.t -> max_fds:int -> fd -> Cstruct.t array -> Unix.sockaddr * int * fd list + +val send_msg : fd -> ?fds:fd list -> ?dst:Unix.sockaddr -> Cstruct.t array -> int + +val getrandom : Cstruct.t -> unit + +val lseek : fd -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t +val fsync : fd -> unit +val ftruncate : fd -> Optint.Int63.t -> unit + +type stat + +val create_stat : unit -> stat + +val fstat : buf:stat -> fd -> unit +val fstatat : buf:stat -> follow:bool -> dir_fd -> string -> unit + +external blksize : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_blksize_bytes" "ocaml_eio_posix_stat_blksize_native" [@@noalloc] +external nlink : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_nlink_bytes" "ocaml_eio_posix_stat_nlink_native" [@@noalloc] +external uid : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_uid_bytes" "ocaml_eio_posix_stat_uid_native" [@@noalloc] +external gid : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_gid_bytes" "ocaml_eio_posix_stat_gid_native" [@@noalloc] +external ino : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_ino_bytes" "ocaml_eio_posix_stat_ino_native" [@@noalloc] +external size : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_size_bytes" "ocaml_eio_posix_stat_size_native" [@@noalloc] +external rdev : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_rdev_bytes" "ocaml_eio_posix_stat_rdev_native" [@@noalloc] +external dev : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_dev_bytes" "ocaml_eio_posix_stat_dev_native" [@@noalloc] +external perm : stat -> (int [@untagged]) = "ocaml_eio_posix_stat_perm_bytes" "ocaml_eio_posix_stat_perm_native" [@@noalloc] +external mode : stat -> (int [@untagged]) = "ocaml_eio_posix_stat_mode_bytes" "ocaml_eio_posix_stat_mode_native" [@@noalloc] +external kind : stat -> Eio.File.Stat.kind = "ocaml_eio_posix_stat_kind" + +external atime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_atime_sec_bytes" "ocaml_eio_posix_stat_atime_sec_native" [@@noalloc] +external ctime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_ctime_sec_bytes" "ocaml_eio_posix_stat_ctime_sec_native" [@@noalloc] +external mtime_sec : stat -> (int64 [@unboxed]) = "ocaml_eio_posix_stat_mtime_sec_bytes" "ocaml_eio_posix_stat_mtime_sec_native" [@@noalloc] + +external atime_nsec : stat -> int = "ocaml_eio_posix_stat_atime_nsec" [@@noalloc] +external ctime_nsec : stat -> int = "ocaml_eio_posix_stat_ctime_nsec" [@@noalloc] +external mtime_nsec : stat -> int = "ocaml_eio_posix_stat_mtime_nsec" [@@noalloc] + +val realpath : string -> string +val read_link : dir_fd -> string -> string + +val mkdir : mode:int -> dir_fd -> string -> unit +val unlink : dir:bool -> dir_fd -> string -> unit +val rename : dir_fd -> string -> dir_fd -> string -> unit + +val symlink : link_to:string -> dir_fd -> string -> unit +(** [symlink ~link_to dir path] will create a new symlink at [dir / path] + linking to [link_to]. *) + +val readdir : dir_fd -> string -> string array + +val readv : fd -> Cstruct.t array -> int +val writev : fd -> Cstruct.t array -> int + +val preadv : file_offset:Optint.Int63.t -> fd -> Cstruct.t array -> int +val pwritev : file_offset:Optint.Int63.t -> fd -> Cstruct.t array -> int + +val pipe : sw:Switch.t -> fd * fd + +module Open_flags : sig + type t + + val rdonly : t + val rdwr : t + val wronly : t + val append : t + val creat : t + val directory : t + val dsync : t option + val excl : t + val noctty : t + val nofollow : t + val sync : t + val trunc : t + val resolve_beneath : t option + val path : t option + + val empty : t + val ( + ) : t -> t -> t + val ( +? ) : t -> t option -> t (** Add if available *) +end + +val openat : sw:Switch.t -> mode:int -> dir_fd -> string -> Open_flags.t -> fd +(** Note: the returned FD is always non-blocking and close-on-exec. *) + +module Process : sig + type t + (** A child process. *) + + module Fork_action = Eio_unix.Private.Fork_action + (** Setup actions to perform in the child process. *) + + val spawn : sw:Switch.t -> Fork_action.t list -> t + (** [spawn ~sw actions] forks a child process, which executes [actions]. + The last action should be {!Fork_action.execve}. + + You will typically want to do [Promise.await (exit_status child)] after this. + + @param sw The child will be sent {!Sys.sigkill} if [sw] finishes. *) + + val signal : t -> int -> unit + (** [signal t x] sends signal [x] to [t]. + + This is similar to doing [Unix.kill t.pid x], + except that it ensures no signal is sent after [t] has been reaped. *) + + val pid : t -> int + + val exit_status : t -> Unix.process_status Promise.t + (** [exit_status t] is a promise for the process's exit status. *) +end + +(**/**) +(* Exposed for testing only. *) +module Resolve : sig + val open_beneath_fallback : ?dirfd:Unix.file_descr -> sw:Switch.t -> mode:int -> string -> Open_flags.t -> fd + val open_unconfined : sw:Switch.t -> mode:int -> fd option -> string -> Open_flags.t -> fd +end +(**/**) diff --git a/lib_eio_posix/net.ml b/lib_eio_posix/net.ml index 7f9d25fc2..476ca63e6 100644 --- a/lib_eio_posix/net.ml +++ b/lib_eio_posix/net.ml @@ -1,191 +1,191 @@ -open Eio.Std - -module Fd = Eio_unix.Fd - -let socket_domain_of = function - | `Unix _ -> Unix.PF_UNIX - | `UdpV4 -> Unix.PF_INET - | `UdpV6 -> Unix.PF_INET6 - | `Udp (host, _) - | `Tcp (host, _) -> - Eio.Net.Ipaddr.fold host - ~v4:(fun _ -> Unix.PF_INET) - ~v6:(fun _ -> Unix.PF_INET6) - -module Listening_socket = struct - type t = { - hook : Switch.hook; - fd : Fd.t; - } - - type tag = [`Generic | `Unix] - - let make ~hook fd = { hook; fd } - - let fd t = t.fd - - let close t = - Switch.remove_hook t.hook; - Fd.close t.fd - - let accept t ~sw = - let client, client_addr = Err.run (Low_level.accept ~sw) t.fd in - let client_addr = match client_addr with - | Unix.ADDR_UNIX path -> `Unix path - | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port) - in - let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in - flow, client_addr - - let listening_addr { fd; _ } = - Eio_unix.Fd.use_exn "listening_addr" fd - (fun fd -> Eio_unix.Net.sockaddr_of_unix_stream (Unix.getsockname fd)) -end - -let listening_handler = Eio_unix.Pi.listening_socket_handler (module Listening_socket) - -let listening_socket ~hook fd = - Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler) - -module Datagram_socket = struct - type tag = [`Generic | `Unix] - - type t = Eio_unix.Fd.t - - let close = Fd.close - - let fd t = t - - let send t ?dst buf = - let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in - let sent = Err.run (Low_level.send_msg t ?dst) (Array.of_list buf) in - assert (sent = Cstruct.lenv buf) - - let recv t buf = - let addr, recv = Err.run (Low_level.recv_msg t) [| buf |] in - Eio_unix.Net.sockaddr_of_unix_datagram addr, recv - - let shutdown t cmd = - try - Low_level.shutdown t @@ match cmd with - | `Receive -> Unix.SHUTDOWN_RECEIVE - | `Send -> Unix.SHUTDOWN_SEND - | `All -> Unix.SHUTDOWN_ALL - with - | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () - | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) -end - -let datagram_handler = Eio_unix.Pi.datagram_handler (module Datagram_socket) - -let datagram_socket fd = - Eio.Resource.T (fd, datagram_handler) - -(* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *) -let getaddrinfo ~service node = - let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } = - match ai_family, ai_socktype, ai_addr with - | (Unix.PF_INET | PF_INET6), - (Unix.SOCK_STREAM | SOCK_DGRAM), - Unix.ADDR_INET (inet_addr,port) -> ( - match ai_protocol with - | 6 -> Some (`Tcp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) - | 17 -> Some (`Udp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) - | _ -> None) - | _ -> None - in - Err.run (Eio_unix.run_in_systhread ~label:"getaddrinfo") @@ fun () -> - let rec aux () = - try - Unix.getaddrinfo node service [] - |> List.filter_map to_eio_sockaddr_t - with Unix.Unix_error (EINTR, _, _) -> aux () - in - aux () - -let listen ~reuse_addr ~reuse_port ~backlog ~sw (listen_addr : Eio.Net.Sockaddr.stream) = - let socket_type, addr = - match listen_addr with - | `Unix path -> - if reuse_addr then ( - let buf = Low_level.create_stat () in - match Low_level.fstatat ~buf ~follow:false Fs path with - | () -> if Low_level.kind buf = `Socket then Unix.unlink path - | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () - | exception Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg - ); - Unix.SOCK_STREAM, Unix.ADDR_UNIX path - | `Tcp (host, port) -> - let host = Eio_unix.Net.Ipaddr.to_unix host in - Unix.SOCK_STREAM, Unix.ADDR_INET (host, port) - in - let sock = Low_level.socket ~sw (socket_domain_of listen_addr) socket_type 0 in - (* For Unix domain sockets, remove the path when done (except for abstract sockets). *) - let hook = - match listen_addr with - | `Unix path when String.length path > 0 && path.[0] <> Char.chr 0 -> - Switch.on_release_cancellable sw (fun () -> Unix.unlink path) - | `Unix _ | `Tcp _ -> - Switch.null_hook - in - Fd.use_exn "listen" sock (fun fd -> - if reuse_addr then - Unix.setsockopt fd Unix.SO_REUSEADDR true; - if reuse_port then - Unix.setsockopt fd Unix.SO_REUSEPORT true; - Unix.bind fd addr; - Unix.listen fd backlog; - ); - (listening_socket ~hook sock :> _ Eio.Net.listening_socket_ty r) - -let connect ~sw connect_addr = - let socket_type, addr = - match connect_addr with - | `Unix path -> Unix.SOCK_STREAM, Unix.ADDR_UNIX path - | `Tcp (host, port) -> - let host = Eio_unix.Net.Ipaddr.to_unix host in - Unix.SOCK_STREAM, Unix.ADDR_INET (host, port) - in - let sock = Low_level.socket ~sw (socket_domain_of connect_addr) socket_type 0 in - try - Low_level.connect sock addr; - (Flow.of_fd sock :> _ Eio_unix.Net.stream_socket) - with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - -let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr = - let sock = Low_level.socket ~sw (socket_domain_of saddr) Unix.SOCK_DGRAM 0 in - begin match saddr with - | `Udp _ | `Unix _ as saddr -> - let addr = Eio_unix.Net.sockaddr_to_unix saddr in - Fd.use_exn "datagram_socket" sock (fun fd -> - if reuse_addr then - Unix.setsockopt fd Unix.SO_REUSEADDR true; - if reuse_port then - Unix.setsockopt fd Unix.SO_REUSEPORT true; - Unix.bind fd addr - ) - | `UdpV4 | `UdpV6 -> () - end; - datagram_socket sock - -module Impl = struct - type t = unit - type tag = [`Generic | `Unix] - - let listen () = listen - - let connect () ~sw addr = - let socket = connect ~sw addr in - (socket :> [`Generic | `Unix] Eio.Net.stream_socket_ty r) - - let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr = - let socket = create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr in - (socket :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r) - - let getaddrinfo () = getaddrinfo - let getnameinfo () = Eio_unix.Net.getnameinfo -end - -let v : Impl.tag Eio.Net.ty r = - let handler = Eio.Net.Pi.network (module Impl) in - Eio.Resource.T ((), handler) +open Eio.Std + +module Fd = Eio_unix.Fd + +let socket_domain_of = function + | `Unix _ -> Unix.PF_UNIX + | `UdpV4 -> Unix.PF_INET + | `UdpV6 -> Unix.PF_INET6 + | `Udp (host, _) + | `Tcp (host, _) -> + Eio.Net.Ipaddr.fold host + ~v4:(fun _ -> Unix.PF_INET) + ~v6:(fun _ -> Unix.PF_INET6) + +module Listening_socket = struct + type t = { + hook : Switch.hook; + fd : Fd.t; + } + + type tag = [`Generic | `Unix] + + let make ~hook fd = { hook; fd } + + let fd t = t.fd + + let close t = + Switch.remove_hook t.hook; + Fd.close t.fd + + let accept t ~sw = + let client, client_addr = Err.run (Low_level.accept ~sw) t.fd in + let client_addr = match client_addr with + | Unix.ADDR_UNIX path -> `Unix path + | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port) + in + let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in + flow, client_addr + + let listening_addr { fd; _ } = + Eio_unix.Fd.use_exn "listening_addr" fd + (fun fd -> Eio_unix.Net.sockaddr_of_unix_stream (Unix.getsockname fd)) +end + +let listening_handler = Eio_unix.Pi.listening_socket_handler (module Listening_socket) + +let listening_socket ~hook fd = + Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler) + +module Datagram_socket = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t + + let close = Fd.close + + let fd t = t + + let send t ?dst buf = + let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in + let sent = Err.run (Low_level.send_msg t ?dst) (Array.of_list buf) in + assert (sent = Cstruct.lenv buf) + + let recv t buf = + let addr, recv = Err.run (Low_level.recv_msg t) [| buf |] in + Eio_unix.Net.sockaddr_of_unix_datagram addr, recv + + let shutdown t cmd = + try + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL + with + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () + | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) +end + +let datagram_handler = Eio_unix.Pi.datagram_handler (module Datagram_socket) + +let datagram_socket fd = + Eio.Resource.T (fd, datagram_handler) + +(* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *) +let getaddrinfo ~service node = + let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } = + match ai_family, ai_socktype, ai_addr with + | (Unix.PF_INET | PF_INET6), + (Unix.SOCK_STREAM | SOCK_DGRAM), + Unix.ADDR_INET (inet_addr,port) -> ( + match ai_protocol with + | 6 -> Some (`Tcp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) + | 17 -> Some (`Udp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) + | _ -> None) + | _ -> None + in + Err.run (Eio_unix.run_in_systhread ~label:"getaddrinfo") @@ fun () -> + let rec aux () = + try + Unix.getaddrinfo node service [] + |> List.filter_map to_eio_sockaddr_t + with Unix.Unix_error (EINTR, _, _) -> aux () + in + aux () + +let listen ~reuse_addr ~reuse_port ~backlog ~sw (listen_addr : Eio.Net.Sockaddr.stream) = + let socket_type, addr = + match listen_addr with + | `Unix path -> + if reuse_addr then ( + let buf = Low_level.create_stat () in + match Low_level.fstatat ~buf ~follow:false Fs path with + | () -> if Low_level.kind buf = `Socket then Unix.unlink path + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () + | exception Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg + ); + Unix.SOCK_STREAM, Unix.ADDR_UNIX path + | `Tcp (host, port) -> + let host = Eio_unix.Net.Ipaddr.to_unix host in + Unix.SOCK_STREAM, Unix.ADDR_INET (host, port) + in + let sock = Low_level.socket ~sw (socket_domain_of listen_addr) socket_type 0 in + (* For Unix domain sockets, remove the path when done (except for abstract sockets). *) + let hook = + match listen_addr with + | `Unix path when String.length path > 0 && path.[0] <> Char.chr 0 -> + Switch.on_release_cancellable sw (fun () -> Unix.unlink path) + | `Unix _ | `Tcp _ -> + Switch.null_hook + in + Fd.use_exn "listen" sock (fun fd -> + if reuse_addr then + Unix.setsockopt fd Unix.SO_REUSEADDR true; + if reuse_port then + Unix.setsockopt fd Unix.SO_REUSEPORT true; + Unix.bind fd addr; + Unix.listen fd backlog; + ); + (listening_socket ~hook sock :> _ Eio.Net.listening_socket_ty r) + +let connect ~sw connect_addr = + let socket_type, addr = + match connect_addr with + | `Unix path -> Unix.SOCK_STREAM, Unix.ADDR_UNIX path + | `Tcp (host, port) -> + let host = Eio_unix.Net.Ipaddr.to_unix host in + Unix.SOCK_STREAM, Unix.ADDR_INET (host, port) + in + let sock = Low_level.socket ~sw (socket_domain_of connect_addr) socket_type 0 in + try + Low_level.connect sock addr; + (Flow.of_fd sock :> _ Eio_unix.Net.stream_socket) + with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) + +let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr = + let sock = Low_level.socket ~sw (socket_domain_of saddr) Unix.SOCK_DGRAM 0 in + begin match saddr with + | `Udp _ | `Unix _ as saddr -> + let addr = Eio_unix.Net.sockaddr_to_unix saddr in + Fd.use_exn "datagram_socket" sock (fun fd -> + if reuse_addr then + Unix.setsockopt fd Unix.SO_REUSEADDR true; + if reuse_port then + Unix.setsockopt fd Unix.SO_REUSEPORT true; + Unix.bind fd addr + ) + | `UdpV4 | `UdpV6 -> () + end; + datagram_socket sock + +module Impl = struct + type t = unit + type tag = [`Generic | `Unix] + + let listen () = listen + + let connect () ~sw addr = + let socket = connect ~sw addr in + (socket :> [`Generic | `Unix] Eio.Net.stream_socket_ty r) + + let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr = + let socket = create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr in + (socket :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r) + + let getaddrinfo () = getaddrinfo + let getnameinfo () = Eio_unix.Net.getnameinfo +end + +let v : Impl.tag Eio.Net.ty r = + let handler = Eio.Net.Pi.network (module Impl) in + Eio.Resource.T ((), handler) diff --git a/lib_eio_posix/path.ml b/lib_eio_posix/path.ml index 270154d21..ad2f257d9 100644 --- a/lib_eio_posix/path.ml +++ b/lib_eio_posix/path.ml @@ -1,81 +1,81 @@ -type token = - | Empty - | DotDot - | String of string - -let rec tokenise = function - | [] -> [] - | ["."] -> [Empty] (* "path/." is the same as "path/" *) - | "." :: xs -> tokenise xs (* Skip dot if not at end *) - | "" :: xs -> Empty :: tokenise xs - | ".." :: xs -> DotDot :: tokenise xs - | x :: xs -> String x :: tokenise xs - -module Rel = struct - type t = - | Leaf of { basename : string; trailing_slash : bool } - | Self (* A final "." *) - | Child of string * t - | Parent of t - - let rec parse = function - | [] -> Self - | [String basename; Empty] -> Leaf { basename; trailing_slash = true } - | [String basename] -> Leaf { basename; trailing_slash = false } - | [DotDot] -> Parent Self - | DotDot :: xs -> Parent (parse xs) - | String s :: xs -> Child (s, parse xs) - | Empty :: xs -> parse xs - - let parse s = parse (tokenise s) - - let rec concat a b = - match a with - | Leaf { basename; trailing_slash = _ } -> Child (basename, b) - | Child (name, xs) -> Child (name, concat xs b) - | Parent xs -> Parent (concat xs b) - | Self -> b - - let rec dump f = function - | Child (x, xs) -> Fmt.pf f "%S / %a" x dump xs - | Parent xs -> Fmt.pf f ".. / %a" dump xs - | Self -> Fmt.pf f "." - | Leaf { basename; trailing_slash } -> - Fmt.pf f "%S" basename; - if trailing_slash then Fmt.pf f " /" - - let rec segs = function - | Leaf { basename; trailing_slash } -> [if trailing_slash then basename ^ "/" else basename] - | Self -> [""] - | Child (x, xs) -> x :: segs xs - | Parent Self -> [".."] - | Parent xs -> ".." :: segs xs - - let to_string = function - | Self -> "." - | t -> String.concat "/" (segs t) -end - -type t = - | Relative of Rel.t - | Absolute of Rel.t - -let rec parse_abs = function - | "" :: [] -> Absolute Self - | "" :: xs -> parse_abs xs - | xs -> Absolute (Rel.parse xs) - -let parse = function - | "" -> Relative Self - | s -> - match String.split_on_char '/' s with - | "" :: path -> parse_abs path - | path -> Relative (Rel.parse path) - -let dump f = function - | Relative r -> Rel.dump f r - | Absolute r -> Fmt.pf f "/ %a" Rel.dump r - -let to_string = function - | Relative r -> Rel.to_string r - | Absolute r -> String.concat "/" ("" :: Rel.segs r) +type token = + | Empty + | DotDot + | String of string + +let rec tokenise = function + | [] -> [] + | ["."] -> [Empty] (* "path/." is the same as "path/" *) + | "." :: xs -> tokenise xs (* Skip dot if not at end *) + | "" :: xs -> Empty :: tokenise xs + | ".." :: xs -> DotDot :: tokenise xs + | x :: xs -> String x :: tokenise xs + +module Rel = struct + type t = + | Leaf of { basename : string; trailing_slash : bool } + | Self (* A final "." *) + | Child of string * t + | Parent of t + + let rec parse = function + | [] -> Self + | [String basename; Empty] -> Leaf { basename; trailing_slash = true } + | [String basename] -> Leaf { basename; trailing_slash = false } + | [DotDot] -> Parent Self + | DotDot :: xs -> Parent (parse xs) + | String s :: xs -> Child (s, parse xs) + | Empty :: xs -> parse xs + + let parse s = parse (tokenise s) + + let rec concat a b = + match a with + | Leaf { basename; trailing_slash = _ } -> Child (basename, b) + | Child (name, xs) -> Child (name, concat xs b) + | Parent xs -> Parent (concat xs b) + | Self -> b + + let rec dump f = function + | Child (x, xs) -> Fmt.pf f "%S / %a" x dump xs + | Parent xs -> Fmt.pf f ".. / %a" dump xs + | Self -> Fmt.pf f "." + | Leaf { basename; trailing_slash } -> + Fmt.pf f "%S" basename; + if trailing_slash then Fmt.pf f " /" + + let rec segs = function + | Leaf { basename; trailing_slash } -> [if trailing_slash then basename ^ "/" else basename] + | Self -> [""] + | Child (x, xs) -> x :: segs xs + | Parent Self -> [".."] + | Parent xs -> ".." :: segs xs + + let to_string = function + | Self -> "." + | t -> String.concat "/" (segs t) +end + +type t = + | Relative of Rel.t + | Absolute of Rel.t + +let rec parse_abs = function + | "" :: [] -> Absolute Self + | "" :: xs -> parse_abs xs + | xs -> Absolute (Rel.parse xs) + +let parse = function + | "" -> Relative Self + | s -> + match String.split_on_char '/' s with + | "" :: path -> parse_abs path + | path -> Relative (Rel.parse path) + +let dump f = function + | Relative r -> Rel.dump f r + | Absolute r -> Fmt.pf f "/ %a" Rel.dump r + +let to_string = function + | Relative r -> Rel.to_string r + | Absolute r -> String.concat "/" ("" :: Rel.segs r) diff --git a/lib_eio_posix/path.mli b/lib_eio_posix/path.mli index 1577dddd8..7b25209ab 100644 --- a/lib_eio_posix/path.mli +++ b/lib_eio_posix/path.mli @@ -1,26 +1,26 @@ -module Rel : sig - type t = - | Leaf of { basename : string; trailing_slash : bool } - | Self (* A final "." *) - | Child of string * t - | Parent of t - - val concat : t -> t -> t - - val to_string : t -> string - - val dump : t Fmt.t -end - -type t = - | Relative of Rel.t - | Absolute of Rel.t - -val parse : string -> t -(** Note: - [parse "" = Relative Self] - [parse ".." = Relative (Parent Self)] *) - -val to_string : t -> string - -val dump : t Fmt.t +module Rel : sig + type t = + | Leaf of { basename : string; trailing_slash : bool } + | Self (* A final "." *) + | Child of string * t + | Parent of t + + val concat : t -> t -> t + + val to_string : t -> string + + val dump : t Fmt.t +end + +type t = + | Relative of Rel.t + | Absolute of Rel.t + +val parse : string -> t +(** Note: + [parse "" = Relative Self] + [parse ".." = Relative (Parent Self)] *) + +val to_string : t -> string + +val dump : t Fmt.t diff --git a/lib_eio_posix/primitives.h b/lib_eio_posix/primitives.h index eff5960c6..fdb2f7d42 100644 --- a/lib_eio_posix/primitives.h +++ b/lib_eio_posix/primitives.h @@ -1,51 +1,51 @@ -/* AUTOGENERATED FILE, DO NOT EDIT */ -#define CAML_NAME_SPACE -#define _GNU_SOURCE -#include -CAMLprim value caml_eio_posix_send_msg(value, value, value, value, value); -CAMLprim value caml_eio_posix_recv_msg(value, value, value); -CAMLprim value caml_eio_posix_getrandom(value, value, value); -CAMLprim value caml_eio_posix_readv(value, value); -CAMLprim value caml_eio_posix_writev(value, value); -CAMLprim value caml_eio_posix_preadv(value, value, value); -CAMLprim value caml_eio_posix_pwritev(value, value, value); -CAMLprim value caml_eio_posix_openat(value, value, value, value); -CAMLprim value caml_eio_posix_fdopendir(value); -CAMLprim value caml_eio_posix_mkdirat(value, value, value); -CAMLprim value caml_eio_posix_unlinkat(value, value, value); -CAMLprim value caml_eio_posix_renameat(value, value, value, value); -CAMLprim value caml_eio_posix_symlinkat(value, value, value); -CAMLprim value caml_eio_posix_make_stat(value); -CAMLprim value caml_eio_posix_fstatat(value, value, value, value); -CAMLprim value caml_eio_posix_fstat(value, value); -CAMLprim int64_t ocaml_eio_posix_stat_blksize_native(value); -CAMLprim value ocaml_eio_posix_stat_blksize_bytes(value); -CAMLprim int64_t ocaml_eio_posix_stat_nlink_native(value); -CAMLprim value ocaml_eio_posix_stat_nlink_bytes(value); -CAMLprim int64_t ocaml_eio_posix_stat_uid_native(value); -CAMLprim value ocaml_eio_posix_stat_uid_bytes(value); -CAMLprim int64_t ocaml_eio_posix_stat_gid_native(value); -CAMLprim value ocaml_eio_posix_stat_gid_bytes(value); -CAMLprim int64_t ocaml_eio_posix_stat_ino_native(value); -CAMLprim value ocaml_eio_posix_stat_ino_bytes(value); -CAMLprim int64_t ocaml_eio_posix_stat_size_native(value); -CAMLprim value ocaml_eio_posix_stat_size_bytes(value); -CAMLprim int64_t ocaml_eio_posix_stat_rdev_native(value); -CAMLprim value ocaml_eio_posix_stat_rdev_bytes(value); -CAMLprim int64_t ocaml_eio_posix_stat_dev_native(value); -CAMLprim value ocaml_eio_posix_stat_dev_bytes(value); -CAMLprim intnat ocaml_eio_posix_stat_perm_native(value); -CAMLprim value ocaml_eio_posix_stat_perm_bytes(value); -CAMLprim intnat ocaml_eio_posix_stat_mode_native(value); -CAMLprim value ocaml_eio_posix_stat_mode_bytes(value); -CAMLprim value ocaml_eio_posix_stat_kind(value); -CAMLprim int64_t ocaml_eio_posix_stat_atime_sec_native(value); -CAMLprim value ocaml_eio_posix_stat_atime_sec_bytes(value); -CAMLprim int64_t ocaml_eio_posix_stat_ctime_sec_native(value); -CAMLprim value ocaml_eio_posix_stat_ctime_sec_bytes(value); -CAMLprim int64_t ocaml_eio_posix_stat_mtime_sec_native(value); -CAMLprim value ocaml_eio_posix_stat_mtime_sec_bytes(value); -CAMLprim value ocaml_eio_posix_stat_atime_nsec(value); -CAMLprim value ocaml_eio_posix_stat_ctime_nsec(value); -CAMLprim value ocaml_eio_posix_stat_mtime_nsec(value); -CAMLprim value caml_eio_posix_spawn(value, value); +/* AUTOGENERATED FILE, DO NOT EDIT */ +#define CAML_NAME_SPACE +#define _GNU_SOURCE +#include +CAMLprim value caml_eio_posix_send_msg(value, value, value, value, value); +CAMLprim value caml_eio_posix_recv_msg(value, value, value); +CAMLprim value caml_eio_posix_getrandom(value, value, value); +CAMLprim value caml_eio_posix_readv(value, value); +CAMLprim value caml_eio_posix_writev(value, value); +CAMLprim value caml_eio_posix_preadv(value, value, value); +CAMLprim value caml_eio_posix_pwritev(value, value, value); +CAMLprim value caml_eio_posix_openat(value, value, value, value); +CAMLprim value caml_eio_posix_fdopendir(value); +CAMLprim value caml_eio_posix_mkdirat(value, value, value); +CAMLprim value caml_eio_posix_unlinkat(value, value, value); +CAMLprim value caml_eio_posix_renameat(value, value, value, value); +CAMLprim value caml_eio_posix_symlinkat(value, value, value); +CAMLprim value caml_eio_posix_make_stat(value); +CAMLprim value caml_eio_posix_fstatat(value, value, value, value); +CAMLprim value caml_eio_posix_fstat(value, value); +CAMLprim int64_t ocaml_eio_posix_stat_blksize_native(value); +CAMLprim value ocaml_eio_posix_stat_blksize_bytes(value); +CAMLprim int64_t ocaml_eio_posix_stat_nlink_native(value); +CAMLprim value ocaml_eio_posix_stat_nlink_bytes(value); +CAMLprim int64_t ocaml_eio_posix_stat_uid_native(value); +CAMLprim value ocaml_eio_posix_stat_uid_bytes(value); +CAMLprim int64_t ocaml_eio_posix_stat_gid_native(value); +CAMLprim value ocaml_eio_posix_stat_gid_bytes(value); +CAMLprim int64_t ocaml_eio_posix_stat_ino_native(value); +CAMLprim value ocaml_eio_posix_stat_ino_bytes(value); +CAMLprim int64_t ocaml_eio_posix_stat_size_native(value); +CAMLprim value ocaml_eio_posix_stat_size_bytes(value); +CAMLprim int64_t ocaml_eio_posix_stat_rdev_native(value); +CAMLprim value ocaml_eio_posix_stat_rdev_bytes(value); +CAMLprim int64_t ocaml_eio_posix_stat_dev_native(value); +CAMLprim value ocaml_eio_posix_stat_dev_bytes(value); +CAMLprim intnat ocaml_eio_posix_stat_perm_native(value); +CAMLprim value ocaml_eio_posix_stat_perm_bytes(value); +CAMLprim intnat ocaml_eio_posix_stat_mode_native(value); +CAMLprim value ocaml_eio_posix_stat_mode_bytes(value); +CAMLprim value ocaml_eio_posix_stat_kind(value); +CAMLprim int64_t ocaml_eio_posix_stat_atime_sec_native(value); +CAMLprim value ocaml_eio_posix_stat_atime_sec_bytes(value); +CAMLprim int64_t ocaml_eio_posix_stat_ctime_sec_native(value); +CAMLprim value ocaml_eio_posix_stat_ctime_sec_bytes(value); +CAMLprim int64_t ocaml_eio_posix_stat_mtime_sec_native(value); +CAMLprim value ocaml_eio_posix_stat_mtime_sec_bytes(value); +CAMLprim value ocaml_eio_posix_stat_atime_nsec(value); +CAMLprim value ocaml_eio_posix_stat_ctime_nsec(value); +CAMLprim value ocaml_eio_posix_stat_mtime_nsec(value); +CAMLprim value caml_eio_posix_spawn(value, value); diff --git a/lib_eio_posix/process.ml b/lib_eio_posix/process.ml index 8461bb5a1..a25547191 100644 --- a/lib_eio_posix/process.ml +++ b/lib_eio_posix/process.ml @@ -1,50 +1,50 @@ -open Eio.Std - -module Process_impl = struct - type t = Low_level.Process.t - type tag = [ `Generic | `Unix ] - - let pid = Low_level.Process.pid - - let await t = - match Eio.Promise.await @@ Low_level.Process.exit_status t with - | Unix.WEXITED i -> `Exited i - | Unix.WSIGNALED i -> `Signaled i - | Unix.WSTOPPED _ -> assert false - - let signal = Low_level.Process.signal -end - -let process = - let handler = Eio.Process.Pi.process (module Process_impl) in - fun proc -> Eio.Resource.T (proc, handler) - -module Impl = struct - module T = struct - type t = unit - - let spawn_unix () ~sw ?cwd ~env ~fds ~executable args = - let actions = Low_level.Process.Fork_action.[ - inherit_fds fds; - execve executable ~argv:(Array.of_list args) ~env - ] in - let with_actions cwd fn = match cwd with - | None -> fn actions - | Some ((dir, path) : Eio.Fs.dir_ty Eio.Path.t) -> - match Fs.as_posix_dir dir with - | None -> Fmt.invalid_arg "cwd is not an OS directory!" - | Some dirfd -> - Switch.run ~name:"spawn_unix" @@ fun launch_sw -> - let cwd = Low_level.openat ~sw:launch_sw ~mode:0 dirfd path Low_level.Open_flags.(rdonly + directory) in - fn (Low_level.Process.Fork_action.fchdir cwd :: actions) - in - with_actions cwd @@ fun actions -> - process (Low_level.Process.spawn ~sw actions) - end - - include Eio_unix.Process.Make_mgr (T) -end - -let mgr : Eio_unix.Process.mgr_ty r = - let h = Eio_unix.Process.Pi.mgr_unix (module Impl) in - Eio.Resource.T ((), h) +open Eio.Std + +module Process_impl = struct + type t = Low_level.Process.t + type tag = [ `Generic | `Unix ] + + let pid = Low_level.Process.pid + + let await t = + match Eio.Promise.await @@ Low_level.Process.exit_status t with + | Unix.WEXITED i -> `Exited i + | Unix.WSIGNALED i -> `Signaled i + | Unix.WSTOPPED _ -> assert false + + let signal = Low_level.Process.signal +end + +let process = + let handler = Eio.Process.Pi.process (module Process_impl) in + fun proc -> Eio.Resource.T (proc, handler) + +module Impl = struct + module T = struct + type t = unit + + let spawn_unix () ~sw ?cwd ~env ~fds ~executable args = + let actions = Low_level.Process.Fork_action.[ + inherit_fds fds; + execve executable ~argv:(Array.of_list args) ~env + ] in + let with_actions cwd fn = match cwd with + | None -> fn actions + | Some ((dir, path) : Eio.Fs.dir_ty Eio.Path.t) -> + match Fs.as_posix_dir dir with + | None -> Fmt.invalid_arg "cwd is not an OS directory!" + | Some dirfd -> + Switch.run ~name:"spawn_unix" @@ fun launch_sw -> + let cwd = Low_level.openat ~sw:launch_sw ~mode:0 dirfd path Low_level.Open_flags.(rdonly + directory) in + fn (Low_level.Process.Fork_action.fchdir cwd :: actions) + in + with_actions cwd @@ fun actions -> + process (Low_level.Process.spawn ~sw actions) + end + + include Eio_unix.Process.Make_mgr (T) +end + +let mgr : Eio_unix.Process.mgr_ty r = + let h = Eio_unix.Process.Pi.mgr_unix (module Impl) in + Eio.Resource.T ((), h) diff --git a/lib_eio_posix/sched.ml b/lib_eio_posix/sched.ml index 23dae62a2..d6c676aaa 100644 --- a/lib_eio_posix/sched.ml +++ b/lib_eio_posix/sched.ml @@ -1,392 +1,392 @@ -(* - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -module Suspended = Eio_utils.Suspended -module Zzz = Eio_utils.Zzz -module Lf_queue = Eio_utils.Lf_queue -module Fiber_context = Eio.Private.Fiber_context -module Trace = Eio.Private.Trace -module Rcfd = Eio_unix.Private.Rcfd -module Poll = Iomux.Poll - -type exit = [`Exit_scheduler] - -(* The type of items in the run queue. *) -type runnable = - | IO : runnable (* Reminder to check for IO *) - | Thread : 'a Suspended.t * 'a -> runnable (* Resume a fiber with a result value *) - | Failed_thread : 'a Suspended.t * exn -> runnable (* Resume a fiber with an exception *) - -(* For each FD we track which fibers are waiting for it to become readable/writeable. *) -type fd_event_waiters = { - read : unit Suspended.t Lwt_dllist.t; - write : unit Suspended.t Lwt_dllist.t; -} - -type t = { - (* The queue of runnable fibers ready to be resumed. Note: other domains can also add work items here. *) - run_q : runnable Lf_queue.t; - - poll : Poll.t; - mutable poll_maxi : int; (* The highest index ever used in [poll]. *) - fd_map : (Unix.file_descr, fd_event_waiters) Hashtbl.t; - - (* When adding to [run_q] from another domain, this domain may be sleeping and so won't see the event. - In that case, [need_wakeup = true] and you must signal using [eventfd]. *) - eventfd : Rcfd.t; (* For sending events. *) - eventfd_r : Unix.file_descr; (* For reading events. *) - - mutable active_ops : int; (* Exit when this is zero and [run_q] and [sleep_q] are empty. *) - - (* If [false], the main thread will check [run_q] before sleeping again - (possibly because an event has been or will be sent to [eventfd]). - It can therefore be set to [false] in either of these cases: - - By the receiving thread because it will check [run_q] before sleeping, or - - By the sending thread because it will signal the main thread later *) - need_wakeup : bool Atomic.t; - - sleep_q: Zzz.t; (* Fibers waiting for timers. *) - - thread_pool : Eio_unix.Private.Thread_pool.t; -} - -(* The message to send to [eventfd] (any character would do). *) -let wake_buffer = Bytes.of_string "!" - -(* This can be called from any systhread (including ones not running Eio), - and also from signal handlers or GC finalizers. It must not take any locks. *) -let wakeup t = - Atomic.set t.need_wakeup false; (* [t] will check [run_q] after getting the event below *) - Rcfd.use t.eventfd - ~if_closed:ignore (* Domain has shut down (presumably after handling the event) *) - (fun fd -> - try - ignore (Unix.single_write fd wake_buffer 0 1 : int) - with - | Unix.Unix_error ((Unix.EAGAIN | EWOULDBLOCK), _, _) -> - (* If the pipe is full then a wake up is pending anyway. *) - () - | Unix.Unix_error (Unix.EPIPE, _, _) -> - (* We're shutting down; the event has already been processed. *) - () - ) - -(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) -let enqueue_thread t k x = - Lf_queue.push t.run_q (Thread (k, x)); - if Atomic.get t.need_wakeup then wakeup t - -(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) -let enqueue_failed_thread t k ex = - Lf_queue.push t.run_q (Failed_thread (k, ex)); - if Atomic.get t.need_wakeup then wakeup t - -(* Can only be called from our own domain, so no need to check for wakeup. *) -let enqueue_at_head t k = - Lf_queue.push_head t.run_q (Thread (k, ())) - -let get_waiters t fd = - match Hashtbl.find_opt t.fd_map fd with - | Some x -> x - | None -> - let x = { read = Lwt_dllist.create (); write = Lwt_dllist.create () } in - Hashtbl.add t.fd_map fd x; - x - -(* The OS told us that the event pipe is ready. Remove events. *) -let clear_event_fd t = - let buf = Bytes.create 8 in (* Read up to 8 events at a time *) - let got = Unix.read t.eventfd_r buf 0 (Bytes.length buf) in - assert (got > 0) - -(* Update [t.poll]'s entry for [fd] to match [waiters]. *) -let update t waiters fd = - let fdi = Iomux.Util.fd_of_unix fd in - let flags = - match not (Lwt_dllist.is_empty waiters.read), - not (Lwt_dllist.is_empty waiters.write) with - | false, false -> Poll.Flags.empty - | true, false -> Poll.Flags.pollin - | false, true -> Poll.Flags.pollout - | true, true -> Poll.Flags.(pollin + pollout) - in - if flags = Poll.Flags.empty then ( - Poll.invalidate_index t.poll fdi; - (* Try to find the new maxi, go back on index until we find the next - used slot, -1 means none in use. *) - let rec lower_maxi = function - | -1 -> t.poll_maxi <- -1 - | index -> - if Poll.((get_fd t.poll index) <> invalid_fd) then - t.poll_maxi <- index - else - lower_maxi (pred index) - in - if fdi = t.poll_maxi then - lower_maxi (pred fdi); - Hashtbl.remove t.fd_map fd - ) else ( - Poll.set_index t.poll fdi fd flags; - if fdi > t.poll_maxi then - t.poll_maxi <- fdi - ) - -let resume t node = - t.active_ops <- t.active_ops - 1; - let k : unit Suspended.t = Lwt_dllist.get node in - Fiber_context.clear_cancel_fn k.fiber; - enqueue_thread t k () - -(* Called when poll indicates that an event we requested for [fd] is ready. *) -let ready t _index fd revents = - assert (not Poll.Flags.(mem revents pollnval)); - if fd == t.eventfd_r then ( - clear_event_fd t - (* The scheduler will now look at the run queue again and notice any new items. *) - ) else ( - let waiters = Hashtbl.find t.fd_map fd in - let pending = Lwt_dllist.create () in - if Poll.Flags.(mem revents (pollout + pollhup + pollerr)) then - Lwt_dllist.transfer_l waiters.write pending; - if Poll.Flags.(mem revents (pollin + pollhup + pollerr)) then - Lwt_dllist.transfer_l waiters.read pending; - (* If pending has things, it means we modified the waiters, refresh our view *) - if not (Lwt_dllist.is_empty pending) then - update t waiters fd; - Lwt_dllist.iter_node_r (resume t) pending - ) - -(* Switch control to the next ready continuation. - If none is ready, wait until we get an event to wake one and then switch. - Returns only if there is nothing to do and no active operations. *) -let rec next t : [`Exit_scheduler] = - (* Wakeup any paused fibers *) - match Lf_queue.pop t.run_q with - | None -> assert false (* We should always have an IO job, at least *) - | Some Thread (k, v) -> (* We already have a runnable task *) - Fiber_context.clear_cancel_fn k.fiber; - Suspended.continue k v - | Some Failed_thread (k, ex) -> - Fiber_context.clear_cancel_fn k.fiber; - Suspended.discontinue k ex - | Some IO -> (* Note: be sure to re-inject the IO task before continuing! *) - (* This is not a fair scheduler: timers always run before all other IO *) - let now = Mtime_clock.now () in - match Zzz.pop ~now t.sleep_q with - | `Due k -> - (* A sleeping task is now due *) - Lf_queue.push t.run_q IO; (* Re-inject IO job in the run queue *) - begin match k with - | Fiber k -> Suspended.continue k () - | Fn fn -> fn (); next t - end - | `Wait_until _ | `Nothing as next_due -> - let timeout = - match next_due with - | `Wait_until time -> - let time = Mtime.to_uint64_ns time in - let now = Mtime.to_uint64_ns now in - let diff_ns = Int64.sub time now in - Poll.Nanoseconds diff_ns - | `Nothing -> Poll.Infinite - in - if timeout = Infinite && t.active_ops = 0 && Lf_queue.is_empty t.run_q then ( - (* Nothing further can happen at this point. *) - Lf_queue.close t.run_q; (* Just to catch bugs if something tries to enqueue later *) - `Exit_scheduler - ) else ( - Atomic.set t.need_wakeup true; - let timeout = - if Lf_queue.is_empty t.run_q then timeout - else ( - (* Either we're just checking for IO to avoid starvation, or - someone added a new job while we were setting [need_wakeup] to [true]. - They might or might not have seen that, so we can't be sure they'll send an event. *) - Poll.Nowait - ) - in - (* At this point we're not going to check [run_q] again before sleeping. - If [need_wakeup] is still [true], this is fine because we don't promise to do that. - If [need_wakeup = false], a wake-up event will arrive and wake us up soon. *) - Trace.suspend_domain Begin; - let nready = - try Poll.ppoll_or_poll t.poll (t.poll_maxi + 1) timeout - with Unix.Unix_error (Unix.EINTR, _, "") -> 0 - in - Trace.suspend_domain End; - Atomic.set t.need_wakeup false; - Lf_queue.push t.run_q IO; (* Re-inject IO job in the run queue *) - Poll.iter_ready t.poll nready (ready t); - next t - ) - -let with_sched fn = - let run_q = Lf_queue.create () in - Lf_queue.push run_q IO; - let sleep_q = Zzz.create () in - let eventfd_r, eventfd_w = Unix.pipe ~cloexec:true () in - Unix.set_nonblock eventfd_r; - Unix.set_nonblock eventfd_w; - let eventfd = Rcfd.make eventfd_w in - let cleanup () = - Unix.close eventfd_r; - let was_open = Rcfd.close eventfd in - assert was_open - in - let poll = Poll.create () in - let fd_map = Hashtbl.create 10 in - let thread_pool = Eio_unix.Private.Thread_pool.create ~sleep_q in - let t = { run_q; poll; poll_maxi = (-1); fd_map; eventfd; eventfd_r; - active_ops = 0; need_wakeup = Atomic.make false; sleep_q; thread_pool } in - let eventfd_ri = Iomux.Util.fd_of_unix eventfd_r in - Poll.set_index t.poll eventfd_ri eventfd_r Poll.Flags.pollin; - if eventfd_ri > t.poll_maxi then - t.poll_maxi <- eventfd_ri; - match fn t with - | x -> cleanup (); x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - cleanup (); - Printexc.raise_with_backtrace ex bt - -let await_readable t (k : unit Suspended.t) fd = - match Fiber_context.get_error k.fiber with - | Some e -> Suspended.discontinue k e - | None -> - t.active_ops <- t.active_ops + 1; - let waiters = get_waiters t fd in - let was_empty = Lwt_dllist.is_empty waiters.read in - let node = Lwt_dllist.add_l k waiters.read in - if was_empty then update t waiters fd; - Fiber_context.set_cancel_fn k.fiber (fun ex -> - Lwt_dllist.remove node; - if Lwt_dllist.is_empty waiters.read then - update t waiters fd; - t.active_ops <- t.active_ops - 1; - enqueue_failed_thread t k ex - ); - next t - -let await_writable t (k : unit Suspended.t) fd = - match Fiber_context.get_error k.fiber with - | Some e -> Suspended.discontinue k e - | None -> - t.active_ops <- t.active_ops + 1; - let waiters = get_waiters t fd in - let was_empty = Lwt_dllist.is_empty waiters.write in - let node = Lwt_dllist.add_l k waiters.write in - if was_empty then update t waiters fd; - Fiber_context.set_cancel_fn k.fiber (fun ex -> - Lwt_dllist.remove node; - if Lwt_dllist.is_empty waiters.write then - update t waiters fd; - t.active_ops <- t.active_ops - 1; - enqueue_failed_thread t k ex - ); - next t - -let get_enqueue t k = function - | Ok v -> enqueue_thread t k v - | Error ex -> enqueue_failed_thread t k ex - -let await_timeout t (k : unit Suspended.t) time = - match Fiber_context.get_error k.fiber with - | Some e -> Suspended.discontinue k e - | None -> - let node = Zzz.add t.sleep_q time (Fiber k) in - Fiber_context.set_cancel_fn k.fiber (fun ex -> - Zzz.remove t.sleep_q node; - enqueue_failed_thread t k ex - ); - next t - -let with_op t fn x = - t.active_ops <- t.active_ops + 1; - match fn x with - | r -> - t.active_ops <- t.active_ops - 1; - r - | exception ex -> - t.active_ops <- t.active_ops - 1; - raise ex - -[@@@alert "-unstable"] - -type _ Effect.t += Enter : (t -> 'a Eio_utils.Suspended.t -> [`Exit_scheduler]) -> 'a Effect.t - -let enter op fn = - Trace.suspend_fiber op; - Effect.perform (Enter fn) - -let run ~extra_effects t main x = - let rec fork ~new_fiber:fiber fn = - let open Effect.Deep in - Trace.fiber (Fiber_context.tid fiber); - match_with fn () - { retc = (fun () -> Fiber_context.destroy fiber; next t); - exnc = (fun ex -> - Fiber_context.destroy fiber; - Printexc.raise_with_backtrace ex (Printexc.get_raw_backtrace ()) - ); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Enter fn -> Some (fun k -> - match Fiber_context.get_error fiber with - | Some e -> discontinue k e - | None -> fn t { Suspended.k; fiber } - ) - | Eio.Private.Effects.Get_context -> Some (fun k -> continue k fiber) - | Eio.Private.Effects.Suspend f -> Some (fun k -> - let k = { Suspended.k; fiber } in - let enqueue = get_enqueue t k in - f fiber enqueue; - next t - ) - | Eio.Private.Effects.Fork (new_fiber, f) -> Some (fun k -> - let k = { Suspended.k; fiber } in - enqueue_at_head t k; - fork ~new_fiber f - ) - | Eio_unix.Private.Await_readable fd -> Some (fun k -> - await_readable t { Suspended.k; fiber } fd - ) - | Eio_unix.Private.Await_writable fd -> Some (fun k -> - await_writable t { Suspended.k; fiber } fd - ) - | Eio_unix.Private.Thread_pool.Run_in_systhread fn -> Some (fun k -> - let k = { Suspended.k; fiber } in - let enqueue x = enqueue_thread t k (x, t.thread_pool) in - Eio_unix.Private.Thread_pool.submit t.thread_pool ~ctx:fiber ~enqueue fn; - next t - ) - | e -> extra_effects.Effect.Deep.effc e - } - in - let result = ref None in - let `Exit_scheduler = - let new_fiber = Fiber_context.make_root () in - Domain_local_await.using - ~prepare_for_await:Eio_utils.Dla.prepare_for_await - ~while_running:(fun () -> - fork ~new_fiber (fun () -> - Eio_unix.Private.Thread_pool.run t.thread_pool @@ fun () -> - result := Some (with_op t main x); - ) - ) - in - match !result with - | Some x -> x - | None -> failwith "BUG in scheduler: deadlock detected" +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Suspended = Eio_utils.Suspended +module Zzz = Eio_utils.Zzz +module Lf_queue = Eio_utils.Lf_queue +module Fiber_context = Eio.Private.Fiber_context +module Trace = Eio.Private.Trace +module Rcfd = Eio_unix.Private.Rcfd +module Poll = Iomux.Poll + +type exit = [`Exit_scheduler] + +(* The type of items in the run queue. *) +type runnable = + | IO : runnable (* Reminder to check for IO *) + | Thread : 'a Suspended.t * 'a -> runnable (* Resume a fiber with a result value *) + | Failed_thread : 'a Suspended.t * exn -> runnable (* Resume a fiber with an exception *) + +(* For each FD we track which fibers are waiting for it to become readable/writeable. *) +type fd_event_waiters = { + read : unit Suspended.t Lwt_dllist.t; + write : unit Suspended.t Lwt_dllist.t; +} + +type t = { + (* The queue of runnable fibers ready to be resumed. Note: other domains can also add work items here. *) + run_q : runnable Lf_queue.t; + + poll : Poll.t; + mutable poll_maxi : int; (* The highest index ever used in [poll]. *) + fd_map : (Unix.file_descr, fd_event_waiters) Hashtbl.t; + + (* When adding to [run_q] from another domain, this domain may be sleeping and so won't see the event. + In that case, [need_wakeup = true] and you must signal using [eventfd]. *) + eventfd : Rcfd.t; (* For sending events. *) + eventfd_r : Unix.file_descr; (* For reading events. *) + + mutable active_ops : int; (* Exit when this is zero and [run_q] and [sleep_q] are empty. *) + + (* If [false], the main thread will check [run_q] before sleeping again + (possibly because an event has been or will be sent to [eventfd]). + It can therefore be set to [false] in either of these cases: + - By the receiving thread because it will check [run_q] before sleeping, or + - By the sending thread because it will signal the main thread later *) + need_wakeup : bool Atomic.t; + + sleep_q: Zzz.t; (* Fibers waiting for timers. *) + + thread_pool : Eio_unix.Private.Thread_pool.t; +} + +(* The message to send to [eventfd] (any character would do). *) +let wake_buffer = Bytes.of_string "!" + +(* This can be called from any systhread (including ones not running Eio), + and also from signal handlers or GC finalizers. It must not take any locks. *) +let wakeup t = + Atomic.set t.need_wakeup false; (* [t] will check [run_q] after getting the event below *) + Rcfd.use t.eventfd + ~if_closed:ignore (* Domain has shut down (presumably after handling the event) *) + (fun fd -> + try + ignore (Unix.single_write fd wake_buffer 0 1 : int) + with + | Unix.Unix_error ((Unix.EAGAIN | EWOULDBLOCK), _, _) -> + (* If the pipe is full then a wake up is pending anyway. *) + () + | Unix.Unix_error (Unix.EPIPE, _, _) -> + (* We're shutting down; the event has already been processed. *) + () + ) + +(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) +let enqueue_thread t k x = + Lf_queue.push t.run_q (Thread (k, x)); + if Atomic.get t.need_wakeup then wakeup t + +(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) +let enqueue_failed_thread t k ex = + Lf_queue.push t.run_q (Failed_thread (k, ex)); + if Atomic.get t.need_wakeup then wakeup t + +(* Can only be called from our own domain, so no need to check for wakeup. *) +let enqueue_at_head t k = + Lf_queue.push_head t.run_q (Thread (k, ())) + +let get_waiters t fd = + match Hashtbl.find_opt t.fd_map fd with + | Some x -> x + | None -> + let x = { read = Lwt_dllist.create (); write = Lwt_dllist.create () } in + Hashtbl.add t.fd_map fd x; + x + +(* The OS told us that the event pipe is ready. Remove events. *) +let clear_event_fd t = + let buf = Bytes.create 8 in (* Read up to 8 events at a time *) + let got = Unix.read t.eventfd_r buf 0 (Bytes.length buf) in + assert (got > 0) + +(* Update [t.poll]'s entry for [fd] to match [waiters]. *) +let update t waiters fd = + let fdi = Iomux.Util.fd_of_unix fd in + let flags = + match not (Lwt_dllist.is_empty waiters.read), + not (Lwt_dllist.is_empty waiters.write) with + | false, false -> Poll.Flags.empty + | true, false -> Poll.Flags.pollin + | false, true -> Poll.Flags.pollout + | true, true -> Poll.Flags.(pollin + pollout) + in + if flags = Poll.Flags.empty then ( + Poll.invalidate_index t.poll fdi; + (* Try to find the new maxi, go back on index until we find the next + used slot, -1 means none in use. *) + let rec lower_maxi = function + | -1 -> t.poll_maxi <- -1 + | index -> + if Poll.((get_fd t.poll index) <> invalid_fd) then + t.poll_maxi <- index + else + lower_maxi (pred index) + in + if fdi = t.poll_maxi then + lower_maxi (pred fdi); + Hashtbl.remove t.fd_map fd + ) else ( + Poll.set_index t.poll fdi fd flags; + if fdi > t.poll_maxi then + t.poll_maxi <- fdi + ) + +let resume t node = + t.active_ops <- t.active_ops - 1; + let k : unit Suspended.t = Lwt_dllist.get node in + Fiber_context.clear_cancel_fn k.fiber; + enqueue_thread t k () + +(* Called when poll indicates that an event we requested for [fd] is ready. *) +let ready t _index fd revents = + assert (not Poll.Flags.(mem revents pollnval)); + if fd == t.eventfd_r then ( + clear_event_fd t + (* The scheduler will now look at the run queue again and notice any new items. *) + ) else ( + let waiters = Hashtbl.find t.fd_map fd in + let pending = Lwt_dllist.create () in + if Poll.Flags.(mem revents (pollout + pollhup + pollerr)) then + Lwt_dllist.transfer_l waiters.write pending; + if Poll.Flags.(mem revents (pollin + pollhup + pollerr)) then + Lwt_dllist.transfer_l waiters.read pending; + (* If pending has things, it means we modified the waiters, refresh our view *) + if not (Lwt_dllist.is_empty pending) then + update t waiters fd; + Lwt_dllist.iter_node_r (resume t) pending + ) + +(* Switch control to the next ready continuation. + If none is ready, wait until we get an event to wake one and then switch. + Returns only if there is nothing to do and no active operations. *) +let rec next t : [`Exit_scheduler] = + (* Wakeup any paused fibers *) + match Lf_queue.pop t.run_q with + | None -> assert false (* We should always have an IO job, at least *) + | Some Thread (k, v) -> (* We already have a runnable task *) + Fiber_context.clear_cancel_fn k.fiber; + Suspended.continue k v + | Some Failed_thread (k, ex) -> + Fiber_context.clear_cancel_fn k.fiber; + Suspended.discontinue k ex + | Some IO -> (* Note: be sure to re-inject the IO task before continuing! *) + (* This is not a fair scheduler: timers always run before all other IO *) + let now = Mtime_clock.now () in + match Zzz.pop ~now t.sleep_q with + | `Due k -> + (* A sleeping task is now due *) + Lf_queue.push t.run_q IO; (* Re-inject IO job in the run queue *) + begin match k with + | Fiber k -> Suspended.continue k () + | Fn fn -> fn (); next t + end + | `Wait_until _ | `Nothing as next_due -> + let timeout = + match next_due with + | `Wait_until time -> + let time = Mtime.to_uint64_ns time in + let now = Mtime.to_uint64_ns now in + let diff_ns = Int64.sub time now in + Poll.Nanoseconds diff_ns + | `Nothing -> Poll.Infinite + in + if timeout = Infinite && t.active_ops = 0 && Lf_queue.is_empty t.run_q then ( + (* Nothing further can happen at this point. *) + Lf_queue.close t.run_q; (* Just to catch bugs if something tries to enqueue later *) + `Exit_scheduler + ) else ( + Atomic.set t.need_wakeup true; + let timeout = + if Lf_queue.is_empty t.run_q then timeout + else ( + (* Either we're just checking for IO to avoid starvation, or + someone added a new job while we were setting [need_wakeup] to [true]. + They might or might not have seen that, so we can't be sure they'll send an event. *) + Poll.Nowait + ) + in + (* At this point we're not going to check [run_q] again before sleeping. + If [need_wakeup] is still [true], this is fine because we don't promise to do that. + If [need_wakeup = false], a wake-up event will arrive and wake us up soon. *) + Trace.suspend_domain Begin; + let nready = + try Poll.ppoll_or_poll t.poll (t.poll_maxi + 1) timeout + with Unix.Unix_error (Unix.EINTR, _, "") -> 0 + in + Trace.suspend_domain End; + Atomic.set t.need_wakeup false; + Lf_queue.push t.run_q IO; (* Re-inject IO job in the run queue *) + Poll.iter_ready t.poll nready (ready t); + next t + ) + +let with_sched fn = + let run_q = Lf_queue.create () in + Lf_queue.push run_q IO; + let sleep_q = Zzz.create () in + let eventfd_r, eventfd_w = Unix.pipe ~cloexec:true () in + Unix.set_nonblock eventfd_r; + Unix.set_nonblock eventfd_w; + let eventfd = Rcfd.make eventfd_w in + let cleanup () = + Unix.close eventfd_r; + let was_open = Rcfd.close eventfd in + assert was_open + in + let poll = Poll.create () in + let fd_map = Hashtbl.create 10 in + let thread_pool = Eio_unix.Private.Thread_pool.create ~sleep_q in + let t = { run_q; poll; poll_maxi = (-1); fd_map; eventfd; eventfd_r; + active_ops = 0; need_wakeup = Atomic.make false; sleep_q; thread_pool } in + let eventfd_ri = Iomux.Util.fd_of_unix eventfd_r in + Poll.set_index t.poll eventfd_ri eventfd_r Poll.Flags.pollin; + if eventfd_ri > t.poll_maxi then + t.poll_maxi <- eventfd_ri; + match fn t with + | x -> cleanup (); x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + cleanup (); + Printexc.raise_with_backtrace ex bt + +let await_readable t (k : unit Suspended.t) fd = + match Fiber_context.get_error k.fiber with + | Some e -> Suspended.discontinue k e + | None -> + t.active_ops <- t.active_ops + 1; + let waiters = get_waiters t fd in + let was_empty = Lwt_dllist.is_empty waiters.read in + let node = Lwt_dllist.add_l k waiters.read in + if was_empty then update t waiters fd; + Fiber_context.set_cancel_fn k.fiber (fun ex -> + Lwt_dllist.remove node; + if Lwt_dllist.is_empty waiters.read then + update t waiters fd; + t.active_ops <- t.active_ops - 1; + enqueue_failed_thread t k ex + ); + next t + +let await_writable t (k : unit Suspended.t) fd = + match Fiber_context.get_error k.fiber with + | Some e -> Suspended.discontinue k e + | None -> + t.active_ops <- t.active_ops + 1; + let waiters = get_waiters t fd in + let was_empty = Lwt_dllist.is_empty waiters.write in + let node = Lwt_dllist.add_l k waiters.write in + if was_empty then update t waiters fd; + Fiber_context.set_cancel_fn k.fiber (fun ex -> + Lwt_dllist.remove node; + if Lwt_dllist.is_empty waiters.write then + update t waiters fd; + t.active_ops <- t.active_ops - 1; + enqueue_failed_thread t k ex + ); + next t + +let get_enqueue t k = function + | Ok v -> enqueue_thread t k v + | Error ex -> enqueue_failed_thread t k ex + +let await_timeout t (k : unit Suspended.t) time = + match Fiber_context.get_error k.fiber with + | Some e -> Suspended.discontinue k e + | None -> + let node = Zzz.add t.sleep_q time (Fiber k) in + Fiber_context.set_cancel_fn k.fiber (fun ex -> + Zzz.remove t.sleep_q node; + enqueue_failed_thread t k ex + ); + next t + +let with_op t fn x = + t.active_ops <- t.active_ops + 1; + match fn x with + | r -> + t.active_ops <- t.active_ops - 1; + r + | exception ex -> + t.active_ops <- t.active_ops - 1; + raise ex + +[@@@alert "-unstable"] + +type _ Effect.t += Enter : (t -> 'a Eio_utils.Suspended.t -> [`Exit_scheduler]) -> 'a Effect.t + +let enter op fn = + Trace.suspend_fiber op; + Effect.perform (Enter fn) + +let run ~extra_effects t main x = + let rec fork ~new_fiber:fiber fn = + let open Effect.Deep in + Trace.fiber (Fiber_context.tid fiber); + match_with fn () + { retc = (fun () -> Fiber_context.destroy fiber; next t); + exnc = (fun ex -> + Fiber_context.destroy fiber; + Printexc.raise_with_backtrace ex (Printexc.get_raw_backtrace ()) + ); + effc = fun (type a) (e : a Effect.t) -> + match e with + | Enter fn -> Some (fun k -> + match Fiber_context.get_error fiber with + | Some e -> discontinue k e + | None -> fn t { Suspended.k; fiber } + ) + | Eio.Private.Effects.Get_context -> Some (fun k -> continue k fiber) + | Eio.Private.Effects.Suspend f -> Some (fun k -> + let k = { Suspended.k; fiber } in + let enqueue = get_enqueue t k in + f fiber enqueue; + next t + ) + | Eio.Private.Effects.Fork (new_fiber, f) -> Some (fun k -> + let k = { Suspended.k; fiber } in + enqueue_at_head t k; + fork ~new_fiber f + ) + | Eio_unix.Private.Await_readable fd -> Some (fun k -> + await_readable t { Suspended.k; fiber } fd + ) + | Eio_unix.Private.Await_writable fd -> Some (fun k -> + await_writable t { Suspended.k; fiber } fd + ) + | Eio_unix.Private.Thread_pool.Run_in_systhread fn -> Some (fun k -> + let k = { Suspended.k; fiber } in + let enqueue x = enqueue_thread t k (x, t.thread_pool) in + Eio_unix.Private.Thread_pool.submit t.thread_pool ~ctx:fiber ~enqueue fn; + next t + ) + | e -> extra_effects.Effect.Deep.effc e + } + in + let result = ref None in + let `Exit_scheduler = + let new_fiber = Fiber_context.make_root () in + Domain_local_await.using + ~prepare_for_await:Eio_utils.Dla.prepare_for_await + ~while_running:(fun () -> + fork ~new_fiber (fun () -> + Eio_unix.Private.Thread_pool.run t.thread_pool @@ fun () -> + result := Some (with_op t main x); + ) + ) + in + match !result with + | Some x -> x + | None -> failwith "BUG in scheduler: deadlock detected" diff --git a/lib_eio_posix/sched.mli b/lib_eio_posix/sched.mli index 22cf07d1c..02e7164a5 100644 --- a/lib_eio_posix/sched.mli +++ b/lib_eio_posix/sched.mli @@ -1,46 +1,46 @@ -(** The scheduler keeps track of all suspended fibers and resumes them as appropriate. - - Each Eio domain has one scheduler, which keeps a queue of runnable - processes plus a record of all fibers waiting for IO operations to complete. *) - -type t - -type exit -(** This is equivalent to [unit], but indicates that a function returning this will call {!next} - and so does not return until the whole event loop is finished. Such functions should normally - be called in tail position. *) - -val with_sched : (t -> 'a) -> 'a -(** [with_sched fn] sets up a scheduler and calls [fn t]. - Typically [fn] will call {!run}. - When [fn] returns, the scheduler's resources are freed. *) - -val run : - extra_effects:exit Effect.Deep.effect_handler -> - t -> ('a -> 'b) -> 'a -> 'b [@@alert "-unstable"] -(** [run ~extra_effects t f x] starts an event loop using [t] and runs [f x] as the root fiber within it. - - Unknown effects are passed to [extra_effects]. *) - -val next : t -> exit -(** [next t] asks the scheduler to transfer control to the next runnable fiber, - or wait for an event from the OS if there is none. This should normally be - called in tail position from an effect handler. *) - -val await_readable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit -(** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for reading. *) - -val await_writable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit -(** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for writing. *) - -val await_timeout : t -> unit Eio_utils.Suspended.t -> Mtime.t -> exit -(** [await_timeout t k time] adds [time, k] to the timer. - - When [time] is reached, [k] is resumed. Cancelling [k] removes the entry from the timer. *) - -val enter : string -> (t -> 'a Eio_utils.Suspended.t -> exit) -> 'a -(** [enter op fn] suspends the current fiber and runs [fn t k] in the scheduler's context. - - [fn] should either resume [k] immediately itself, or call one of the [await_*] functions above. - - [op] is used when tracing. *) +(** The scheduler keeps track of all suspended fibers and resumes them as appropriate. + + Each Eio domain has one scheduler, which keeps a queue of runnable + processes plus a record of all fibers waiting for IO operations to complete. *) + +type t + +type exit +(** This is equivalent to [unit], but indicates that a function returning this will call {!next} + and so does not return until the whole event loop is finished. Such functions should normally + be called in tail position. *) + +val with_sched : (t -> 'a) -> 'a +(** [with_sched fn] sets up a scheduler and calls [fn t]. + Typically [fn] will call {!run}. + When [fn] returns, the scheduler's resources are freed. *) + +val run : + extra_effects:exit Effect.Deep.effect_handler -> + t -> ('a -> 'b) -> 'a -> 'b [@@alert "-unstable"] +(** [run ~extra_effects t f x] starts an event loop using [t] and runs [f x] as the root fiber within it. + + Unknown effects are passed to [extra_effects]. *) + +val next : t -> exit +(** [next t] asks the scheduler to transfer control to the next runnable fiber, + or wait for an event from the OS if there is none. This should normally be + called in tail position from an effect handler. *) + +val await_readable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit +(** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for reading. *) + +val await_writable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit +(** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for writing. *) + +val await_timeout : t -> unit Eio_utils.Suspended.t -> Mtime.t -> exit +(** [await_timeout t k time] adds [time, k] to the timer. + + When [time] is reached, [k] is resumed. Cancelling [k] removes the entry from the timer. *) + +val enter : string -> (t -> 'a Eio_utils.Suspended.t -> exit) -> 'a +(** [enter op fn] suspends the current fiber and runs [fn t k] in the scheduler's context. + + [fn] should either resume [k] immediately itself, or call one of the [await_*] functions above. + + [op] is used when tracing. *) diff --git a/lib_eio_posix/test/dune b/lib_eio_posix/test/dune index 0fe02fffa..3d4c87dae 100644 --- a/lib_eio_posix/test/dune +++ b/lib_eio_posix/test/dune @@ -1,10 +1,10 @@ -(mdx - (package eio_posix) - (enabled_if (= %{os_type} "Unix")) - (deps (package eio_posix))) - -(tests - (names open_beneath test_await) - (package eio_posix) - (build_if (= %{os_type} "Unix")) - (libraries eio_posix)) +(mdx + (package eio_posix) + (enabled_if (= %{os_type} "Unix")) + (deps (package eio_posix))) + +(tests + (names open_beneath test_await) + (package eio_posix) + (build_if (= %{os_type} "Unix")) + (libraries eio_posix)) diff --git a/lib_eio_posix/test/open_beneath.ml b/lib_eio_posix/test/open_beneath.ml index 3b85adebf..365c726c1 100644 --- a/lib_eio_posix/test/open_beneath.ml +++ b/lib_eio_posix/test/open_beneath.ml @@ -1,91 +1,91 @@ -open Eio.Std - -let () = Printexc.record_backtrace true - -module L = Eio_posix.Low_level - -let check ~mode dirfd path flags = - Switch.run @@ fun sw -> - (* traceln "check %S" path; *) - let x = - let path = if path = "" then "." else path in - try Ok (L.Resolve.open_unconfined ~sw ~mode (Some dirfd) path flags) with Unix.Unix_error _ as e -> Error e in - let y = - Eio_unix.Fd.use_exn "check" dirfd @@ fun dirfd -> - try Ok (L.Resolve.open_beneath_fallback ~sw ~dirfd ~mode path flags) with Unix.Unix_error _ as e -> Error e - in - match x, y with - | Ok x, Ok y -> - let inode fd = - let buf = L.create_stat () in - L.fstat fd ~buf; - (L.dev buf, L.ino buf) - in - let x_info = inode x in - let y_info = inode y in - if x_info <> y_info then - Fmt.failwith "Got a different inode opening %S!" path - | Error (Unix.Unix_error (x, _, _) as e1), - Error (Unix.Unix_error (y, _, _) as e2) -> - if x <> y then ( - Fmt.failwith "Different errors: %a vs %a" Fmt.exn e1 Fmt.exn e2 - ) - | Error _, Error _ -> assert false - | Error e, Ok _ -> Fmt.failwith "Only OS open failed: %a" Fmt.exn e - | Ok _, Error e -> Fmt.failwith "Only open_beneath failed: %a" Fmt.exn e - -let test base path = - check ~mode:0 base path L.Open_flags.rdonly; - if path <> "" then ( - check ~mode:0 base (path ^ "/") L.Open_flags.rdonly; - check ~mode:0 base (path ^ "/.") L.Open_flags.rdonly - ) - -let test_denied base path = - match L.Open_flags.resolve_beneath with - | Some some_resolve_beneath -> - (* Check our behaviour matches the OS's *) - check ~mode:0 base path L.Open_flags.(rdonly + some_resolve_beneath) - | None -> - (* traceln "check-reject %S" path; *) - (* OS doesn't support resolve_beneath. Just check we reject it. *) - Switch.run @@ fun sw -> - Eio_unix.Fd.use_exn "check" base @@ fun base -> - match L.Resolve.open_beneath_fallback ~sw ~dirfd:base ~mode:0 path L.Open_flags.rdonly with - | (_fd : Eio_unix.Fd.t) -> Fmt.failwith "%S should have been rejected!" path - | exception Eio.Io (Eio.Fs.E Permission_denied _, _) -> () - -let () = - try - Eio_posix.run @@ fun env -> - Eio.Path.(rmtree ~missing_ok:true (Eio.Stdenv.cwd env / "test_beneath")); - Unix.mkdir "test_beneath" 0o700; - Unix.mkdir "test_beneath/subdir" 0o700; - Unix.symlink "subdir" "test_beneath/link_subdir"; - Unix.symlink ".." "test_beneath/link_subdir/parent"; - Unix.symlink ".." "test_beneath/parent"; - Unix.symlink "loop2" "test_beneath/loop1"; - Unix.symlink "loop1" "test_beneath/loop2"; - Unix.symlink "file" "test_beneath/to-file"; - Unix.symlink "file/" "test_beneath/to-file-slash"; - Unix.symlink "subdir/" "test_beneath/to-dir-slash"; - Switch.run @@ fun sw -> - let test_dir = L.Resolve.open_beneath_fallback ~sw "test_beneath" L.Open_flags.directory ~mode:0 in - let f = L.openat ~sw (Fd test_dir) "file" L.Open_flags.(creat + rdwr) ~mode:0o600 in - Eio_unix.Fd.close f; - test test_dir "file"; - test test_dir "subdir"; - test test_dir "link_subdir"; - test test_dir "link_subdir/parent"; - test_denied test_dir "link_subdir/parent/parent"; - test test_dir ""; - test test_dir "."; - test_denied test_dir ".."; - test test_dir "loop1"; - test test_dir "to-file"; - test test_dir "to-file-slash"; - test test_dir "to-dir-slash/file"; - with Failure msg -> - Printexc.print_backtrace stderr; - Fmt.epr "Tests failed: %s" msg; - exit 1 +open Eio.Std + +let () = Printexc.record_backtrace true + +module L = Eio_posix.Low_level + +let check ~mode dirfd path flags = + Switch.run @@ fun sw -> + (* traceln "check %S" path; *) + let x = + let path = if path = "" then "." else path in + try Ok (L.Resolve.open_unconfined ~sw ~mode (Some dirfd) path flags) with Unix.Unix_error _ as e -> Error e in + let y = + Eio_unix.Fd.use_exn "check" dirfd @@ fun dirfd -> + try Ok (L.Resolve.open_beneath_fallback ~sw ~dirfd ~mode path flags) with Unix.Unix_error _ as e -> Error e + in + match x, y with + | Ok x, Ok y -> + let inode fd = + let buf = L.create_stat () in + L.fstat fd ~buf; + (L.dev buf, L.ino buf) + in + let x_info = inode x in + let y_info = inode y in + if x_info <> y_info then + Fmt.failwith "Got a different inode opening %S!" path + | Error (Unix.Unix_error (x, _, _) as e1), + Error (Unix.Unix_error (y, _, _) as e2) -> + if x <> y then ( + Fmt.failwith "Different errors: %a vs %a" Fmt.exn e1 Fmt.exn e2 + ) + | Error _, Error _ -> assert false + | Error e, Ok _ -> Fmt.failwith "Only OS open failed: %a" Fmt.exn e + | Ok _, Error e -> Fmt.failwith "Only open_beneath failed: %a" Fmt.exn e + +let test base path = + check ~mode:0 base path L.Open_flags.rdonly; + if path <> "" then ( + check ~mode:0 base (path ^ "/") L.Open_flags.rdonly; + check ~mode:0 base (path ^ "/.") L.Open_flags.rdonly + ) + +let test_denied base path = + match L.Open_flags.resolve_beneath with + | Some some_resolve_beneath -> + (* Check our behaviour matches the OS's *) + check ~mode:0 base path L.Open_flags.(rdonly + some_resolve_beneath) + | None -> + (* traceln "check-reject %S" path; *) + (* OS doesn't support resolve_beneath. Just check we reject it. *) + Switch.run @@ fun sw -> + Eio_unix.Fd.use_exn "check" base @@ fun base -> + match L.Resolve.open_beneath_fallback ~sw ~dirfd:base ~mode:0 path L.Open_flags.rdonly with + | (_fd : Eio_unix.Fd.t) -> Fmt.failwith "%S should have been rejected!" path + | exception Eio.Io (Eio.Fs.E Permission_denied _, _) -> () + +let () = + try + Eio_posix.run @@ fun env -> + Eio.Path.(rmtree ~missing_ok:true (Eio.Stdenv.cwd env / "test_beneath")); + Unix.mkdir "test_beneath" 0o700; + Unix.mkdir "test_beneath/subdir" 0o700; + Unix.symlink "subdir" "test_beneath/link_subdir"; + Unix.symlink ".." "test_beneath/link_subdir/parent"; + Unix.symlink ".." "test_beneath/parent"; + Unix.symlink "loop2" "test_beneath/loop1"; + Unix.symlink "loop1" "test_beneath/loop2"; + Unix.symlink "file" "test_beneath/to-file"; + Unix.symlink "file/" "test_beneath/to-file-slash"; + Unix.symlink "subdir/" "test_beneath/to-dir-slash"; + Switch.run @@ fun sw -> + let test_dir = L.Resolve.open_beneath_fallback ~sw "test_beneath" L.Open_flags.directory ~mode:0 in + let f = L.openat ~sw (Fd test_dir) "file" L.Open_flags.(creat + rdwr) ~mode:0o600 in + Eio_unix.Fd.close f; + test test_dir "file"; + test test_dir "subdir"; + test test_dir "link_subdir"; + test test_dir "link_subdir/parent"; + test_denied test_dir "link_subdir/parent/parent"; + test test_dir ""; + test test_dir "."; + test_denied test_dir ".."; + test test_dir "loop1"; + test test_dir "to-file"; + test test_dir "to-file-slash"; + test test_dir "to-dir-slash/file"; + with Failure msg -> + Printexc.print_backtrace stderr; + Fmt.epr "Tests failed: %s" msg; + exit 1 diff --git a/lib_eio_posix/test/path.md b/lib_eio_posix/test/path.md index 791660511..3a641c3d3 100644 --- a/lib_eio_posix/test/path.md +++ b/lib_eio_posix/test/path.md @@ -1,58 +1,58 @@ -```ocaml -# #require "eio_posix" -``` -```ocaml -module P = Eio_posix__Path - -let dump f p = - Fmt.pf f "%a (%S)" P.dump p (P.to_string p) -``` - -```ocaml -# #install_printer dump;; - -# P.parse "foo" -- : P.t = "foo" ("foo") - -# P.parse "foo/bar" -- : P.t = "foo" / "bar" ("foo/bar") - -# P.parse "foo//bar/" -- : P.t = "foo" / "bar" / ("foo/bar/") - -# P.parse "foo/." -- : P.t = "foo" / ("foo/") - -# P.parse "foo/./" -- : P.t = "foo" / ("foo/") - -# P.parse "" -- : P.t = . (".") - -# P.parse "." -- : P.t = . (".") - -# P.parse ".." -- : P.t = .. / . ("..") - -# P.parse "./../.././.." -- : P.t = .. / .. / .. / . ("../../..") - -# P.parse "/" -- : P.t = / . ("/") - -# P.parse "/etc" -- : P.t = / "etc" ("/etc") - -# P.parse "/etc/passwd" -- : P.t = / "etc" / "passwd" ("/etc/passwd") - -# P.parse "/." -- : P.t = / . ("/") - -# P.parse "/.." -- : P.t = / .. / . ("/..") - -# P.parse "//../" -- : P.t = / .. / . ("/..") -``` +```ocaml +# #require "eio_posix" +``` +```ocaml +module P = Eio_posix__Path + +let dump f p = + Fmt.pf f "%a (%S)" P.dump p (P.to_string p) +``` + +```ocaml +# #install_printer dump;; + +# P.parse "foo" +- : P.t = "foo" ("foo") + +# P.parse "foo/bar" +- : P.t = "foo" / "bar" ("foo/bar") + +# P.parse "foo//bar/" +- : P.t = "foo" / "bar" / ("foo/bar/") + +# P.parse "foo/." +- : P.t = "foo" / ("foo/") + +# P.parse "foo/./" +- : P.t = "foo" / ("foo/") + +# P.parse "" +- : P.t = . (".") + +# P.parse "." +- : P.t = . (".") + +# P.parse ".." +- : P.t = .. / . ("..") + +# P.parse "./../.././.." +- : P.t = .. / .. / .. / . ("../../..") + +# P.parse "/" +- : P.t = / . ("/") + +# P.parse "/etc" +- : P.t = / "etc" ("/etc") + +# P.parse "/etc/passwd" +- : P.t = / "etc" / "passwd" ("/etc/passwd") + +# P.parse "/." +- : P.t = / . ("/") + +# P.parse "/.." +- : P.t = / .. / . ("/..") + +# P.parse "//../" +- : P.t = / .. / . ("/..") +``` diff --git a/lib_eio_posix/test/poll.md b/lib_eio_posix/test/poll.md index 80aea8567..6620e949d 100644 --- a/lib_eio_posix/test/poll.md +++ b/lib_eio_posix/test/poll.md @@ -1,29 +1,29 @@ -```ocaml -# #require "eio_posix";; -``` - -```ocaml -open Eio.Std -``` - -## Closing an FD removes it from the multiplexer - -Closing an FD automatically removes it from epoll's set, meaning that you have -to re-add it using `EPOLL_CTL_ADD`, not `EPOLL_CTL_MOD`. - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run (fun sw -> - let r, w = Eio_unix.pipe sw in - Eio_unix.Fd.use_exn "await_writable" (Eio_unix.Resource.fd w) @@ fun fd -> - Eio_unix.await_writable fd - ); - (* [r] and [w] are now closed. We'll likely allocate the same FD numbers the second time. - Check we don't get confused and try to [EPOLL_CTL_MOD] them. *) - Switch.run (fun sw -> - let r, w = Eio_unix.pipe sw in - Eio_unix.Fd.use_exn "await_writable" (Eio_unix.Resource.fd w) @@ fun fd -> - Eio_unix.await_writable fd - );; -- : unit = () -``` +```ocaml +# #require "eio_posix";; +``` + +```ocaml +open Eio.Std +``` + +## Closing an FD removes it from the multiplexer + +Closing an FD automatically removes it from epoll's set, meaning that you have +to re-add it using `EPOLL_CTL_ADD`, not `EPOLL_CTL_MOD`. + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run (fun sw -> + let r, w = Eio_unix.pipe sw in + Eio_unix.Fd.use_exn "await_writable" (Eio_unix.Resource.fd w) @@ fun fd -> + Eio_unix.await_writable fd + ); + (* [r] and [w] are now closed. We'll likely allocate the same FD numbers the second time. + Check we don't get confused and try to [EPOLL_CTL_MOD] them. *) + Switch.run (fun sw -> + let r, w = Eio_unix.pipe sw in + Eio_unix.Fd.use_exn "await_writable" (Eio_unix.Resource.fd w) @@ fun fd -> + Eio_unix.await_writable fd + );; +- : unit = () +``` diff --git a/lib_eio_posix/test/spawn.md b/lib_eio_posix/test/spawn.md index dc41a114b..1d4757139 100644 --- a/lib_eio_posix/test/spawn.md +++ b/lib_eio_posix/test/spawn.md @@ -1,232 +1,232 @@ -```ocaml -# #require "eio_posix";; -``` - -```ocaml -open Eio.Std - -module Process = Eio_posix.Low_level.Process -``` - -## Spawning processes - -Setting environment variables: - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = Process.spawn ~sw Process.Fork_action.[ - execve "/usr/bin/env" - ~argv:[| "env" |] - ~env:[| "FOO=bar" |]; - ] in - Promise.await (Process.exit_status child);; -FOO=bar -- : Unix.process_status = Unix.WEXITED 0 -``` - -Changing directory: - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = Process.spawn ~sw Process.Fork_action.[ - chdir "/"; - execve "/usr/bin/env" - ~argv:[| "env"; "pwd" |] - ~env:(Unix.environment ()) - ] in - Promise.await (Process.exit_status child);; -/ -- : Unix.process_status = Unix.WEXITED 0 -``` - -Changing directory using a file descriptor: - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - let root = Eio_posix.Low_level.openat ~sw ~mode:0 Fs "/" Eio_posix.Low_level.Open_flags.(rdonly + directory) in - let child = Process.spawn ~sw Process.Fork_action.[ - fchdir root; - execve "/usr/bin/env" - ~argv:[| "env"; "pwd" |] - ~env:(Unix.environment ()) - ] in - Promise.await (Process.exit_status child);; -/ -- : Unix.process_status = Unix.WEXITED 0 -``` - -Exit status: - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = Process.spawn ~sw Process.Fork_action.[ - execve "/usr/bin/env" - ~argv:[| "env"; "false" |] - ~env:(Unix.environment ()) - ] in - Promise.await (Process.exit_status child);; -- : Unix.process_status = Unix.WEXITED 1 -``` - -Failure starting child: - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - try - let _child = - Process.spawn ~sw Process.Fork_action.[ - chdir "/idontexist"; - execve "/usr/bin/env" - ~argv:[| "env"; "pwd" |] - ~env:(Unix.environment ()) - ] - in - assert false - with Failure ex -> - String.sub ex 0 7 -- : string = "chdir: " -``` - -Signalling a running child: - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = - Process.spawn ~sw Process.Fork_action.[ - execve "/usr/bin/env" - ~argv:[| "env"; "sleep"; "1000" |] - ~env:(Unix.environment ()) - ] - in - Process.signal child Sys.sigkill; - match Promise.await (Process.exit_status child) with - | Unix.WSIGNALED x when x = Sys.sigkill -> traceln "Child got SIGKILL" - | _ -> assert false;; -+Child got SIGKILL -- : unit = () -``` - -Signalling an exited child does nothing: - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - let child = - Process.spawn ~sw Process.Fork_action.[ - execve "/usr/bin/env" - ~argv:[| "env" |] - ~env:[| "FOO=bar" |]; - ] - in - ignore (Promise.await (Process.exit_status child) : Unix.process_status); - Process.signal child Sys.sigkill;; -FOO=bar -- : unit = () -``` - -Inheriting file descriptors: - -```ocaml -let fd flow = Eio_unix.Resource.fd flow -let int_of_fd : Unix.file_descr -> int = Obj.magic -let id flow = Eio_unix.Fd.use_exn "id" (fd flow) int_of_fd -let read_all pipe = - let r = Eio.Buf_read.of_flow pipe ~max_size:1024 in - Eio.Buf_read.take_all r -``` - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - let pipe_r, pipe_w = Eio_unix.pipe sw in - let child = - Process.spawn ~sw Process.Fork_action.[ - inherit_fds [ - 1, fd pipe_w, `Blocking; - ]; - execve "/usr/bin/env" - ~argv:[| "env" |] - ~env:[| "FOO=bar" |]; - ] - in - Eio.Flow.close pipe_w; - let r = Eio.Buf_read.of_flow pipe_r ~max_size:1024 in - traceln "Read: %S" (Eio.Buf_read.take_all r); - Promise.await (Process.exit_status child);; -+Read: "FOO=bar\n" -- : Unix.process_status = Unix.WEXITED 0 -``` - -Swapping FDs (note: plain sh can't handle multi-digit FDs!): - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - let pipe1_r, pipe1_w = Eio_unix.pipe sw in - let pipe2_r, pipe2_w = Eio_unix.pipe sw in - let pipe3_r, pipe3_w = Eio_unix.pipe sw in - let pipe4_r, pipe4_w = Eio_unix.pipe sw in - let child = - Process.spawn ~sw Process.Fork_action.[ - inherit_fds [ - id pipe1_w, fd pipe2_w, `Blocking; - id pipe2_w, fd pipe1_w, `Blocking; - id pipe3_w, fd pipe4_w, `Blocking; - id pipe4_w, fd pipe3_w, `Blocking; - ]; - execve "/usr/bin/env" - ~argv:[| - "env"; "bash"; "-c"; - Printf.sprintf "echo one >&%d; echo two >&%d; echo three >&%d; echo four >&%d" - (id pipe1_w) - (id pipe2_w) - (id pipe3_w) - (id pipe4_w) - |] - ~env:(Unix.environment ()) - ] - in - Eio.Flow.close pipe1_w; - Eio.Flow.close pipe2_w; - Eio.Flow.close pipe3_w; - Eio.Flow.close pipe4_w; - traceln "Pipe1: %S" (read_all pipe1_r); - traceln "Pipe2: %S" (read_all pipe2_r); - traceln "Pipe3: %S" (read_all pipe3_r); - traceln "Pipe4: %S" (read_all pipe4_r); - Promise.await (Process.exit_status child);; -+Pipe1: "two\n" -+Pipe2: "one\n" -+Pipe3: "four\n" -+Pipe4: "three\n" -- : Unix.process_status = Unix.WEXITED 0 -``` - -Keeping an FD open: - -```ocaml -# Eio_posix.run @@ fun _env -> - Switch.run @@ fun sw -> - let pipe1_r, pipe1_w = Eio_unix.pipe sw in - let child = - Process.spawn ~sw Process.Fork_action.[ - inherit_fds [ - id pipe1_w, fd pipe1_w, `Blocking; - ]; - execve "/usr/bin/env" - ~argv:[| "env"; "bash"; "-c"; Printf.sprintf "echo one >&%d" (id pipe1_w) |] - ~env:(Unix.environment ()) - ] - in - Eio.Flow.close pipe1_w; - traceln "Pipe1: %S" (read_all pipe1_r); - Promise.await (Process.exit_status child);; -+Pipe1: "one\n" -- : Unix.process_status = Unix.WEXITED 0 -``` +```ocaml +# #require "eio_posix";; +``` + +```ocaml +open Eio.Std + +module Process = Eio_posix.Low_level.Process +``` + +## Spawning processes + +Setting environment variables: + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = Process.spawn ~sw Process.Fork_action.[ + execve "/usr/bin/env" + ~argv:[| "env" |] + ~env:[| "FOO=bar" |]; + ] in + Promise.await (Process.exit_status child);; +FOO=bar +- : Unix.process_status = Unix.WEXITED 0 +``` + +Changing directory: + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = Process.spawn ~sw Process.Fork_action.[ + chdir "/"; + execve "/usr/bin/env" + ~argv:[| "env"; "pwd" |] + ~env:(Unix.environment ()) + ] in + Promise.await (Process.exit_status child);; +/ +- : Unix.process_status = Unix.WEXITED 0 +``` + +Changing directory using a file descriptor: + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let root = Eio_posix.Low_level.openat ~sw ~mode:0 Fs "/" Eio_posix.Low_level.Open_flags.(rdonly + directory) in + let child = Process.spawn ~sw Process.Fork_action.[ + fchdir root; + execve "/usr/bin/env" + ~argv:[| "env"; "pwd" |] + ~env:(Unix.environment ()) + ] in + Promise.await (Process.exit_status child);; +/ +- : Unix.process_status = Unix.WEXITED 0 +``` + +Exit status: + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = Process.spawn ~sw Process.Fork_action.[ + execve "/usr/bin/env" + ~argv:[| "env"; "false" |] + ~env:(Unix.environment ()) + ] in + Promise.await (Process.exit_status child);; +- : Unix.process_status = Unix.WEXITED 1 +``` + +Failure starting child: + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + try + let _child = + Process.spawn ~sw Process.Fork_action.[ + chdir "/idontexist"; + execve "/usr/bin/env" + ~argv:[| "env"; "pwd" |] + ~env:(Unix.environment ()) + ] + in + assert false + with Failure ex -> + String.sub ex 0 7 +- : string = "chdir: " +``` + +Signalling a running child: + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = + Process.spawn ~sw Process.Fork_action.[ + execve "/usr/bin/env" + ~argv:[| "env"; "sleep"; "1000" |] + ~env:(Unix.environment ()) + ] + in + Process.signal child Sys.sigkill; + match Promise.await (Process.exit_status child) with + | Unix.WSIGNALED x when x = Sys.sigkill -> traceln "Child got SIGKILL" + | _ -> assert false;; ++Child got SIGKILL +- : unit = () +``` + +Signalling an exited child does nothing: + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let child = + Process.spawn ~sw Process.Fork_action.[ + execve "/usr/bin/env" + ~argv:[| "env" |] + ~env:[| "FOO=bar" |]; + ] + in + ignore (Promise.await (Process.exit_status child) : Unix.process_status); + Process.signal child Sys.sigkill;; +FOO=bar +- : unit = () +``` + +Inheriting file descriptors: + +```ocaml +let fd flow = Eio_unix.Resource.fd flow +let int_of_fd : Unix.file_descr -> int = Obj.magic +let id flow = Eio_unix.Fd.use_exn "id" (fd flow) int_of_fd +let read_all pipe = + let r = Eio.Buf_read.of_flow pipe ~max_size:1024 in + Eio.Buf_read.take_all r +``` + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let pipe_r, pipe_w = Eio_unix.pipe sw in + let child = + Process.spawn ~sw Process.Fork_action.[ + inherit_fds [ + 1, fd pipe_w, `Blocking; + ]; + execve "/usr/bin/env" + ~argv:[| "env" |] + ~env:[| "FOO=bar" |]; + ] + in + Eio.Flow.close pipe_w; + let r = Eio.Buf_read.of_flow pipe_r ~max_size:1024 in + traceln "Read: %S" (Eio.Buf_read.take_all r); + Promise.await (Process.exit_status child);; ++Read: "FOO=bar\n" +- : Unix.process_status = Unix.WEXITED 0 +``` + +Swapping FDs (note: plain sh can't handle multi-digit FDs!): + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let pipe1_r, pipe1_w = Eio_unix.pipe sw in + let pipe2_r, pipe2_w = Eio_unix.pipe sw in + let pipe3_r, pipe3_w = Eio_unix.pipe sw in + let pipe4_r, pipe4_w = Eio_unix.pipe sw in + let child = + Process.spawn ~sw Process.Fork_action.[ + inherit_fds [ + id pipe1_w, fd pipe2_w, `Blocking; + id pipe2_w, fd pipe1_w, `Blocking; + id pipe3_w, fd pipe4_w, `Blocking; + id pipe4_w, fd pipe3_w, `Blocking; + ]; + execve "/usr/bin/env" + ~argv:[| + "env"; "bash"; "-c"; + Printf.sprintf "echo one >&%d; echo two >&%d; echo three >&%d; echo four >&%d" + (id pipe1_w) + (id pipe2_w) + (id pipe3_w) + (id pipe4_w) + |] + ~env:(Unix.environment ()) + ] + in + Eio.Flow.close pipe1_w; + Eio.Flow.close pipe2_w; + Eio.Flow.close pipe3_w; + Eio.Flow.close pipe4_w; + traceln "Pipe1: %S" (read_all pipe1_r); + traceln "Pipe2: %S" (read_all pipe2_r); + traceln "Pipe3: %S" (read_all pipe3_r); + traceln "Pipe4: %S" (read_all pipe4_r); + Promise.await (Process.exit_status child);; ++Pipe1: "two\n" ++Pipe2: "one\n" ++Pipe3: "four\n" ++Pipe4: "three\n" +- : Unix.process_status = Unix.WEXITED 0 +``` + +Keeping an FD open: + +```ocaml +# Eio_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let pipe1_r, pipe1_w = Eio_unix.pipe sw in + let child = + Process.spawn ~sw Process.Fork_action.[ + inherit_fds [ + id pipe1_w, fd pipe1_w, `Blocking; + ]; + execve "/usr/bin/env" + ~argv:[| "env"; "bash"; "-c"; Printf.sprintf "echo one >&%d" (id pipe1_w) |] + ~env:(Unix.environment ()) + ] + in + Eio.Flow.close pipe1_w; + traceln "Pipe1: %S" (read_all pipe1_r); + Promise.await (Process.exit_status child);; ++Pipe1: "one\n" +- : Unix.process_status = Unix.WEXITED 0 +``` diff --git a/lib_eio_posix/test/test_await.ml b/lib_eio_posix/test/test_await.ml index d5533e631..81aa9a742 100644 --- a/lib_eio_posix/test/test_await.ml +++ b/lib_eio_posix/test/test_await.ml @@ -1,25 +1,25 @@ -open Eio.Std - -let () = - Eio_posix.run @@ fun _ -> - let a, b = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in - (* Start awaiting readable/writable state, but cancel immediately. *) - try - Eio.Cancel.sub (fun cc -> - Fiber.all [ - (fun () -> Eio_unix.await_readable a); - (fun () -> Eio_unix.await_writable b); - (fun () -> Eio.Cancel.cancel cc Exit); - ]; - assert false - ) - with Eio.Cancel.Cancelled _ -> - (* Now wait for something else. Will fail if the old FDs are still being waited on. *) - let c, d = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in - Unix.close a; - Unix.close b; - Fiber.first - (fun () -> Eio_unix.await_readable c) - (fun () -> Eio_unix.await_writable d); - Unix.close c; - Unix.close d +open Eio.Std + +let () = + Eio_posix.run @@ fun _ -> + let a, b = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in + (* Start awaiting readable/writable state, but cancel immediately. *) + try + Eio.Cancel.sub (fun cc -> + Fiber.all [ + (fun () -> Eio_unix.await_readable a); + (fun () -> Eio_unix.await_writable b); + (fun () -> Eio.Cancel.cancel cc Exit); + ]; + assert false + ) + with Eio.Cancel.Cancelled _ -> + (* Now wait for something else. Will fail if the old FDs are still being waited on. *) + let c, d = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in + Unix.close a; + Unix.close b; + Fiber.first + (fun () -> Eio_unix.await_readable c) + (fun () -> Eio_unix.await_writable d); + Unix.close c; + Unix.close d diff --git a/lib_eio_posix/time.ml b/lib_eio_posix/time.ml index 9e07c3956..c0595d53c 100644 --- a/lib_eio_posix/time.ml +++ b/lib_eio_posix/time.ml @@ -1,30 +1,30 @@ -open Eio.Std - -module Mono_clock = struct - type t = unit - type time = Mtime.t - - let now () = Mtime_clock.now () - let sleep_until () time = Low_level.sleep_until time -end - -let mono_clock : Mtime.t Eio.Time.clock_ty r = - let handler = Eio.Time.Pi.clock (module Mono_clock) in - Eio.Resource.T ((), handler) - -module Clock = struct - type t = unit - type time = float - - let now () = Unix.gettimeofday () - - let sleep_until () time = - (* todo: use the realtime clock directly instead of converting to monotonic time. - That is needed to handle adjustments to the system clock correctly. *) - let d = time -. Unix.gettimeofday () in - Eio.Time.Mono.sleep mono_clock d -end - -let clock : float Eio.Time.clock_ty r = - let handler = Eio.Time.Pi.clock (module Clock) in - Eio.Resource.T ((), handler) +open Eio.Std + +module Mono_clock = struct + type t = unit + type time = Mtime.t + + let now () = Mtime_clock.now () + let sleep_until () time = Low_level.sleep_until time +end + +let mono_clock : Mtime.t Eio.Time.clock_ty r = + let handler = Eio.Time.Pi.clock (module Mono_clock) in + Eio.Resource.T ((), handler) + +module Clock = struct + type t = unit + type time = float + + let now () = Unix.gettimeofday () + + let sleep_until () time = + (* todo: use the realtime clock directly instead of converting to monotonic time. + That is needed to handle adjustments to the system clock correctly. *) + let d = time -. Unix.gettimeofday () in + Eio.Time.Mono.sleep mono_clock d +end + +let clock : float Eio.Time.clock_ty r = + let handler = Eio.Time.Pi.clock (module Clock) in + Eio.Resource.T ((), handler) diff --git a/lib_eio_windows/domain_mgr.ml b/lib_eio_windows/domain_mgr.ml index 24f036b31..9373b6c04 100755 --- a/lib_eio_windows/domain_mgr.ml +++ b/lib_eio_windows/domain_mgr.ml @@ -1,120 +1,120 @@ -(* - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Eio.Std - -[@@@alert "-unstable"] - -module Fd = Eio_unix.Fd - -let socketpair k ~sw ~domain ~ty ~protocol wrap_a wrap_b = - let open Effect.Deep in - match - let unix_a, unix_b = Unix.socketpair ~cloexec:true domain ty protocol in - let a = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_a in - let b = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_b in - Unix.set_nonblock unix_a; - Unix.set_nonblock unix_b; - (wrap_a a, wrap_b b) - with - | r -> continue k r - | exception Unix.Unix_error (code, name, arg) -> - discontinue k (Err.wrap code name arg) - -(* Run an event loop in the current domain, using [fn x] as the root fiber. *) -let run_event_loop fn x = - Sched.with_sched @@ fun sched -> - let open Effect.Deep in - let extra_effects : _ effect_handler = { - effc = fun (type a) (e : a Effect.t) : ((a, Sched.exit) continuation -> Sched.exit) option -> - match e with - | Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k Time.mono_clock) - | Eio_unix.Net.Import_socket_stream (sw, close_unix, unix_fd) -> Some (fun k -> - let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in - (* TODO: On Windows, if the FD from Unix.pipe () is passed this will fail *) - (try Unix.set_nonblock unix_fd with Unix.Unix_error (Unix.ENOTSOCK, _, _) -> ()); - continue k (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) - ) - | Eio_unix.Net.Import_socket_listening (sw, close_unix, unix_fd) -> Some (fun k -> - let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in - Unix.set_nonblock unix_fd; - continue k (Net.listening_socket ~hook:Switch.null_hook fd) - ) - | Eio_unix.Net.Import_socket_datagram (sw, close_unix, unix_fd) -> Some (fun k -> - let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in - Unix.set_nonblock unix_fd; - continue k (Net.datagram_socket fd) - ) - | Eio_unix.Net.Socketpair_stream (sw, domain, protocol) -> Some (fun k -> - let wrap fd = (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) in - socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_STREAM wrap wrap - ) - | Eio_unix.Net.Socketpair_datagram (sw, domain, protocol) -> Some (fun k -> - let wrap fd = Net.datagram_socket fd in - socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_DGRAM wrap wrap - ) - | Eio_unix.Private.Pipe sw -> Some (fun k -> - match - let r, w = Low_level.pipe ~sw in - let source = Flow.of_fd r in - let sink = Flow.of_fd w in - (source, sink) - with - | r -> continue k r - | exception Unix.Unix_error (code, name, arg) -> - discontinue k (Err.wrap code name arg) - ) - | _ -> None - } - in - Sched.run ~extra_effects sched fn x - -let wrap_backtrace fn x = - match fn x with - | x -> Ok x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - Error (ex, bt) - -let unwrap_backtrace = function - | Ok x -> x - | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt - -module Impl = struct - type t = unit - - let run_raw () fn = - let domain = ref None in - Eio.Private.Suspend.enter "run-domain" (fun _ctx enqueue -> - domain := Some (Domain.spawn (fun () -> Fun.protect (wrap_backtrace fn) ~finally:(fun () -> enqueue (Ok ())))) - ); - unwrap_backtrace (Domain.join (Option.get !domain)) - - let run () fn = - let domain = ref None in - Eio.Private.Suspend.enter "run-domain" (fun ctx enqueue -> - let cancelled, set_cancelled = Promise.create () in - Eio.Private.Fiber_context.set_cancel_fn ctx (Promise.resolve set_cancelled); - domain := Some (Domain.spawn (fun () -> - Fun.protect (run_event_loop (wrap_backtrace (fun () -> fn ~cancelled))) - ~finally:(fun () -> enqueue (Ok ())))) - ); - unwrap_backtrace (Domain.join (Option.get !domain)) -end - -let v = - let handler = Eio.Domain_manager.Pi.mgr (module Impl) in - Eio.Resource.T ((), handler) +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Eio.Std + +[@@@alert "-unstable"] + +module Fd = Eio_unix.Fd + +let socketpair k ~sw ~domain ~ty ~protocol wrap_a wrap_b = + let open Effect.Deep in + match + let unix_a, unix_b = Unix.socketpair ~cloexec:true domain ty protocol in + let a = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_a in + let b = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_b in + Unix.set_nonblock unix_a; + Unix.set_nonblock unix_b; + (wrap_a a, wrap_b b) + with + | r -> continue k r + | exception Unix.Unix_error (code, name, arg) -> + discontinue k (Err.wrap code name arg) + +(* Run an event loop in the current domain, using [fn x] as the root fiber. *) +let run_event_loop fn x = + Sched.with_sched @@ fun sched -> + let open Effect.Deep in + let extra_effects : _ effect_handler = { + effc = fun (type a) (e : a Effect.t) : ((a, Sched.exit) continuation -> Sched.exit) option -> + match e with + | Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k Time.mono_clock) + | Eio_unix.Net.Import_socket_stream (sw, close_unix, unix_fd) -> Some (fun k -> + let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in + (* TODO: On Windows, if the FD from Unix.pipe () is passed this will fail *) + (try Unix.set_nonblock unix_fd with Unix.Unix_error (Unix.ENOTSOCK, _, _) -> ()); + continue k (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) + ) + | Eio_unix.Net.Import_socket_listening (sw, close_unix, unix_fd) -> Some (fun k -> + let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in + Unix.set_nonblock unix_fd; + continue k (Net.listening_socket ~hook:Switch.null_hook fd) + ) + | Eio_unix.Net.Import_socket_datagram (sw, close_unix, unix_fd) -> Some (fun k -> + let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in + Unix.set_nonblock unix_fd; + continue k (Net.datagram_socket fd) + ) + | Eio_unix.Net.Socketpair_stream (sw, domain, protocol) -> Some (fun k -> + let wrap fd = (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) in + socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_STREAM wrap wrap + ) + | Eio_unix.Net.Socketpair_datagram (sw, domain, protocol) -> Some (fun k -> + let wrap fd = Net.datagram_socket fd in + socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_DGRAM wrap wrap + ) + | Eio_unix.Private.Pipe sw -> Some (fun k -> + match + let r, w = Low_level.pipe ~sw in + let source = Flow.of_fd r in + let sink = Flow.of_fd w in + (source, sink) + with + | r -> continue k r + | exception Unix.Unix_error (code, name, arg) -> + discontinue k (Err.wrap code name arg) + ) + | _ -> None + } + in + Sched.run ~extra_effects sched fn x + +let wrap_backtrace fn x = + match fn x with + | x -> Ok x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + Error (ex, bt) + +let unwrap_backtrace = function + | Ok x -> x + | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt + +module Impl = struct + type t = unit + + let run_raw () fn = + let domain = ref None in + Eio.Private.Suspend.enter "run-domain" (fun _ctx enqueue -> + domain := Some (Domain.spawn (fun () -> Fun.protect (wrap_backtrace fn) ~finally:(fun () -> enqueue (Ok ())))) + ); + unwrap_backtrace (Domain.join (Option.get !domain)) + + let run () fn = + let domain = ref None in + Eio.Private.Suspend.enter "run-domain" (fun ctx enqueue -> + let cancelled, set_cancelled = Promise.create () in + Eio.Private.Fiber_context.set_cancel_fn ctx (Promise.resolve set_cancelled); + domain := Some (Domain.spawn (fun () -> + Fun.protect (run_event_loop (wrap_backtrace (fun () -> fn ~cancelled))) + ~finally:(fun () -> enqueue (Ok ())))) + ); + unwrap_backtrace (Domain.join (Option.get !domain)) +end + +let v = + let handler = Eio.Domain_manager.Pi.mgr (module Impl) in + Eio.Resource.T ((), handler) diff --git a/lib_eio_windows/dune b/lib_eio_windows/dune index 879134229..8951d920a 100644 --- a/lib_eio_windows/dune +++ b/lib_eio_windows/dune @@ -1,16 +1,16 @@ -(library - (name eio_windows) - (public_name eio_windows) - (library_flags :standard -cclib -lbcrypt -cclib -lntdll) - (enabled_if (= %{os_type} "Win32")) - (foreign_stubs - (language c) - (include_dirs ../lib_eio/unix/include) - (names eio_windows_stubs eio_windows_cstruct_stubs)) - (c_library_flags :standard -lbcrypt -lntdll) - (libraries eio eio.unix eio.utils fmt)) - -(rule - (targets config.ml) - (enabled_if (= %{os_type} "Win32")) - (action (run ./include/discover.exe))) +(library + (name eio_windows) + (public_name eio_windows) + (library_flags :standard -cclib -lbcrypt -cclib -lntdll) + (enabled_if (= %{os_type} "Win32")) + (foreign_stubs + (language c) + (include_dirs ../lib_eio/unix/include) + (names eio_windows_stubs eio_windows_cstruct_stubs)) + (c_library_flags :standard -lbcrypt -lntdll) + (libraries eio eio.unix eio.utils fmt)) + +(rule + (targets config.ml) + (enabled_if (= %{os_type} "Win32")) + (action (run ./include/discover.exe))) diff --git a/lib_eio_windows/eio_windows.ml b/lib_eio_windows/eio_windows.ml index 254668efd..c53385bc2 100755 --- a/lib_eio_windows/eio_windows.ml +++ b/lib_eio_windows/eio_windows.ml @@ -1,39 +1,39 @@ -(* - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -module Low_level = Low_level - -type stdenv = Eio_unix.Stdenv.base - -let run main = - let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> _ Eio_unix.source) in - let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> _ Eio_unix.sink) in - let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> _ Eio_unix.sink) in - Domain_mgr.run_event_loop main @@ object (_ : stdenv) - method stdin = stdin - method stdout = stdout - method stderr = stderr - method debug = Eio.Private.Debug.v - method clock = Time.clock - method mono_clock = Time.mono_clock - method net = Net.v - method domain_mgr = Domain_mgr.v - method cwd = ((Fs.cwd, "") :> Eio.Fs.dir_ty Eio.Path.t) - method fs = ((Fs.fs, "") :> Eio.Fs.dir_ty Eio.Path.t) - method process_mgr = failwith "process operations not supported on Windows yet" - method secure_random = Flow.secure_random - method backend_id = "windows" - end +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Low_level = Low_level + +type stdenv = Eio_unix.Stdenv.base + +let run main = + let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> _ Eio_unix.source) in + let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> _ Eio_unix.sink) in + let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> _ Eio_unix.sink) in + Domain_mgr.run_event_loop main @@ object (_ : stdenv) + method stdin = stdin + method stdout = stdout + method stderr = stderr + method debug = Eio.Private.Debug.v + method clock = Time.clock + method mono_clock = Time.mono_clock + method net = Net.v + method domain_mgr = Domain_mgr.v + method cwd = ((Fs.cwd, "") :> Eio.Fs.dir_ty Eio.Path.t) + method fs = ((Fs.fs, "") :> Eio.Fs.dir_ty Eio.Path.t) + method process_mgr = failwith "process operations not supported on Windows yet" + method secure_random = Flow.secure_random + method backend_id = "windows" + end diff --git a/lib_eio_windows/eio_windows.mli b/lib_eio_windows/eio_windows.mli index 408c3c902..8e4c9e9c4 100755 --- a/lib_eio_windows/eio_windows.mli +++ b/lib_eio_windows/eio_windows.mli @@ -1,12 +1,12 @@ -(** Fallback Eio backend for Windows using OCaml's [Unix.select]. *) - -type stdenv = Eio_unix.Stdenv.base -(** An extended version of {!Eio.Stdenv.base} with some extra features available on Windows. *) - -val run : (stdenv -> 'a) -> 'a -(** [run main] runs an event loop and calls [main stdenv] inside it. - - For portable code, you should use {!Eio_main.run} instead, which will call this for you if appropriate. *) - -module Low_level = Low_level -(** Low-level API. *) +(** Fallback Eio backend for Windows using OCaml's [Unix.select]. *) + +type stdenv = Eio_unix.Stdenv.base +(** An extended version of {!Eio.Stdenv.base} with some extra features available on Windows. *) + +val run : (stdenv -> 'a) -> 'a +(** [run main] runs an event loop and calls [main stdenv] inside it. + + For portable code, you should use {!Eio_main.run} instead, which will call this for you if appropriate. *) + +module Low_level = Low_level +(** Low-level API. *) diff --git a/lib_eio_windows/eio_windows_stubs.c b/lib_eio_windows/eio_windows_stubs.c index 4e26e21c5..680858e62 100755 --- a/lib_eio_windows/eio_windows_stubs.c +++ b/lib_eio_windows/eio_windows_stubs.c @@ -1,263 +1,263 @@ -#define _FILE_OFFSET_BITS 64 - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -typedef ULONG (__stdcall *pNtCreateFile)( - PHANDLE FileHandle, - ULONG DesiredAccess, - PVOID ObjectAttributes, - PVOID IoStatusBlock, - PLARGE_INTEGER AllocationSize, - ULONG FileAttributes, - ULONG ShareAccess, - ULONG CreateDisposition, - ULONG CreateOptions, - PVOID EaBuffer, - ULONG EaLength - ); - -#include -#include -#include -#include -#include -#include - -#ifdef ARCH_SIXTYFOUR -#define Int63_val(v) Long_val(v) -#else -#define Int63_val(v) (Int64_val(v)) >> 1 -#endif - -static void caml_stat_free_preserving_errno(void *ptr) -{ - int saved = errno; - caml_stat_free(ptr); - errno = saved; -} - -CAMLprim value caml_eio_windows_getrandom(value v_ba, value v_off, value v_len) -{ - CAMLparam1(v_ba); - ssize_t ret; - ssize_t off = (ssize_t)Long_val(v_off); - ssize_t len = (ssize_t)Long_val(v_len); - do - { - void *buf = (uint8_t *)Caml_ba_data_val(v_ba) + off; - caml_enter_blocking_section(); - ret = BCryptGenRandom(NULL, buf, len, BCRYPT_USE_SYSTEM_PREFERRED_RNG); - caml_leave_blocking_section(); - } while (errno == EINTR); - if (ret != STATUS_SUCCESS) - uerror("getrandom", Nothing); - CAMLreturn(Val_long(len)); -} - -CAMLprim value caml_eio_windows_readv(value v_fd, value v_bufs) -{ - uerror("readv is not supported on windows yet", Nothing); -} - -CAMLprim value caml_eio_windows_preadv(value v_fd, value v_bufs, value v_offset) -{ - uerror("preadv is not supported on windows yet", Nothing); -} - -CAMLprim value caml_eio_windows_pwritev(value v_fd, value v_bufs, value v_offset) -{ - uerror("pwritev is not supported on windows yet", Nothing); -} - -// File-system operations - -// No follow -void no_follow(HANDLE h) { - BY_HANDLE_FILE_INFORMATION b; - - if (!GetFileInformationByHandle(h, &b)) { - caml_win32_maperr(GetLastError()); - uerror("nofollow", Nothing); - } - - if (b.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT) { - CloseHandle(h); - caml_unix_error(ELOOP, "nofollow", Nothing); - } -} - -// We recreate an openat like function using NtCreateFile -CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_nofollow, value v_pathname, value v_desired_access, value v_create_disposition, value v_create_options) -{ - CAMLparam2(v_dirfd, v_pathname); - HANDLE h, dir; - OBJECT_ATTRIBUTES obj_attr; - IO_STATUS_BLOCK io_status; - wchar_t *pathname; - UNICODE_STRING relative; - NTSTATUS r; - - // Not sure what the overhead of this is, but it allows us to have low-level control - // over file creation. In particular, we can specify the HANDLE to the parent directory - // of a relative path a la openat. - pNtCreateFile NtCreatefile = (pNtCreateFile)GetProcAddress(GetModuleHandle("ntdll.dll"), "NtCreateFile"); - caml_unix_check_path(v_pathname, "openat"); - pathname = caml_stat_strdup_to_utf16(String_val(v_pathname)); - RtlInitUnicodeString(&relative, pathname); - - // If NULL the filepath has to be absolute - if (Is_some(v_dirfd)) { - dir = Handle_val(Field(v_dirfd, 0)); - } else { - dir = NULL; - } - - // Initialise object attributes, passing in the root directory FD - InitializeObjectAttributes( - &obj_attr, - &relative, - OBJ_CASE_INSENSITIVE, // TODO: Double-check what flags need to be passed at this point. - dir, - NULL - ); - - // Create the file - r = NtCreatefile( - &h, - Int_val(v_desired_access) | FILE_READ_ATTRIBUTES, - &obj_attr, - &io_status, - 0, // Allocation size - FILE_ATTRIBUTE_NORMAL, // TODO: Could check flags to see if we can do READONLY here a la OCaml - (FILE_SHARE_READ | FILE_SHARE_WRITE), - Int_val(v_create_disposition), - ( - FILE_SYNCHRONOUS_IO_NONALERT - | FILE_OPEN_FOR_BACKUP_INTENT - | (Bool_val(v_nofollow) ? FILE_FLAG_OPEN_REPARSE_POINT : Int_val(v_create_options))), - NULL, // Extended attribute buffer - 0 // Extended attribute buffer length - ); - - // Free the allocated pathname - caml_stat_free(pathname); - - if (h == INVALID_HANDLE_VALUE) { - caml_win32_maperr(RtlNtStatusToDosError(r)); - uerror("openat handle", v_pathname); - } - - if (!NT_SUCCESS(r)) { - caml_win32_maperr(RtlNtStatusToDosError(r)); - uerror("openat", Nothing); - } - - // No follow check -- Windows doesn't actually have that ability - // so we have to do it after the fact. This will raise if a symbolic - // link is encountered and will close the handle. - if (Bool_val(v_nofollow)) { - no_follow(h); - } - - CAMLreturn(caml_win32_alloc_handle(h)); -} - -value caml_eio_windows_openat_bytes(value* values, int argc) { - return caml_eio_windows_openat(values[0], values[1], values[2], values[3], values[4], values[5]); -} - -CAMLprim value caml_eio_windows_unlinkat(value v_dirfd, value v_pathname, value v_dir) -{ - CAMLparam2(v_dirfd, v_pathname); - HANDLE h, dir; - OBJECT_ATTRIBUTES obj_attr; - IO_STATUS_BLOCK io_status; - wchar_t *pathname; - UNICODE_STRING relative; - NTSTATUS r; - - // Not sure what the overhead of this is, but it allows us to have low-level control - // over file creation. In particular, we can specify the HANDLE to the parent directory - // of a relative path a la openat. - pNtCreateFile NtCreatefile = (pNtCreateFile)GetProcAddress(GetModuleHandle("ntdll.dll"), "NtCreateFile"); - caml_unix_check_path(v_pathname, "openat"); - pathname = caml_stat_strdup_to_utf16(String_val(v_pathname)); - RtlInitUnicodeString(&relative, pathname); - - // If NULL the filepath has to be absolute - if (Is_some(v_dirfd)) { - dir = Handle_val(Field(v_dirfd, 0)); - } else { - dir = NULL; - } - - // Initialise object attributes, passing in the root directory FD - InitializeObjectAttributes( - &obj_attr, - &relative, - OBJ_CASE_INSENSITIVE, // TODO: Double-check what flags need to be passed at this point. - dir, - NULL - ); - - // Create the file - r = NtCreatefile( - &h, - (SYNCHRONIZE | DELETE), - &obj_attr, - &io_status, - 0, // Allocation size - FILE_ATTRIBUTE_NORMAL, // TODO: Could check flags to see if we can do READONLY here a la OCaml - (FILE_SHARE_DELETE), - FILE_OPEN, - ((Bool_val(v_dir) ? FILE_DIRECTORY_FILE : FILE_NON_DIRECTORY_FILE) | FILE_SYNCHRONOUS_IO_NONALERT | FILE_DELETE_ON_CLOSE), - NULL, // Extended attribute buffer - 0 // Extended attribute buffer length - ); - - // Free the allocated pathname - caml_stat_free(pathname); - - if (h == INVALID_HANDLE_VALUE) { - caml_win32_maperr(RtlNtStatusToDosError(r)); - uerror("openat", v_pathname); - } - - if (!NT_SUCCESS(r)) { - caml_win32_maperr(RtlNtStatusToDosError(r)); - uerror("openat", v_pathname); - } - - // Now close the file to delete it - BOOL closed; - closed = CloseHandle(h); - - CAMLreturn(Val_unit); -} - -CAMLprim value caml_eio_windows_renameat(value v_old_fd, value v_old_path, value v_new_fd, value v_new_path) -{ - uerror("renameat is not supported on windows yet", Nothing); -} - -CAMLprim value caml_eio_windows_symlinkat(value v_old_path, value v_new_fd, value v_new_path) -{ - uerror("symlinkat is not supported on windows yet", Nothing); -} - -CAMLprim value caml_eio_windows_spawn(value v_errors, value v_actions) -{ - uerror("processes are not supported on windows yet", Nothing); -} +#define _FILE_OFFSET_BITS 64 + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +typedef ULONG (__stdcall *pNtCreateFile)( + PHANDLE FileHandle, + ULONG DesiredAccess, + PVOID ObjectAttributes, + PVOID IoStatusBlock, + PLARGE_INTEGER AllocationSize, + ULONG FileAttributes, + ULONG ShareAccess, + ULONG CreateDisposition, + ULONG CreateOptions, + PVOID EaBuffer, + ULONG EaLength + ); + +#include +#include +#include +#include +#include +#include + +#ifdef ARCH_SIXTYFOUR +#define Int63_val(v) Long_val(v) +#else +#define Int63_val(v) (Int64_val(v)) >> 1 +#endif + +static void caml_stat_free_preserving_errno(void *ptr) +{ + int saved = errno; + caml_stat_free(ptr); + errno = saved; +} + +CAMLprim value caml_eio_windows_getrandom(value v_ba, value v_off, value v_len) +{ + CAMLparam1(v_ba); + ssize_t ret; + ssize_t off = (ssize_t)Long_val(v_off); + ssize_t len = (ssize_t)Long_val(v_len); + do + { + void *buf = (uint8_t *)Caml_ba_data_val(v_ba) + off; + caml_enter_blocking_section(); + ret = BCryptGenRandom(NULL, buf, len, BCRYPT_USE_SYSTEM_PREFERRED_RNG); + caml_leave_blocking_section(); + } while (errno == EINTR); + if (ret != STATUS_SUCCESS) + uerror("getrandom", Nothing); + CAMLreturn(Val_long(len)); +} + +CAMLprim value caml_eio_windows_readv(value v_fd, value v_bufs) +{ + uerror("readv is not supported on windows yet", Nothing); +} + +CAMLprim value caml_eio_windows_preadv(value v_fd, value v_bufs, value v_offset) +{ + uerror("preadv is not supported on windows yet", Nothing); +} + +CAMLprim value caml_eio_windows_pwritev(value v_fd, value v_bufs, value v_offset) +{ + uerror("pwritev is not supported on windows yet", Nothing); +} + +// File-system operations + +// No follow +void no_follow(HANDLE h) { + BY_HANDLE_FILE_INFORMATION b; + + if (!GetFileInformationByHandle(h, &b)) { + caml_win32_maperr(GetLastError()); + uerror("nofollow", Nothing); + } + + if (b.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT) { + CloseHandle(h); + caml_unix_error(ELOOP, "nofollow", Nothing); + } +} + +// We recreate an openat like function using NtCreateFile +CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_nofollow, value v_pathname, value v_desired_access, value v_create_disposition, value v_create_options) +{ + CAMLparam2(v_dirfd, v_pathname); + HANDLE h, dir; + OBJECT_ATTRIBUTES obj_attr; + IO_STATUS_BLOCK io_status; + wchar_t *pathname; + UNICODE_STRING relative; + NTSTATUS r; + + // Not sure what the overhead of this is, but it allows us to have low-level control + // over file creation. In particular, we can specify the HANDLE to the parent directory + // of a relative path a la openat. + pNtCreateFile NtCreatefile = (pNtCreateFile)GetProcAddress(GetModuleHandle("ntdll.dll"), "NtCreateFile"); + caml_unix_check_path(v_pathname, "openat"); + pathname = caml_stat_strdup_to_utf16(String_val(v_pathname)); + RtlInitUnicodeString(&relative, pathname); + + // If NULL the filepath has to be absolute + if (Is_some(v_dirfd)) { + dir = Handle_val(Field(v_dirfd, 0)); + } else { + dir = NULL; + } + + // Initialise object attributes, passing in the root directory FD + InitializeObjectAttributes( + &obj_attr, + &relative, + OBJ_CASE_INSENSITIVE, // TODO: Double-check what flags need to be passed at this point. + dir, + NULL + ); + + // Create the file + r = NtCreatefile( + &h, + Int_val(v_desired_access) | FILE_READ_ATTRIBUTES, + &obj_attr, + &io_status, + 0, // Allocation size + FILE_ATTRIBUTE_NORMAL, // TODO: Could check flags to see if we can do READONLY here a la OCaml + (FILE_SHARE_READ | FILE_SHARE_WRITE), + Int_val(v_create_disposition), + ( + FILE_SYNCHRONOUS_IO_NONALERT + | FILE_OPEN_FOR_BACKUP_INTENT + | (Bool_val(v_nofollow) ? FILE_FLAG_OPEN_REPARSE_POINT : Int_val(v_create_options))), + NULL, // Extended attribute buffer + 0 // Extended attribute buffer length + ); + + // Free the allocated pathname + caml_stat_free(pathname); + + if (h == INVALID_HANDLE_VALUE) { + caml_win32_maperr(RtlNtStatusToDosError(r)); + uerror("openat handle", v_pathname); + } + + if (!NT_SUCCESS(r)) { + caml_win32_maperr(RtlNtStatusToDosError(r)); + uerror("openat", Nothing); + } + + // No follow check -- Windows doesn't actually have that ability + // so we have to do it after the fact. This will raise if a symbolic + // link is encountered and will close the handle. + if (Bool_val(v_nofollow)) { + no_follow(h); + } + + CAMLreturn(caml_win32_alloc_handle(h)); +} + +value caml_eio_windows_openat_bytes(value* values, int argc) { + return caml_eio_windows_openat(values[0], values[1], values[2], values[3], values[4], values[5]); +} + +CAMLprim value caml_eio_windows_unlinkat(value v_dirfd, value v_pathname, value v_dir) +{ + CAMLparam2(v_dirfd, v_pathname); + HANDLE h, dir; + OBJECT_ATTRIBUTES obj_attr; + IO_STATUS_BLOCK io_status; + wchar_t *pathname; + UNICODE_STRING relative; + NTSTATUS r; + + // Not sure what the overhead of this is, but it allows us to have low-level control + // over file creation. In particular, we can specify the HANDLE to the parent directory + // of a relative path a la openat. + pNtCreateFile NtCreatefile = (pNtCreateFile)GetProcAddress(GetModuleHandle("ntdll.dll"), "NtCreateFile"); + caml_unix_check_path(v_pathname, "openat"); + pathname = caml_stat_strdup_to_utf16(String_val(v_pathname)); + RtlInitUnicodeString(&relative, pathname); + + // If NULL the filepath has to be absolute + if (Is_some(v_dirfd)) { + dir = Handle_val(Field(v_dirfd, 0)); + } else { + dir = NULL; + } + + // Initialise object attributes, passing in the root directory FD + InitializeObjectAttributes( + &obj_attr, + &relative, + OBJ_CASE_INSENSITIVE, // TODO: Double-check what flags need to be passed at this point. + dir, + NULL + ); + + // Create the file + r = NtCreatefile( + &h, + (SYNCHRONIZE | DELETE), + &obj_attr, + &io_status, + 0, // Allocation size + FILE_ATTRIBUTE_NORMAL, // TODO: Could check flags to see if we can do READONLY here a la OCaml + (FILE_SHARE_DELETE), + FILE_OPEN, + ((Bool_val(v_dir) ? FILE_DIRECTORY_FILE : FILE_NON_DIRECTORY_FILE) | FILE_SYNCHRONOUS_IO_NONALERT | FILE_DELETE_ON_CLOSE), + NULL, // Extended attribute buffer + 0 // Extended attribute buffer length + ); + + // Free the allocated pathname + caml_stat_free(pathname); + + if (h == INVALID_HANDLE_VALUE) { + caml_win32_maperr(RtlNtStatusToDosError(r)); + uerror("openat", v_pathname); + } + + if (!NT_SUCCESS(r)) { + caml_win32_maperr(RtlNtStatusToDosError(r)); + uerror("openat", v_pathname); + } + + // Now close the file to delete it + BOOL closed; + closed = CloseHandle(h); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_eio_windows_renameat(value v_old_fd, value v_old_path, value v_new_fd, value v_new_path) +{ + uerror("renameat is not supported on windows yet", Nothing); +} + +CAMLprim value caml_eio_windows_symlinkat(value v_old_path, value v_new_fd, value v_new_path) +{ + uerror("symlinkat is not supported on windows yet", Nothing); +} + +CAMLprim value caml_eio_windows_spawn(value v_errors, value v_actions) +{ + uerror("processes are not supported on windows yet", Nothing); +} diff --git a/lib_eio_windows/err.ml b/lib_eio_windows/err.ml index f813a06c1..cd8caaa38 100755 --- a/lib_eio_windows/err.ml +++ b/lib_eio_windows/err.ml @@ -1,29 +1,29 @@ -type Eio.Exn.Backend.t += - | Outside_sandbox of string * string - | Absolute_path - | Invalid_leaf of string - -let unclassified_error e = Eio.Exn.create (Eio.Exn.X e) - -let () = - Eio.Exn.Backend.register_pp (fun f -> function - | Outside_sandbox (path, dir) -> Fmt.pf f "Outside_sandbox (%S, %S)" path dir; true - | Absolute_path -> Fmt.pf f "Absolute_path"; true - | Invalid_leaf x -> Fmt.pf f "Invalid_leaf %S" x; true - | _ -> false - ) - -let wrap code name arg = - let e = Eio_unix.Unix_error (code, name, arg) in - match code with - | EEXIST -> Eio.Fs.err (Already_exists e) - | ENOENT -> Eio.Fs.err (Not_found e) - | EXDEV | EACCES | EPERM -> Eio.Fs.err (Permission_denied e) - | ECONNREFUSED -> Eio.Net.err (Connection_failure (Refused e)) - | ECONNRESET | EPIPE -> Eio.Net.err (Connection_reset e) - | _ -> unclassified_error e - -let run fn x = - try fn x - with Unix.Unix_error (code, name, arg) -> - raise (wrap code name arg) +type Eio.Exn.Backend.t += + | Outside_sandbox of string * string + | Absolute_path + | Invalid_leaf of string + +let unclassified_error e = Eio.Exn.create (Eio.Exn.X e) + +let () = + Eio.Exn.Backend.register_pp (fun f -> function + | Outside_sandbox (path, dir) -> Fmt.pf f "Outside_sandbox (%S, %S)" path dir; true + | Absolute_path -> Fmt.pf f "Absolute_path"; true + | Invalid_leaf x -> Fmt.pf f "Invalid_leaf %S" x; true + | _ -> false + ) + +let wrap code name arg = + let e = Eio_unix.Unix_error (code, name, arg) in + match code with + | EEXIST -> Eio.Fs.err (Already_exists e) + | ENOENT -> Eio.Fs.err (Not_found e) + | EXDEV | EACCES | EPERM -> Eio.Fs.err (Permission_denied e) + | ECONNREFUSED -> Eio.Net.err (Connection_failure (Refused e)) + | ECONNRESET | EPIPE -> Eio.Net.err (Connection_reset e) + | _ -> unclassified_error e + +let run fn x = + try fn x + with Unix.Unix_error (code, name, arg) -> + raise (wrap code name arg) diff --git a/lib_eio_windows/flow.ml b/lib_eio_windows/flow.ml index 5eacd68da..caeadd537 100755 --- a/lib_eio_windows/flow.ml +++ b/lib_eio_windows/flow.ml @@ -1,107 +1,107 @@ -open Eio.Std - -module Fd = Eio_unix.Fd - -module Impl = struct - type tag = [`Generic | `Unix] - - type t = Eio_unix.Fd.t - - let stat t = - try - let ust = Low_level.fstat t in - let st_kind : Eio.File.Stat.kind = - match ust.st_kind with - | Unix.S_REG -> `Regular_file - | Unix.S_DIR -> `Directory - | Unix.S_CHR -> `Character_special - | Unix.S_BLK -> `Block_device - | Unix.S_LNK -> `Symbolic_link - | Unix.S_FIFO -> `Fifo - | Unix.S_SOCK -> `Socket - in - Eio.File.Stat.{ - dev = ust.st_dev |> Int64.of_int; - ino = ust.st_ino |> Int64.of_int; - kind = st_kind; - perm = ust.st_perm; - nlink = ust.st_nlink |> Int64.of_int; - uid = ust.st_uid |> Int64.of_int; - gid = ust.st_gid |> Int64.of_int; - rdev = ust.st_rdev |> Int64.of_int; - size = ust.st_size |> Optint.Int63.of_int64; - atime = ust.st_atime; - mtime = ust.st_mtime; - ctime = ust.st_ctime; - } - with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg - - let write_all t bufs = - try Low_level.writev t bufs - with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - - (* todo: provide a way to do a single write *) - let single_write t bufs = - write_all t bufs; - Cstruct.lenv bufs - - let copy t ~src = Eio.Flow.Pi.simple_copy ~single_write t ~src - - let single_read t buf = - match Low_level.read_cstruct t buf with - | 0 -> raise End_of_file - | got -> got - | exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg) - - let shutdown t cmd = - try - Low_level.shutdown t @@ match cmd with - | `Receive -> Unix.SHUTDOWN_RECEIVE - | `Send -> Unix.SHUTDOWN_SEND - | `All -> Unix.SHUTDOWN_ALL - with - | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () - | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - - let read_methods = [] - - let pread t ~file_offset bufs = - let got = Low_level.preadv ~file_offset t (Array.of_list bufs) in - if got = 0 then raise End_of_file - else got - - let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (Array.of_list bufs) - - let send_msg _t ~fds:_ _data = failwith "Not implemented on Windows" - - let recv_msg_with_fds _t ~sw:_ ~max_fds:_ _data = failwith "Not implemented on Windows" - - let seek = Low_level.lseek - let sync = Low_level.fsync - let truncate = Low_level.ftruncate - - let fd t = t - - let close = Eio_unix.Fd.close -end - -let handler = Eio_unix.Pi.flow_handler (module Impl) - -let of_fd fd = - let r = Eio.Resource.T (fd, handler) in - (r : [`Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :> - [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r) - -module Secure_random = struct - type t = unit - - let single_read () buf = - Low_level.getrandom buf; - Cstruct.length buf - - let read_methods = [] -end - -let secure_random = - let ops = Eio.Flow.Pi.source (module Secure_random) in - Eio.Resource.T ((), ops) +open Eio.Std + +module Fd = Eio_unix.Fd + +module Impl = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t + + let stat t = + try + let ust = Low_level.fstat t in + let st_kind : Eio.File.Stat.kind = + match ust.st_kind with + | Unix.S_REG -> `Regular_file + | Unix.S_DIR -> `Directory + | Unix.S_CHR -> `Character_special + | Unix.S_BLK -> `Block_device + | Unix.S_LNK -> `Symbolic_link + | Unix.S_FIFO -> `Fifo + | Unix.S_SOCK -> `Socket + in + Eio.File.Stat.{ + dev = ust.st_dev |> Int64.of_int; + ino = ust.st_ino |> Int64.of_int; + kind = st_kind; + perm = ust.st_perm; + nlink = ust.st_nlink |> Int64.of_int; + uid = ust.st_uid |> Int64.of_int; + gid = ust.st_gid |> Int64.of_int; + rdev = ust.st_rdev |> Int64.of_int; + size = ust.st_size |> Optint.Int63.of_int64; + atime = ust.st_atime; + mtime = ust.st_mtime; + ctime = ust.st_ctime; + } + with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg + + let write_all t bufs = + try Low_level.writev t bufs + with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) + + (* todo: provide a way to do a single write *) + let single_write t bufs = + write_all t bufs; + Cstruct.lenv bufs + + let copy t ~src = Eio.Flow.Pi.simple_copy ~single_write t ~src + + let single_read t buf = + match Low_level.read_cstruct t buf with + | 0 -> raise End_of_file + | got -> got + | exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg) + + let shutdown t cmd = + try + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL + with + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () + | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) + + let read_methods = [] + + let pread t ~file_offset bufs = + let got = Low_level.preadv ~file_offset t (Array.of_list bufs) in + if got = 0 then raise End_of_file + else got + + let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (Array.of_list bufs) + + let send_msg _t ~fds:_ _data = failwith "Not implemented on Windows" + + let recv_msg_with_fds _t ~sw:_ ~max_fds:_ _data = failwith "Not implemented on Windows" + + let seek = Low_level.lseek + let sync = Low_level.fsync + let truncate = Low_level.ftruncate + + let fd t = t + + let close = Eio_unix.Fd.close +end + +let handler = Eio_unix.Pi.flow_handler (module Impl) + +let of_fd fd = + let r = Eio.Resource.T (fd, handler) in + (r : [`Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :> + [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r) + +module Secure_random = struct + type t = unit + + let single_read () buf = + Low_level.getrandom buf; + Cstruct.length buf + + let read_methods = [] +end + +let secure_random = + let ops = Eio.Flow.Pi.source (module Secure_random) in + Eio.Resource.T ((), ops) diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index d877b6fb5..9613566d6 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -1,215 +1,215 @@ -(* - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -(* This module provides (optional) sandboxing, allowing operations to be restricted to a subtree. - - For now, sandboxed directories use realpath and [O_NOFOLLOW], which is probably quite slow, - and requires duplicating a load of path lookup logic from the kernel. - It might be better to hold a directory FD rather than a path. - On FreeBSD we could use O_RESOLVE_BENEATH and let the OS handle everything for us. - On other systems we would have to resolve one path component at a time. *) - -open Eio.Std - -module Fd = Eio_unix.Fd - -module rec Dir : sig - include Eio.Fs.Pi.DIR - - val v : label:string -> sandbox:bool -> string -> t - - val resolve : t -> string -> string - (** [resolve t path] returns the real path that should be used to access [path]. - For sandboxes, this is [realpath path] (and it checks that it is within the sandbox). - For unrestricted access, this returns [path] unchanged. - @raise Eio.Fs.Permission_denied if sandboxed and [path] is outside of [dir_path]. *) - - val with_parent_dir : t -> string -> (Fd.t option -> string -> 'a) -> 'a - (** [with_parent_dir t path fn] runs [fn dir_fd rel_path], - where [rel_path] accessed relative to [dir_fd] gives access to [path]. - For unrestricted access, this just runs [fn None path]. - For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *) -end = struct - type t = { - dir_path : string; - sandbox : bool; - label : string; - mutable closed : bool; - } - - let resolve t path = - if t.sandbox then ( - if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; - if Filename.is_relative path then ( - let dir_path = Err.run Low_level.realpath t.dir_path in - let full = Err.run Low_level.realpath (Filename.concat dir_path path) in - let prefix_len = String.length dir_path + 1 in - (* \\??\\ Is necessary with NtCreateFile. *) - if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then begin - "\\??\\" ^ full - end else if full = dir_path then - "\\??\\" ^ full - else - raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path))) - ) else ( - raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path) - ) - ) else path - - let with_parent_dir t path fn = - if t.sandbox then ( - if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; - let dir, leaf = Filename.dirname path, Filename.basename path in - if leaf = ".." then ( - (* We could be smarter here and normalise the path first, but '..' - doesn't make sense for any of the current uses of [with_parent_dir] - anyway. *) - raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf))) - ) else ( - let dir = resolve t dir in - Switch.run @@ fun sw -> - let open Low_level in - let dirfd = Err.run (Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if)) Flags.Create.(directory) in - fn (Some dirfd) leaf - ) - ) else fn None path - - let v ~label ~sandbox dir_path = { dir_path; sandbox; label; closed = false } - - (* Sandboxes use [O_NOFOLLOW] when opening files ([resolve] already removed any symlinks). - This avoids a race where symlink might be added after [realpath] returns. - TODO: Emulate [O_NOFOLLOW] here. *) - let opt_nofollow t = t.sandbox - - let open_in t ~sw path = - let open Low_level in - let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in - (Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t) - - let rec open_out t ~sw ~append ~create path = - let open Low_level in - let _mode, disp = - match create with - | `Never -> 0, Low_level.Flags.Disposition.open_ - | `If_missing perm -> perm, Low_level.Flags.Disposition.open_if - | `Or_truncate perm -> perm, Low_level.Flags.Disposition.overwrite_if - | `Exclusive perm -> perm, Low_level.Flags.Disposition.create - in - let flags = - if append then Low_level.Flags.Open.(synchronise + append) - else Low_level.Flags.Open.(generic_write + synchronise) - in - match - with_parent_dir t path @@ fun dirfd path -> - Low_level.openat ?dirfd ~nofollow:(opt_nofollow t) ~sw path flags disp Flags.Create.(non_directory) - with - | fd -> (Flow.of_fd fd :> Eio.File.rw_ty r) - (* This is the result of raising [caml_unix_error(ELOOP,...)] *) - | exception Unix.Unix_error (EUNKNOWNERR 114, _, _) -> - print_endline "UNKNOWN"; - (* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that). - A leaf symlink might be OK, but we need to check it's still in the sandbox. - todo: possibly we should limit the number of redirections here, like the kernel does. *) - let target = Unix.readlink path in - let full_target = - if Filename.is_relative target then - Filename.concat (Filename.dirname path) target - else target - in - open_out t ~sw ~append ~create full_target - | exception Unix.Unix_error (code, name, arg) -> - raise (Err.wrap code name arg) - - let mkdir t ~perm path = - with_parent_dir t path @@ fun dirfd path -> - Err.run (Low_level.mkdir ?dirfd ~mode:perm) path - - let unlink t path = - with_parent_dir t path @@ fun dirfd path -> - Err.run (Low_level.unlink ?dirfd ~dir:false) path - - let rmdir t path = - with_parent_dir t path @@ fun dirfd path -> - Err.run (Low_level.unlink ?dirfd ~dir:true) path - - let stat t ~follow path = - Switch.run @@ fun sw -> - let open Low_level in - let flags = Low_level.Flags.Open.(generic_read + synchronise) in - let dis = Flags.Disposition.open_if in - let create = Flags.Create.non_directory in - let fd = Err.run (openat ~sw ~nofollow:(not follow) (resolve t path) flags dis) create in - Flow.Impl.stat fd - - let read_dir t path = - (* todo: need fdopendir here to avoid races *) - let path = resolve t path in - Err.run Low_level.readdir path - |> Array.to_list - - let read_link t path = - with_parent_dir t path @@ fun dirfd path -> - Err.run (Low_level.read_link ?dirfd) path - - let rename t old_path new_dir new_path = - match Handler.as_posix_dir new_dir with - | None -> invalid_arg "Target is not an eio_windows directory!" - | Some new_dir -> - with_parent_dir t old_path @@ fun old_dir old_path -> - with_parent_dir new_dir new_path @@ fun new_dir new_path -> - Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path - - let symlink ~link_to t path = - with_parent_dir t path @@ fun dirfd path -> - Err.run (Low_level.symlink ~link_to dirfd) path - - let close t = t.closed <- true - - let open_dir t ~sw path = - Switch.check sw; - let label = Filename.basename path in - let d = v ~label (resolve t path) ~sandbox:true in - Switch.on_release sw (fun () -> close d); - Eio.Resource.T (d, Handler.v) - - let pp f t = Fmt.string f (String.escaped t.label) - - let native _t _path = - failwith "TODO: Windows native" -end -and Handler : sig - val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler - - val as_posix_dir : [> `Dir] r -> Dir.t option -end = struct - (* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check - that the new location is within its sandbox. *) - type (_, _, _) Eio.Resource.pi += Posix_dir : ('t, 't -> Dir.t, [> `Posix_dir]) Eio.Resource.pi - - let as_posix_dir (Eio.Resource.T (t, ops)) = - match Eio.Resource.get_opt ops Posix_dir with - | None -> None - | Some fn -> Some (fn t) - - let v = Eio.Resource.handler [ - H (Eio.Fs.Pi.Dir, (module Dir)); - H (Posix_dir, Fun.id); - ] -end - -(* Full access to the filesystem. *) -let fs = Eio.Resource.T (Dir.v ~label:"fs" ~sandbox:false ".", Handler.v) -let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~sandbox:true ".", Handler.v) +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* This module provides (optional) sandboxing, allowing operations to be restricted to a subtree. + + For now, sandboxed directories use realpath and [O_NOFOLLOW], which is probably quite slow, + and requires duplicating a load of path lookup logic from the kernel. + It might be better to hold a directory FD rather than a path. + On FreeBSD we could use O_RESOLVE_BENEATH and let the OS handle everything for us. + On other systems we would have to resolve one path component at a time. *) + +open Eio.Std + +module Fd = Eio_unix.Fd + +module rec Dir : sig + include Eio.Fs.Pi.DIR + + val v : label:string -> sandbox:bool -> string -> t + + val resolve : t -> string -> string + (** [resolve t path] returns the real path that should be used to access [path]. + For sandboxes, this is [realpath path] (and it checks that it is within the sandbox). + For unrestricted access, this returns [path] unchanged. + @raise Eio.Fs.Permission_denied if sandboxed and [path] is outside of [dir_path]. *) + + val with_parent_dir : t -> string -> (Fd.t option -> string -> 'a) -> 'a + (** [with_parent_dir t path fn] runs [fn dir_fd rel_path], + where [rel_path] accessed relative to [dir_fd] gives access to [path]. + For unrestricted access, this just runs [fn None path]. + For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *) +end = struct + type t = { + dir_path : string; + sandbox : bool; + label : string; + mutable closed : bool; + } + + let resolve t path = + if t.sandbox then ( + if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; + if Filename.is_relative path then ( + let dir_path = Err.run Low_level.realpath t.dir_path in + let full = Err.run Low_level.realpath (Filename.concat dir_path path) in + let prefix_len = String.length dir_path + 1 in + (* \\??\\ Is necessary with NtCreateFile. *) + if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then begin + "\\??\\" ^ full + end else if full = dir_path then + "\\??\\" ^ full + else + raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path))) + ) else ( + raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path) + ) + ) else path + + let with_parent_dir t path fn = + if t.sandbox then ( + if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; + let dir, leaf = Filename.dirname path, Filename.basename path in + if leaf = ".." then ( + (* We could be smarter here and normalise the path first, but '..' + doesn't make sense for any of the current uses of [with_parent_dir] + anyway. *) + raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf))) + ) else ( + let dir = resolve t dir in + Switch.run @@ fun sw -> + let open Low_level in + let dirfd = Err.run (Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if)) Flags.Create.(directory) in + fn (Some dirfd) leaf + ) + ) else fn None path + + let v ~label ~sandbox dir_path = { dir_path; sandbox; label; closed = false } + + (* Sandboxes use [O_NOFOLLOW] when opening files ([resolve] already removed any symlinks). + This avoids a race where symlink might be added after [realpath] returns. + TODO: Emulate [O_NOFOLLOW] here. *) + let opt_nofollow t = t.sandbox + + let open_in t ~sw path = + let open Low_level in + let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in + (Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t) + + let rec open_out t ~sw ~append ~create path = + let open Low_level in + let _mode, disp = + match create with + | `Never -> 0, Low_level.Flags.Disposition.open_ + | `If_missing perm -> perm, Low_level.Flags.Disposition.open_if + | `Or_truncate perm -> perm, Low_level.Flags.Disposition.overwrite_if + | `Exclusive perm -> perm, Low_level.Flags.Disposition.create + in + let flags = + if append then Low_level.Flags.Open.(synchronise + append) + else Low_level.Flags.Open.(generic_write + synchronise) + in + match + with_parent_dir t path @@ fun dirfd path -> + Low_level.openat ?dirfd ~nofollow:(opt_nofollow t) ~sw path flags disp Flags.Create.(non_directory) + with + | fd -> (Flow.of_fd fd :> Eio.File.rw_ty r) + (* This is the result of raising [caml_unix_error(ELOOP,...)] *) + | exception Unix.Unix_error (EUNKNOWNERR 114, _, _) -> + print_endline "UNKNOWN"; + (* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that). + A leaf symlink might be OK, but we need to check it's still in the sandbox. + todo: possibly we should limit the number of redirections here, like the kernel does. *) + let target = Unix.readlink path in + let full_target = + if Filename.is_relative target then + Filename.concat (Filename.dirname path) target + else target + in + open_out t ~sw ~append ~create full_target + | exception Unix.Unix_error (code, name, arg) -> + raise (Err.wrap code name arg) + + let mkdir t ~perm path = + with_parent_dir t path @@ fun dirfd path -> + Err.run (Low_level.mkdir ?dirfd ~mode:perm) path + + let unlink t path = + with_parent_dir t path @@ fun dirfd path -> + Err.run (Low_level.unlink ?dirfd ~dir:false) path + + let rmdir t path = + with_parent_dir t path @@ fun dirfd path -> + Err.run (Low_level.unlink ?dirfd ~dir:true) path + + let stat t ~follow path = + Switch.run @@ fun sw -> + let open Low_level in + let flags = Low_level.Flags.Open.(generic_read + synchronise) in + let dis = Flags.Disposition.open_if in + let create = Flags.Create.non_directory in + let fd = Err.run (openat ~sw ~nofollow:(not follow) (resolve t path) flags dis) create in + Flow.Impl.stat fd + + let read_dir t path = + (* todo: need fdopendir here to avoid races *) + let path = resolve t path in + Err.run Low_level.readdir path + |> Array.to_list + + let read_link t path = + with_parent_dir t path @@ fun dirfd path -> + Err.run (Low_level.read_link ?dirfd) path + + let rename t old_path new_dir new_path = + match Handler.as_posix_dir new_dir with + | None -> invalid_arg "Target is not an eio_windows directory!" + | Some new_dir -> + with_parent_dir t old_path @@ fun old_dir old_path -> + with_parent_dir new_dir new_path @@ fun new_dir new_path -> + Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path + + let symlink ~link_to t path = + with_parent_dir t path @@ fun dirfd path -> + Err.run (Low_level.symlink ~link_to dirfd) path + + let close t = t.closed <- true + + let open_dir t ~sw path = + Switch.check sw; + let label = Filename.basename path in + let d = v ~label (resolve t path) ~sandbox:true in + Switch.on_release sw (fun () -> close d); + Eio.Resource.T (d, Handler.v) + + let pp f t = Fmt.string f (String.escaped t.label) + + let native _t _path = + failwith "TODO: Windows native" +end +and Handler : sig + val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler + + val as_posix_dir : [> `Dir] r -> Dir.t option +end = struct + (* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check + that the new location is within its sandbox. *) + type (_, _, _) Eio.Resource.pi += Posix_dir : ('t, 't -> Dir.t, [> `Posix_dir]) Eio.Resource.pi + + let as_posix_dir (Eio.Resource.T (t, ops)) = + match Eio.Resource.get_opt ops Posix_dir with + | None -> None + | Some fn -> Some (fn t) + + let v = Eio.Resource.handler [ + H (Eio.Fs.Pi.Dir, (module Dir)); + H (Posix_dir, Fun.id); + ] +end + +(* Full access to the filesystem. *) +let fs = Eio.Resource.T (Dir.v ~label:"fs" ~sandbox:false ".", Handler.v) +let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~sandbox:true ".", Handler.v) diff --git a/lib_eio_windows/include/discover.ml b/lib_eio_windows/include/discover.ml index b38c130a6..0e6afe1ac 100755 --- a/lib_eio_windows/include/discover.ml +++ b/lib_eio_windows/include/discover.ml @@ -1,52 +1,52 @@ -module C = Configurator.V1 - -let () = - C.main ~name:"discover" (fun c -> - let defs = - C.C_define.import c ~c_flags:["-D_LARGEFILE64_SOURCE"] - ~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"; "winternl.h"; "ntdef.h"] - C.C_define.Type.[ - "_O_RDONLY", Int; - "_O_RDWR", Int; - "_O_WRONLY", Int; - "_O_APPEND", Int; - "_O_CREAT", Int; - "_O_NOINHERIT", Int; - "_O_TRUNC", Int; - "_O_EXCL", Int; - - (* Desired Access *) - "GENERIC_READ", Int; - "GENERIC_WRITE", Int; - "SYNCHRONIZE", Int; - "FILE_APPEND_DATA", Int; - - (* Create Disposition *) - "FILE_SUPERSEDE", Int; - "FILE_CREATE", Int; - "FILE_OPEN", Int; - "FILE_OPEN_IF", Int; - "FILE_OVERWRITE", Int; - "FILE_OVERWRITE_IF", Int; - - (* Create Options *) - "FILE_DIRECTORY_FILE", Int; - "FILE_NON_DIRECTORY_FILE", Int; - "FILE_NO_INTERMEDIATE_BUFFERING", Int; - "FILE_WRITE_THROUGH", Int; - "FILE_SEQUENTIAL_ONLY", Int; - ] - |> List.map (function - | name, C.C_define.Value.Int v -> - let name = - if name.[0] = '_' then - let name_length = String.length name in - String.sub name 1 (name_length - 1) - else name - in - Printf.sprintf "let %s = 0x%x" (String.lowercase_ascii name) v - | _ -> assert false - ) - in - C.Flags.write_lines "config.ml" defs - ) +module C = Configurator.V1 + +let () = + C.main ~name:"discover" (fun c -> + let defs = + C.C_define.import c ~c_flags:["-D_LARGEFILE64_SOURCE"] + ~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"; "winternl.h"; "ntdef.h"] + C.C_define.Type.[ + "_O_RDONLY", Int; + "_O_RDWR", Int; + "_O_WRONLY", Int; + "_O_APPEND", Int; + "_O_CREAT", Int; + "_O_NOINHERIT", Int; + "_O_TRUNC", Int; + "_O_EXCL", Int; + + (* Desired Access *) + "GENERIC_READ", Int; + "GENERIC_WRITE", Int; + "SYNCHRONIZE", Int; + "FILE_APPEND_DATA", Int; + + (* Create Disposition *) + "FILE_SUPERSEDE", Int; + "FILE_CREATE", Int; + "FILE_OPEN", Int; + "FILE_OPEN_IF", Int; + "FILE_OVERWRITE", Int; + "FILE_OVERWRITE_IF", Int; + + (* Create Options *) + "FILE_DIRECTORY_FILE", Int; + "FILE_NON_DIRECTORY_FILE", Int; + "FILE_NO_INTERMEDIATE_BUFFERING", Int; + "FILE_WRITE_THROUGH", Int; + "FILE_SEQUENTIAL_ONLY", Int; + ] + |> List.map (function + | name, C.C_define.Value.Int v -> + let name = + if name.[0] = '_' then + let name_length = String.length name in + String.sub name 1 (name_length - 1) + else name + in + Printf.sprintf "let %s = 0x%x" (String.lowercase_ascii name) v + | _ -> assert false + ) + in + C.Flags.write_lines "config.ml" defs + ) diff --git a/lib_eio_windows/include/dune b/lib_eio_windows/include/dune index db98d61d5..187737d3c 100755 --- a/lib_eio_windows/include/dune +++ b/lib_eio_windows/include/dune @@ -1,4 +1,4 @@ -(executable - (name discover) - (modules discover) - (libraries dune-configurator)) +(executable + (name discover) + (modules discover) + (libraries dune-configurator)) diff --git a/lib_eio_windows/low_level.ml b/lib_eio_windows/low_level.ml index 85f25cd26..ef19382f6 100755 --- a/lib_eio_windows/low_level.ml +++ b/lib_eio_windows/low_level.ml @@ -1,271 +1,271 @@ -open Eio.Std - -(* There are some things that should be improved here: - - - Blocking FDs (e.g. stdout) wait for the FD to become ready and then do a blocking operation. - This might not succeed, and will block the whole domain in that case. - Ideally, all blocking operations should happen in a sys-thread instead. - - - Various other operations, such as listing a directory, should also be done in a sys-thread - to avoid high latencies in the main domain. *) - -type ty = Read | Write - -let in_worker_thread = Eio_unix.run_in_systhread - -module Fd = Eio_unix.Fd - -let await_readable fd = - Fd.use_exn "await_readable" fd @@ fun fd -> - Sched.enter @@ fun t k -> - Sched.await_readable t k fd - -let await_writable fd = - Fd.use_exn "await_writable" fd @@ fun fd -> - Sched.enter @@ fun t k -> - Sched.await_writable t k fd - -let rec do_nonblocking ty fn fd = - Fiber.yield (); - try fn fd with - | Unix.Unix_error (EINTR, _, _) -> - do_nonblocking ty fn fd (* Just in case *) - | Unix.Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - Sched.enter (fun t k -> - match ty with - | Read -> Sched.await_readable t k fd - | Write -> Sched.await_writable t k fd - ); - do_nonblocking ty fn fd - -let read fd buf start len = - Fd.use_exn "read" fd @@ fun fd -> - do_nonblocking Read (fun fd -> Unix.read fd buf start len) fd - -let read_cstruct fd buf = - Fd.use_exn "read_cstruct" fd @@ fun fd -> - do_nonblocking Read (fun fd -> Unix_cstruct.read fd buf) fd - -let write fd buf start len = - Fd.use_exn "write" fd @@ fun fd -> - do_nonblocking Write (fun fd -> Unix.write fd buf start len) fd - -let sleep_until time = - Sched.enter @@ fun t k -> - Sched.await_timeout t k time - -let socket ~sw socket_domain socket_type protocol = - Switch.check sw; - let sock_unix = Unix.socket ~cloexec:true socket_domain socket_type protocol in - Unix.set_nonblock sock_unix; - Fd.of_unix ~sw ~blocking:false ~close_unix:true sock_unix - -let connect fd addr = - try - Fd.use_exn "connect" fd (fun fd -> Unix.connect fd addr) - with - | Unix.Unix_error ((EINTR | EAGAIN | EWOULDBLOCK | EINPROGRESS), _, _) -> - await_writable fd; - match Fd.use_exn "connect" fd Unix.getsockopt_error with - | None -> () - | Some code -> raise (Err.wrap code "connect-in-progress" "") - -let accept ~sw sock = - Fd.use_exn "accept" sock @@ fun sock -> - let client, addr = - do_nonblocking Read (fun fd -> Switch.check sw; Unix.accept ~cloexec:true fd) sock - in - Unix.set_nonblock client; - Fd.of_unix ~sw ~blocking:false ~close_unix:true client, addr - -let shutdown sock cmd = - Fd.use_exn "shutdown" sock (fun fd -> Unix.shutdown fd cmd) - -let send_msg fd ?dst buf = - Fd.use_exn "send_msg" fd @@ fun fd -> - do_nonblocking Write (fun fd -> - match dst with - | Some dst -> Unix.sendto fd buf 0 (Bytes.length buf) [] dst - | None -> Unix.send fd buf 0 (Bytes.length buf) [] - ) fd - -let recv_msg fd buf = - Fd.use_exn "recv_msg" fd @@ fun fd -> - do_nonblocking Read (fun fd -> Unix.recvfrom fd buf 0 (Bytes.length buf) []) fd - -external eio_getrandom : Cstruct.buffer -> int -> int -> int = "caml_eio_windows_getrandom" - -let getrandom { Cstruct.buffer; off; len } = - let rec loop n = - if n = len then - () - else - loop (n + eio_getrandom buffer (off + n) (len - n)) - in - in_worker_thread @@ fun () -> - loop 0 - -let fstat fd = - Fd.use_exn "fstat" fd Unix.LargeFile.fstat - -let lstat path = - in_worker_thread @@ fun () -> - Unix.LargeFile.lstat path - -let realpath path = - in_worker_thread @@ fun () -> - Unix.realpath path - -let read_entries h = - let rec aux acc = - match Unix.readdir h with - | "." | ".." -> aux acc - | leaf -> aux (leaf :: acc) - | exception End_of_file -> Array.of_list acc - in - aux [] - -let readdir path = - in_worker_thread @@ fun () -> - let h = Unix.opendir path in - match read_entries h with - | r -> Unix.closedir h; r - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - Unix.closedir h; Printexc.raise_with_backtrace ex bt - -let read_link ?dirfd path = - in_worker_thread @@ fun () -> - Eio_unix.Private.read_link dirfd path - -external eio_readv : Unix.file_descr -> Cstruct.t array -> int = "caml_eio_windows_readv" - -external eio_preadv : Unix.file_descr -> Cstruct.t array -> Optint.Int63.t -> int = "caml_eio_windows_preadv" -external eio_pwritev : Unix.file_descr -> Cstruct.t array -> Optint.Int63.t -> int = "caml_eio_windows_pwritev" - -let readv fd bufs = - Fd.use_exn "readv" fd @@ fun fd -> - do_nonblocking Read (fun fd -> eio_readv fd bufs) fd - -let writev fd bufs = - Fd.use_exn "writev" fd @@ fun fd -> - do_nonblocking Write (fun fd -> Unix_cstruct.writev fd bufs) fd - -let preadv ~file_offset fd bufs = - Fd.use_exn "preadv" fd @@ fun fd -> - do_nonblocking Read (fun fd -> eio_preadv fd bufs file_offset) fd - -let pwritev ~file_offset fd bufs = - Fd.use_exn "pwritev" fd @@ fun fd -> - do_nonblocking Write (fun fd -> eio_pwritev fd bufs file_offset) fd - -module Flags = struct - module Open = struct - type t = int - let rdonly = Config.o_rdonly - let rdwr = Config.o_rdwr - let wronly = Config.o_wronly - let cloexec = Config.o_noinherit - let creat = Config.o_creat - let excl = Config.o_excl - let trunc = Config.o_trunc - - let generic_read = Config.generic_read - let generic_write = Config.generic_write - let synchronise = Config.synchronize - let append = Config.file_append_data - - let empty = 0 - let ( + ) = ( lor ) - end - - module Disposition = struct - type t = int - let supersede = Config.file_supersede - let create = Config.file_create - let open_ = Config.file_open - let open_if = Config.file_open_if - let overwrite = Config.file_overwrite - let overwrite_if = Config.file_overwrite_if - end - - module Create = struct - type t = int - let directory = Config.file_directory_file - let non_directory = Config.file_non_directory_file - let no_intermediate_buffering = Config.file_no_intermediate_buffering - let write_through = Config.file_write_through - let sequential_only = Config.file_sequential_only - let ( + ) = ( lor ) - end -end - -let rec with_dirfd op dirfd fn = - match dirfd with - | None -> fn None - | Some dirfd -> Fd.use_exn op dirfd (fun fd -> fn (Some fd)) - | exception Unix.Unix_error(Unix.EINTR, _, "") -> with_dirfd op dirfd fn - -external eio_openat : Unix.file_descr option -> bool -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> Unix.file_descr = "caml_eio_windows_openat_bytes" "caml_eio_windows_openat" - -let openat ?dirfd ?(nofollow=false) ~sw path flags dis create = - with_dirfd "openat" dirfd @@ fun dirfd -> - Switch.check sw; - in_worker_thread (fun () -> eio_openat dirfd nofollow path Flags.Open.(flags + cloexec (* + nonblock *)) dis create) - |> Fd.of_unix ~sw ~blocking:false ~close_unix:true - -let mkdir ?dirfd ?(nofollow=false) ~mode:_ path = - Switch.run @@ fun sw -> - let _ : Fd.t = openat ?dirfd ~nofollow ~sw path Flags.Open.(generic_write + synchronise) Flags.Disposition.(create) Flags.Create.(directory) in - () - -external eio_unlinkat : Unix.file_descr option -> string -> bool -> unit = "caml_eio_windows_unlinkat" - -let unlink ?dirfd ~dir path = - with_dirfd "unlink" dirfd @@ fun dirfd -> - in_worker_thread @@ fun () -> - eio_unlinkat dirfd path dir - -external eio_renameat : Unix.file_descr option -> string -> Unix.file_descr option -> string -> unit = "caml_eio_windows_renameat" - -let rename ?old_dir old_path ?new_dir new_path = - with_dirfd "rename-old" old_dir @@ fun old_dir -> - with_dirfd "rename-new" new_dir @@ fun new_dir -> - in_worker_thread @@ fun () -> - eio_renameat old_dir old_path new_dir new_path - - -external eio_symlinkat : string -> Unix.file_descr option -> string -> unit = "caml_eio_windows_symlinkat" - -let symlink ~link_to new_dir new_path = - with_dirfd "symlink-new" new_dir @@ fun new_dir -> - in_worker_thread @@ fun () -> - eio_symlinkat link_to new_dir new_path - -let lseek fd off cmd = - Fd.use_exn "lseek" fd @@ fun fd -> - let cmd = - match cmd with - | `Set -> Unix.SEEK_SET - | `Cur -> Unix.SEEK_CUR - | `End -> Unix.SEEK_END - in - Unix.LargeFile.lseek fd (Optint.Int63.to_int64 off) cmd - |> Optint.Int63.of_int64 - -let fsync fd = - Eio_unix.run_in_systhread @@ fun () -> - Fd.use_exn "fsync" fd Unix.fsync - -let ftruncate fd len = - Eio_unix.run_in_systhread @@ fun () -> - Fd.use_exn "ftruncate" fd @@ fun fd -> - Unix.LargeFile.ftruncate fd (Optint.Int63.to_int64 len) - -let pipe ~sw = - let unix_r, unix_w = Unix.pipe ~cloexec:true () in - let r = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_r in - let w = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_w in - Unix.set_nonblock unix_r; - Unix.set_nonblock unix_w; - r, w +open Eio.Std + +(* There are some things that should be improved here: + + - Blocking FDs (e.g. stdout) wait for the FD to become ready and then do a blocking operation. + This might not succeed, and will block the whole domain in that case. + Ideally, all blocking operations should happen in a sys-thread instead. + + - Various other operations, such as listing a directory, should also be done in a sys-thread + to avoid high latencies in the main domain. *) + +type ty = Read | Write + +let in_worker_thread = Eio_unix.run_in_systhread + +module Fd = Eio_unix.Fd + +let await_readable fd = + Fd.use_exn "await_readable" fd @@ fun fd -> + Sched.enter @@ fun t k -> + Sched.await_readable t k fd + +let await_writable fd = + Fd.use_exn "await_writable" fd @@ fun fd -> + Sched.enter @@ fun t k -> + Sched.await_writable t k fd + +let rec do_nonblocking ty fn fd = + Fiber.yield (); + try fn fd with + | Unix.Unix_error (EINTR, _, _) -> + do_nonblocking ty fn fd (* Just in case *) + | Unix.Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> + Sched.enter (fun t k -> + match ty with + | Read -> Sched.await_readable t k fd + | Write -> Sched.await_writable t k fd + ); + do_nonblocking ty fn fd + +let read fd buf start len = + Fd.use_exn "read" fd @@ fun fd -> + do_nonblocking Read (fun fd -> Unix.read fd buf start len) fd + +let read_cstruct fd buf = + Fd.use_exn "read_cstruct" fd @@ fun fd -> + do_nonblocking Read (fun fd -> Unix_cstruct.read fd buf) fd + +let write fd buf start len = + Fd.use_exn "write" fd @@ fun fd -> + do_nonblocking Write (fun fd -> Unix.write fd buf start len) fd + +let sleep_until time = + Sched.enter @@ fun t k -> + Sched.await_timeout t k time + +let socket ~sw socket_domain socket_type protocol = + Switch.check sw; + let sock_unix = Unix.socket ~cloexec:true socket_domain socket_type protocol in + Unix.set_nonblock sock_unix; + Fd.of_unix ~sw ~blocking:false ~close_unix:true sock_unix + +let connect fd addr = + try + Fd.use_exn "connect" fd (fun fd -> Unix.connect fd addr) + with + | Unix.Unix_error ((EINTR | EAGAIN | EWOULDBLOCK | EINPROGRESS), _, _) -> + await_writable fd; + match Fd.use_exn "connect" fd Unix.getsockopt_error with + | None -> () + | Some code -> raise (Err.wrap code "connect-in-progress" "") + +let accept ~sw sock = + Fd.use_exn "accept" sock @@ fun sock -> + let client, addr = + do_nonblocking Read (fun fd -> Switch.check sw; Unix.accept ~cloexec:true fd) sock + in + Unix.set_nonblock client; + Fd.of_unix ~sw ~blocking:false ~close_unix:true client, addr + +let shutdown sock cmd = + Fd.use_exn "shutdown" sock (fun fd -> Unix.shutdown fd cmd) + +let send_msg fd ?dst buf = + Fd.use_exn "send_msg" fd @@ fun fd -> + do_nonblocking Write (fun fd -> + match dst with + | Some dst -> Unix.sendto fd buf 0 (Bytes.length buf) [] dst + | None -> Unix.send fd buf 0 (Bytes.length buf) [] + ) fd + +let recv_msg fd buf = + Fd.use_exn "recv_msg" fd @@ fun fd -> + do_nonblocking Read (fun fd -> Unix.recvfrom fd buf 0 (Bytes.length buf) []) fd + +external eio_getrandom : Cstruct.buffer -> int -> int -> int = "caml_eio_windows_getrandom" + +let getrandom { Cstruct.buffer; off; len } = + let rec loop n = + if n = len then + () + else + loop (n + eio_getrandom buffer (off + n) (len - n)) + in + in_worker_thread @@ fun () -> + loop 0 + +let fstat fd = + Fd.use_exn "fstat" fd Unix.LargeFile.fstat + +let lstat path = + in_worker_thread @@ fun () -> + Unix.LargeFile.lstat path + +let realpath path = + in_worker_thread @@ fun () -> + Unix.realpath path + +let read_entries h = + let rec aux acc = + match Unix.readdir h with + | "." | ".." -> aux acc + | leaf -> aux (leaf :: acc) + | exception End_of_file -> Array.of_list acc + in + aux [] + +let readdir path = + in_worker_thread @@ fun () -> + let h = Unix.opendir path in + match read_entries h with + | r -> Unix.closedir h; r + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + Unix.closedir h; Printexc.raise_with_backtrace ex bt + +let read_link ?dirfd path = + in_worker_thread @@ fun () -> + Eio_unix.Private.read_link dirfd path + +external eio_readv : Unix.file_descr -> Cstruct.t array -> int = "caml_eio_windows_readv" + +external eio_preadv : Unix.file_descr -> Cstruct.t array -> Optint.Int63.t -> int = "caml_eio_windows_preadv" +external eio_pwritev : Unix.file_descr -> Cstruct.t array -> Optint.Int63.t -> int = "caml_eio_windows_pwritev" + +let readv fd bufs = + Fd.use_exn "readv" fd @@ fun fd -> + do_nonblocking Read (fun fd -> eio_readv fd bufs) fd + +let writev fd bufs = + Fd.use_exn "writev" fd @@ fun fd -> + do_nonblocking Write (fun fd -> Unix_cstruct.writev fd bufs) fd + +let preadv ~file_offset fd bufs = + Fd.use_exn "preadv" fd @@ fun fd -> + do_nonblocking Read (fun fd -> eio_preadv fd bufs file_offset) fd + +let pwritev ~file_offset fd bufs = + Fd.use_exn "pwritev" fd @@ fun fd -> + do_nonblocking Write (fun fd -> eio_pwritev fd bufs file_offset) fd + +module Flags = struct + module Open = struct + type t = int + let rdonly = Config.o_rdonly + let rdwr = Config.o_rdwr + let wronly = Config.o_wronly + let cloexec = Config.o_noinherit + let creat = Config.o_creat + let excl = Config.o_excl + let trunc = Config.o_trunc + + let generic_read = Config.generic_read + let generic_write = Config.generic_write + let synchronise = Config.synchronize + let append = Config.file_append_data + + let empty = 0 + let ( + ) = ( lor ) + end + + module Disposition = struct + type t = int + let supersede = Config.file_supersede + let create = Config.file_create + let open_ = Config.file_open + let open_if = Config.file_open_if + let overwrite = Config.file_overwrite + let overwrite_if = Config.file_overwrite_if + end + + module Create = struct + type t = int + let directory = Config.file_directory_file + let non_directory = Config.file_non_directory_file + let no_intermediate_buffering = Config.file_no_intermediate_buffering + let write_through = Config.file_write_through + let sequential_only = Config.file_sequential_only + let ( + ) = ( lor ) + end +end + +let rec with_dirfd op dirfd fn = + match dirfd with + | None -> fn None + | Some dirfd -> Fd.use_exn op dirfd (fun fd -> fn (Some fd)) + | exception Unix.Unix_error(Unix.EINTR, _, "") -> with_dirfd op dirfd fn + +external eio_openat : Unix.file_descr option -> bool -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> Unix.file_descr = "caml_eio_windows_openat_bytes" "caml_eio_windows_openat" + +let openat ?dirfd ?(nofollow=false) ~sw path flags dis create = + with_dirfd "openat" dirfd @@ fun dirfd -> + Switch.check sw; + in_worker_thread (fun () -> eio_openat dirfd nofollow path Flags.Open.(flags + cloexec (* + nonblock *)) dis create) + |> Fd.of_unix ~sw ~blocking:false ~close_unix:true + +let mkdir ?dirfd ?(nofollow=false) ~mode:_ path = + Switch.run @@ fun sw -> + let _ : Fd.t = openat ?dirfd ~nofollow ~sw path Flags.Open.(generic_write + synchronise) Flags.Disposition.(create) Flags.Create.(directory) in + () + +external eio_unlinkat : Unix.file_descr option -> string -> bool -> unit = "caml_eio_windows_unlinkat" + +let unlink ?dirfd ~dir path = + with_dirfd "unlink" dirfd @@ fun dirfd -> + in_worker_thread @@ fun () -> + eio_unlinkat dirfd path dir + +external eio_renameat : Unix.file_descr option -> string -> Unix.file_descr option -> string -> unit = "caml_eio_windows_renameat" + +let rename ?old_dir old_path ?new_dir new_path = + with_dirfd "rename-old" old_dir @@ fun old_dir -> + with_dirfd "rename-new" new_dir @@ fun new_dir -> + in_worker_thread @@ fun () -> + eio_renameat old_dir old_path new_dir new_path + + +external eio_symlinkat : string -> Unix.file_descr option -> string -> unit = "caml_eio_windows_symlinkat" + +let symlink ~link_to new_dir new_path = + with_dirfd "symlink-new" new_dir @@ fun new_dir -> + in_worker_thread @@ fun () -> + eio_symlinkat link_to new_dir new_path + +let lseek fd off cmd = + Fd.use_exn "lseek" fd @@ fun fd -> + let cmd = + match cmd with + | `Set -> Unix.SEEK_SET + | `Cur -> Unix.SEEK_CUR + | `End -> Unix.SEEK_END + in + Unix.LargeFile.lseek fd (Optint.Int63.to_int64 off) cmd + |> Optint.Int63.of_int64 + +let fsync fd = + Eio_unix.run_in_systhread @@ fun () -> + Fd.use_exn "fsync" fd Unix.fsync + +let ftruncate fd len = + Eio_unix.run_in_systhread @@ fun () -> + Fd.use_exn "ftruncate" fd @@ fun fd -> + Unix.LargeFile.ftruncate fd (Optint.Int63.to_int64 len) + +let pipe ~sw = + let unix_r, unix_w = Unix.pipe ~cloexec:true () in + let r = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_r in + let w = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_w in + Unix.set_nonblock unix_r; + Unix.set_nonblock unix_w; + r, w diff --git a/lib_eio_windows/low_level.mli b/lib_eio_windows/low_level.mli index e2ec400bd..fc48c219a 100755 --- a/lib_eio_windows/low_level.mli +++ b/lib_eio_windows/low_level.mli @@ -1,128 +1,128 @@ -(** This module provides an effects-based API for calling POSIX functions. - - Normally it's better to use the cross-platform {!Eio} APIs instead, - which uses these functions automatically where appropriate. - - These functions mostly copy the POSIX APIs directly, except that: - - + They suspend the calling fiber instead of returning [EAGAIN] or similar. - + They handle [EINTR] by automatically restarting the call. - + They wrap {!Unix.file_descr} in {!Fd}, to avoid use-after-close bugs. - + They attach new FDs to switches, to avoid resource leaks. *) - -open Eio.Std - -type fd := Eio_unix.Fd.t - -val await_readable : fd -> unit -val await_writable : fd -> unit - -val sleep_until : Mtime.t -> unit - -val read : fd -> bytes -> int -> int -> int -val read_cstruct : fd -> Cstruct.t -> int -val write : fd -> bytes -> int -> int -> int - -val socket : sw:Switch.t -> Unix.socket_domain -> Unix.socket_type -> int -> fd -val connect : fd -> Unix.sockaddr -> unit -val accept : sw:Switch.t -> fd -> fd * Unix.sockaddr - -val shutdown : fd -> Unix.shutdown_command -> unit - -val recv_msg : fd -> bytes -> int * Unix.sockaddr -val send_msg : fd -> ?dst:Unix.sockaddr -> bytes -> int - -val getrandom : Cstruct.t -> unit - -val lseek : fd -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t -val fsync : fd -> unit -val ftruncate : fd -> Optint.Int63.t -> unit - -val fstat : fd -> Unix.LargeFile.stats -val lstat : string -> Unix.LargeFile.stats - -val realpath : string -> string -val read_link : ?dirfd:fd -> string -> string - -val mkdir : ?dirfd:fd -> ?nofollow:bool -> mode:int -> string -> unit -val unlink : ?dirfd:fd -> dir:bool -> string -> unit -val rename : ?old_dir:fd -> string -> ?new_dir:fd -> string -> unit - -val symlink : link_to:string -> fd option -> string -> unit -(** [symlink ~link_to dir path] will create a new symlink at [dir / path] - linking to [link_to]. *) - -val readdir : string -> string array - -val readv : fd -> Cstruct.t array -> int -val writev : fd -> Cstruct.t list -> unit - -val preadv : file_offset:Optint.Int63.t -> fd -> Cstruct.t array -> int -val pwritev : file_offset:Optint.Int63.t -> fd -> Cstruct.t array -> int - -val pipe : sw:Switch.t -> fd * fd - -module Flags : sig - module Open : sig - type t - - val rdonly : t - val rdwr : t - val wronly : t - val creat : t - val excl : t - val trunc : t - - val generic_read : t - val generic_write : t - val synchronise : t - val append : t - - val empty : t - val ( + ) : t -> t -> t - end - - module Disposition : sig - type t - - val supersede : t - (** If the file already exists, replace it with the given file. - If it does not, create the given file. *) - - val create : t - (** Create the file, if it already exists fail. *) - - val open_ : t - (** If the file already exists, open it otherwise fail. *) - - val open_if : t - (** If the file already exists, open it otherwise create it. *) - - val overwrite : t - (** If the file already exists, open it and overwrite it otherwise fail. *) - - val overwrite_if : t - (** If the file already exists, open it and overwrite it otherwise create it. *) - end - - module Create : sig - type t - - val directory : t - (** Create a directory. *) - - val non_directory : t - (** Create something that is not a directory. *) - - val no_intermediate_buffering : t - - val write_through : t - - val sequential_only : t - - val ( + ) : t -> t -> t - end -end - -val openat : ?dirfd:fd -> ?nofollow:bool-> sw:Switch.t -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> fd -(** Note: the returned FD is always non-blocking and close-on-exec. *) +(** This module provides an effects-based API for calling POSIX functions. + + Normally it's better to use the cross-platform {!Eio} APIs instead, + which uses these functions automatically where appropriate. + + These functions mostly copy the POSIX APIs directly, except that: + + + They suspend the calling fiber instead of returning [EAGAIN] or similar. + + They handle [EINTR] by automatically restarting the call. + + They wrap {!Unix.file_descr} in {!Fd}, to avoid use-after-close bugs. + + They attach new FDs to switches, to avoid resource leaks. *) + +open Eio.Std + +type fd := Eio_unix.Fd.t + +val await_readable : fd -> unit +val await_writable : fd -> unit + +val sleep_until : Mtime.t -> unit + +val read : fd -> bytes -> int -> int -> int +val read_cstruct : fd -> Cstruct.t -> int +val write : fd -> bytes -> int -> int -> int + +val socket : sw:Switch.t -> Unix.socket_domain -> Unix.socket_type -> int -> fd +val connect : fd -> Unix.sockaddr -> unit +val accept : sw:Switch.t -> fd -> fd * Unix.sockaddr + +val shutdown : fd -> Unix.shutdown_command -> unit + +val recv_msg : fd -> bytes -> int * Unix.sockaddr +val send_msg : fd -> ?dst:Unix.sockaddr -> bytes -> int + +val getrandom : Cstruct.t -> unit + +val lseek : fd -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t +val fsync : fd -> unit +val ftruncate : fd -> Optint.Int63.t -> unit + +val fstat : fd -> Unix.LargeFile.stats +val lstat : string -> Unix.LargeFile.stats + +val realpath : string -> string +val read_link : ?dirfd:fd -> string -> string + +val mkdir : ?dirfd:fd -> ?nofollow:bool -> mode:int -> string -> unit +val unlink : ?dirfd:fd -> dir:bool -> string -> unit +val rename : ?old_dir:fd -> string -> ?new_dir:fd -> string -> unit + +val symlink : link_to:string -> fd option -> string -> unit +(** [symlink ~link_to dir path] will create a new symlink at [dir / path] + linking to [link_to]. *) + +val readdir : string -> string array + +val readv : fd -> Cstruct.t array -> int +val writev : fd -> Cstruct.t list -> unit + +val preadv : file_offset:Optint.Int63.t -> fd -> Cstruct.t array -> int +val pwritev : file_offset:Optint.Int63.t -> fd -> Cstruct.t array -> int + +val pipe : sw:Switch.t -> fd * fd + +module Flags : sig + module Open : sig + type t + + val rdonly : t + val rdwr : t + val wronly : t + val creat : t + val excl : t + val trunc : t + + val generic_read : t + val generic_write : t + val synchronise : t + val append : t + + val empty : t + val ( + ) : t -> t -> t + end + + module Disposition : sig + type t + + val supersede : t + (** If the file already exists, replace it with the given file. + If it does not, create the given file. *) + + val create : t + (** Create the file, if it already exists fail. *) + + val open_ : t + (** If the file already exists, open it otherwise fail. *) + + val open_if : t + (** If the file already exists, open it otherwise create it. *) + + val overwrite : t + (** If the file already exists, open it and overwrite it otherwise fail. *) + + val overwrite_if : t + (** If the file already exists, open it and overwrite it otherwise create it. *) + end + + module Create : sig + type t + + val directory : t + (** Create a directory. *) + + val non_directory : t + (** Create something that is not a directory. *) + + val no_intermediate_buffering : t + + val write_through : t + + val sequential_only : t + + val ( + ) : t -> t -> t + end +end + +val openat : ?dirfd:fd -> ?nofollow:bool-> sw:Switch.t -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> fd +(** Note: the returned FD is always non-blocking and close-on-exec. *) diff --git a/lib_eio_windows/net.ml b/lib_eio_windows/net.ml index cf3095ca9..6156a550b 100755 --- a/lib_eio_windows/net.ml +++ b/lib_eio_windows/net.ml @@ -1,195 +1,195 @@ -open Eio.Std - -module Fd = Eio_unix.Fd - -let socket_domain_of = function - | `Unix _ -> Unix.PF_UNIX - | `UdpV4 -> Unix.PF_INET - | `UdpV6 -> Unix.PF_INET6 - | `Udp (host, _) - | `Tcp (host, _) -> - Eio.Net.Ipaddr.fold host - ~v4:(fun _ -> Unix.PF_INET) - ~v6:(fun _ -> Unix.PF_INET6) - -module Listening_socket = struct - type t = { - hook : Switch.hook; - fd : Fd.t; - } - - type tag = [`Generic | `Unix] - - let make ~hook fd = { hook; fd } - - let fd t = t.fd - - let close t = - Switch.remove_hook t.hook; - Fd.close t.fd - - let accept t ~sw = - let client, client_addr = Err.run (Low_level.accept ~sw) t.fd in - let client_addr = match client_addr with - | Unix.ADDR_UNIX path -> `Unix path - | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port) - in - let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in - flow, client_addr - - let listening_addr { fd; _ } = - Eio_unix.Fd.use_exn "listening_addr" fd - (fun fd -> Eio_unix.Net.sockaddr_of_unix_stream (Unix.getsockname fd)) -end - -let listening_handler = Eio_unix.Pi.listening_socket_handler (module Listening_socket) - -let listening_socket ~hook fd = - Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler) - -module Datagram_socket = struct - type tag = [`Generic | `Unix] - - type t = Eio_unix.Fd.t - - let close = Fd.close - - let fd t = t - - let send t ?dst buf = - let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in - let sent = Err.run (Low_level.send_msg t ?dst) (Bytes.unsafe_of_string (Cstruct.copyv buf)) in - assert (sent = Cstruct.lenv buf) - - let recv t buf = - let b = Bytes.create (Cstruct.length buf) in - let recv, addr = Err.run (Low_level.recv_msg t) b in - Cstruct.blit_from_bytes b 0 buf 0 recv; - Eio_unix.Net.sockaddr_of_unix_datagram addr, recv - - let shutdown t cmd = - try - Low_level.shutdown t @@ match cmd with - | `Receive -> Unix.SHUTDOWN_RECEIVE - | `Send -> Unix.SHUTDOWN_SEND - | `All -> Unix.SHUTDOWN_ALL - with - | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () - | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) -end - -let datagram_handler = Eio_unix.Pi.datagram_handler (module Datagram_socket) - -let datagram_socket fd = - Eio.Resource.T (fd, datagram_handler) - -(* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *) -let getaddrinfo ~service node = - let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } = - match ai_family, ai_socktype, ai_addr with - | (Unix.PF_INET | PF_INET6), - (Unix.SOCK_STREAM | SOCK_DGRAM), - Unix.ADDR_INET (inet_addr,port) -> ( - match ai_protocol with - | 6 -> Some (`Tcp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) - | 17 -> Some (`Udp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) - | _ -> None) - | _ -> None - in - Err.run (Eio_unix.run_in_systhread ~label:"getaddrinfo") @@ fun () -> - let rec aux () = - try - Unix.getaddrinfo node service [] - |> List.filter_map to_eio_sockaddr_t - with Unix.Unix_error (EINTR, _, _) -> aux () - in - aux () - -let listen ~reuse_addr ~reuse_port ~backlog ~sw (listen_addr : Eio.Net.Sockaddr.stream) = - let socket_type, addr, is_unix_socket = - match listen_addr with - | `Unix path -> - if reuse_addr then ( - match Low_level.lstat path with - | Unix.{ st_kind = S_SOCK; _ } -> Unix.unlink path - | _ -> () - | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () - | exception Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg - ); - Unix.SOCK_STREAM, Unix.ADDR_UNIX path, true - | `Tcp (host, port) -> - let host = Eio_unix.Net.Ipaddr.to_unix host in - Unix.SOCK_STREAM, Unix.ADDR_INET (host, port), false - in - let sock = Low_level.socket ~sw (socket_domain_of listen_addr) socket_type 0 in - (* For Unix domain sockets, remove the path when done (except for abstract sockets). *) - let hook = - match listen_addr with - | `Unix path when String.length path > 0 && path.[0] <> Char.chr 0 -> - Switch.on_release_cancellable sw (fun () -> Unix.unlink path) - | `Unix _ | `Tcp _ -> - Switch.null_hook - in - Fd.use_exn "listen" sock (fun fd -> - (* REUSEADDR cannot be set on a Windows UNIX domain socket, - otherwise the Unix.bind will fail! *) - if not is_unix_socket && reuse_addr then - Unix.setsockopt fd Unix.SO_REUSEADDR true; - if reuse_port then - Unix.setsockopt fd Unix.SO_REUSEPORT true; - Unix.bind fd addr; - Unix.listen fd backlog - ); - (listening_socket ~hook sock :> _ Eio.Net.listening_socket_ty r) - -let connect ~sw connect_addr = - let socket_type, addr = - match connect_addr with - | `Unix path -> Unix.SOCK_STREAM, Unix.ADDR_UNIX path - | `Tcp (host, port) -> - let host = Eio_unix.Net.Ipaddr.to_unix host in - Unix.SOCK_STREAM, Unix.ADDR_INET (host, port) - in - let sock = Low_level.socket ~sw (socket_domain_of connect_addr) socket_type 0 in - try - Low_level.connect sock addr; - (Flow.of_fd sock :> _ Eio_unix.Net.stream_socket) - with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - -let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr = - let sock = Low_level.socket ~sw (socket_domain_of saddr) Unix.SOCK_DGRAM 0 in - begin match saddr with - | `Udp _ | `Unix _ as saddr -> - let addr = Eio_unix.Net.sockaddr_to_unix saddr in - Fd.use_exn "datagram_socket" sock (fun fd -> - if reuse_addr then - Unix.setsockopt fd Unix.SO_REUSEADDR true; - if reuse_port then - Unix.setsockopt fd Unix.SO_REUSEPORT true; - Unix.bind fd addr - ) - | `UdpV4 | `UdpV6 -> () - end; - datagram_socket sock - -module Impl = struct - type t = unit - type tag = [`Generic | `Unix] - - let listen () = listen - - let connect () ~sw addr = - let socket = connect ~sw addr in - (socket :> [`Generic | `Unix] Eio.Net.stream_socket_ty r) - - let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr = - let socket = create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr in - (socket :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r) - - let getaddrinfo () = getaddrinfo - let getnameinfo () = Eio_unix.Net.getnameinfo -end - -let v : Impl.tag Eio.Net.ty r = - let handler = Eio.Net.Pi.network (module Impl) in - Eio.Resource.T ((), handler) +open Eio.Std + +module Fd = Eio_unix.Fd + +let socket_domain_of = function + | `Unix _ -> Unix.PF_UNIX + | `UdpV4 -> Unix.PF_INET + | `UdpV6 -> Unix.PF_INET6 + | `Udp (host, _) + | `Tcp (host, _) -> + Eio.Net.Ipaddr.fold host + ~v4:(fun _ -> Unix.PF_INET) + ~v6:(fun _ -> Unix.PF_INET6) + +module Listening_socket = struct + type t = { + hook : Switch.hook; + fd : Fd.t; + } + + type tag = [`Generic | `Unix] + + let make ~hook fd = { hook; fd } + + let fd t = t.fd + + let close t = + Switch.remove_hook t.hook; + Fd.close t.fd + + let accept t ~sw = + let client, client_addr = Err.run (Low_level.accept ~sw) t.fd in + let client_addr = match client_addr with + | Unix.ADDR_UNIX path -> `Unix path + | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port) + in + let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in + flow, client_addr + + let listening_addr { fd; _ } = + Eio_unix.Fd.use_exn "listening_addr" fd + (fun fd -> Eio_unix.Net.sockaddr_of_unix_stream (Unix.getsockname fd)) +end + +let listening_handler = Eio_unix.Pi.listening_socket_handler (module Listening_socket) + +let listening_socket ~hook fd = + Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler) + +module Datagram_socket = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t + + let close = Fd.close + + let fd t = t + + let send t ?dst buf = + let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in + let sent = Err.run (Low_level.send_msg t ?dst) (Bytes.unsafe_of_string (Cstruct.copyv buf)) in + assert (sent = Cstruct.lenv buf) + + let recv t buf = + let b = Bytes.create (Cstruct.length buf) in + let recv, addr = Err.run (Low_level.recv_msg t) b in + Cstruct.blit_from_bytes b 0 buf 0 recv; + Eio_unix.Net.sockaddr_of_unix_datagram addr, recv + + let shutdown t cmd = + try + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL + with + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () + | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) +end + +let datagram_handler = Eio_unix.Pi.datagram_handler (module Datagram_socket) + +let datagram_socket fd = + Eio.Resource.T (fd, datagram_handler) + +(* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *) +let getaddrinfo ~service node = + let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } = + match ai_family, ai_socktype, ai_addr with + | (Unix.PF_INET | PF_INET6), + (Unix.SOCK_STREAM | SOCK_DGRAM), + Unix.ADDR_INET (inet_addr,port) -> ( + match ai_protocol with + | 6 -> Some (`Tcp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) + | 17 -> Some (`Udp (Eio_unix.Net.Ipaddr.of_unix inet_addr, port)) + | _ -> None) + | _ -> None + in + Err.run (Eio_unix.run_in_systhread ~label:"getaddrinfo") @@ fun () -> + let rec aux () = + try + Unix.getaddrinfo node service [] + |> List.filter_map to_eio_sockaddr_t + with Unix.Unix_error (EINTR, _, _) -> aux () + in + aux () + +let listen ~reuse_addr ~reuse_port ~backlog ~sw (listen_addr : Eio.Net.Sockaddr.stream) = + let socket_type, addr, is_unix_socket = + match listen_addr with + | `Unix path -> + if reuse_addr then ( + match Low_level.lstat path with + | Unix.{ st_kind = S_SOCK; _ } -> Unix.unlink path + | _ -> () + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () + | exception Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg + ); + Unix.SOCK_STREAM, Unix.ADDR_UNIX path, true + | `Tcp (host, port) -> + let host = Eio_unix.Net.Ipaddr.to_unix host in + Unix.SOCK_STREAM, Unix.ADDR_INET (host, port), false + in + let sock = Low_level.socket ~sw (socket_domain_of listen_addr) socket_type 0 in + (* For Unix domain sockets, remove the path when done (except for abstract sockets). *) + let hook = + match listen_addr with + | `Unix path when String.length path > 0 && path.[0] <> Char.chr 0 -> + Switch.on_release_cancellable sw (fun () -> Unix.unlink path) + | `Unix _ | `Tcp _ -> + Switch.null_hook + in + Fd.use_exn "listen" sock (fun fd -> + (* REUSEADDR cannot be set on a Windows UNIX domain socket, + otherwise the Unix.bind will fail! *) + if not is_unix_socket && reuse_addr then + Unix.setsockopt fd Unix.SO_REUSEADDR true; + if reuse_port then + Unix.setsockopt fd Unix.SO_REUSEPORT true; + Unix.bind fd addr; + Unix.listen fd backlog + ); + (listening_socket ~hook sock :> _ Eio.Net.listening_socket_ty r) + +let connect ~sw connect_addr = + let socket_type, addr = + match connect_addr with + | `Unix path -> Unix.SOCK_STREAM, Unix.ADDR_UNIX path + | `Tcp (host, port) -> + let host = Eio_unix.Net.Ipaddr.to_unix host in + Unix.SOCK_STREAM, Unix.ADDR_INET (host, port) + in + let sock = Low_level.socket ~sw (socket_domain_of connect_addr) socket_type 0 in + try + Low_level.connect sock addr; + (Flow.of_fd sock :> _ Eio_unix.Net.stream_socket) + with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) + +let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr = + let sock = Low_level.socket ~sw (socket_domain_of saddr) Unix.SOCK_DGRAM 0 in + begin match saddr with + | `Udp _ | `Unix _ as saddr -> + let addr = Eio_unix.Net.sockaddr_to_unix saddr in + Fd.use_exn "datagram_socket" sock (fun fd -> + if reuse_addr then + Unix.setsockopt fd Unix.SO_REUSEADDR true; + if reuse_port then + Unix.setsockopt fd Unix.SO_REUSEPORT true; + Unix.bind fd addr + ) + | `UdpV4 | `UdpV6 -> () + end; + datagram_socket sock + +module Impl = struct + type t = unit + type tag = [`Generic | `Unix] + + let listen () = listen + + let connect () ~sw addr = + let socket = connect ~sw addr in + (socket :> [`Generic | `Unix] Eio.Net.stream_socket_ty r) + + let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr = + let socket = create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr in + (socket :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r) + + let getaddrinfo () = getaddrinfo + let getnameinfo () = Eio_unix.Net.getnameinfo +end + +let v : Impl.tag Eio.Net.ty r = + let handler = Eio.Net.Pi.network (module Impl) in + Eio.Resource.T ((), handler) diff --git a/lib_eio_windows/sched.ml b/lib_eio_windows/sched.ml index 6b504d0d2..1d0e25ca2 100755 --- a/lib_eio_windows/sched.ml +++ b/lib_eio_windows/sched.ml @@ -1,387 +1,387 @@ -(* - * Copyright (C) 2023 Thomas Leonard - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -module Suspended = Eio_utils.Suspended -module Zzz = Eio_utils.Zzz -module Lf_queue = Eio_utils.Lf_queue -module Fiber_context = Eio.Private.Fiber_context -module Trace = Eio.Private.Trace -module Rcfd = Eio_unix.Private.Rcfd - -type exit = [`Exit_scheduler] - -(* The type of items in the run queue. *) -type runnable = - | IO : runnable (* Reminder to check for IO *) - | Thread : 'a Suspended.t * 'a -> runnable (* Resume a fiber with a result value *) - | Failed_thread : 'a Suspended.t * exn -> runnable (* Resume a fiber with an exception *) - -(* For each FD we track which fibers are waiting for it to become readable/writeable. *) -type fd_event_waiters = { - read : unit Suspended.t Lwt_dllist.t; - write : unit Suspended.t Lwt_dllist.t; -} - -module FdCompare = struct - type t = Unix.file_descr - let compare = Stdlib.compare -end - -module FdSet = Set.Make (FdCompare) - -(* A structure for storing the file descriptors for select. *) -type poll = { - mutable to_read : FdSet.t; - mutable to_write : FdSet.t; -} - -type t = { - (* The queue of runnable fibers ready to be resumed. Note: other domains can also add work items here. *) - run_q : runnable Lf_queue.t; - - poll : poll; - fd_map : (Unix.file_descr, fd_event_waiters) Hashtbl.t; - - (* When adding to [run_q] from another domain, this domain may be sleeping and so won't see the event. - In that case, [need_wakeup = true] and you must signal using [eventfd]. *) - eventfd : Rcfd.t; (* For sending events. *) - eventfd_r : Unix.file_descr; (* For reading events. *) - - mutable active_ops : int; (* Exit when this is zero and [run_q] and [sleep_q] are empty. *) - - (* If [false], the main thread will check [run_q] before sleeping again - (possibly because an event has been or will be sent to [eventfd]). - It can therefore be set to [false] in either of these cases: - - By the receiving thread because it will check [run_q] before sleeping, or - - By the sending thread because it will signal the main thread later *) - need_wakeup : bool Atomic.t; - - sleep_q: Zzz.t; (* Fibers waiting for timers. *) - - thread_pool : Eio_unix.Private.Thread_pool.t; -} - -(* The message to send to [eventfd] (any character would do). *) -let wake_buffer = Bytes.of_string "!" - -(* This can be called from any systhread (including ones not running Eio), - and also from signal handlers or GC finalizers. It must not take any locks. *) -let wakeup t = - Atomic.set t.need_wakeup false; (* [t] will check [run_q] after getting the event below *) - Rcfd.use t.eventfd - ~if_closed:ignore (* Domain has shut down (presumably after handling the event) *) - (fun fd -> - (* This can fail if the pipe is full, but then a wake up is pending anyway. *) - ignore (Unix.single_write fd wake_buffer 0 1 : int); - ) - -(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) -let enqueue_thread t k x = - Lf_queue.push t.run_q (Thread (k, x)); - if Atomic.get t.need_wakeup then wakeup t - -(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) -let enqueue_failed_thread t k ex = - Lf_queue.push t.run_q (Failed_thread (k, ex)); - if Atomic.get t.need_wakeup then wakeup t - -(* Can only be called from our own domain, so no need to check for wakeup. *) -let enqueue_at_head t k = - Lf_queue.push_head t.run_q (Thread (k, ())) - -let get_waiters t fd = - match Hashtbl.find_opt t.fd_map fd with - | Some x -> x - | None -> - let x = { read = Lwt_dllist.create (); write = Lwt_dllist.create () } in - Hashtbl.add t.fd_map fd x; - x - -(* The OS told us that the event pipe is ready. Remove events. *) -let clear_event_fd t = - let buf = Bytes.create 8 in (* Read up to 8 events at a time *) - let got = Unix.read t.eventfd_r buf 0 (Bytes.length buf) in - assert (got > 0) - -(* Update [t.poll]'s entry for [fd] to match [waiters]. *) -let update t waiters fd = - let flags = - match not (Lwt_dllist.is_empty waiters.read), - not (Lwt_dllist.is_empty waiters.write) with - | false, false -> `Empty - | true, false -> `R - | false, true -> `W - | true, true -> `RW - in - match flags with - | `Empty -> ( - t.poll.to_read <- FdSet.remove fd t.poll.to_read; - t.poll.to_write <- FdSet.remove fd t.poll.to_write; - Hashtbl.remove t.fd_map fd - ) - | `R -> t.poll.to_read <- FdSet.add fd t.poll.to_read - | `W -> t.poll.to_write <- FdSet.add fd t.poll.to_write - | `RW -> - t.poll.to_read <- FdSet.add fd t.poll.to_read; - t.poll.to_write <- FdSet.add fd t.poll.to_write - -let resume t node = - t.active_ops <- t.active_ops - 1; - let k : unit Suspended.t = Lwt_dllist.get node in - Fiber_context.clear_cancel_fn k.fiber; - enqueue_thread t k () - -(* Called when poll indicates that an event we requested for [fd] is ready. *) -let ready t revents fd = - if fd == t.eventfd_r then ( - clear_event_fd t - (* The scheduler will now look at the run queue again and notice any new items. *) - ) else ( - let waiters = Hashtbl.find t.fd_map fd in - let pending = Lwt_dllist.create () in - if List.mem `W revents then - Lwt_dllist.transfer_l waiters.write pending; - if List.mem `R revents then - Lwt_dllist.transfer_l waiters.read pending; - (* If pending has things, it means we modified the waiters, refresh our view *) - if not (Lwt_dllist.is_empty pending) then - update t waiters fd; - Lwt_dllist.iter_node_r (resume t) pending - ) - -(* Switch control to the next ready continuation. - If none is ready, wait until we get an event to wake one and then switch. - Returns only if there is nothing to do and no active operations. *) -let rec next t : [`Exit_scheduler] = - (* Wakeup any paused fibers *) - match Lf_queue.pop t.run_q with - | None -> assert false (* We should always have an IO job, at least *) - | Some Thread (k, v) -> (* We already have a runnable task *) - Fiber_context.clear_cancel_fn k.fiber; - Suspended.continue k v - | Some Failed_thread (k, ex) -> - Fiber_context.clear_cancel_fn k.fiber; - Suspended.discontinue k ex - | Some IO -> (* Note: be sure to re-inject the IO task before continuing! *) - (* This is not a fair scheduler: timers always run before all other IO *) - let now = Mtime_clock.now () in - match Zzz.pop ~now t.sleep_q with - | `Due k -> - (* A sleeping task is now due *) - Lf_queue.push t.run_q IO; (* Re-inject IO job in the run queue *) - begin match k with - | Fiber k -> Suspended.continue k () - | Fn fn -> fn (); next t - end - | `Wait_until _ | `Nothing as next_due -> - let timeout = - match next_due with - | `Wait_until time -> - let time = Mtime.to_uint64_ns time in - let now = Mtime.to_uint64_ns now in - let diff_ns = Int64.sub time now in - (* Convert to seconds for Unix.select *) - let diff = Int64.(to_float diff_ns) /. 1_000_000_000. in - diff - | `Nothing -> (-1.) - in - if timeout < 0. && t.active_ops = 0 && Lf_queue.is_empty t.run_q then ( - (* Nothing further can happen at this point. *) - Lf_queue.close t.run_q; (* Just to catch bugs if something tries to enqueue later *) - `Exit_scheduler - ) else ( - Atomic.set t.need_wakeup true; - let timeout = - if Lf_queue.is_empty t.run_q then timeout - else ( - (* Either we're just checking for IO to avoid starvation, or - someone added a new job while we were setting [need_wakeup] to [true]. - They might or might not have seen that, so we can't be sure they'll send an event. *) - 0.0 - ) - in - (* At this point we're not going to check [run_q] again before sleeping. - If [need_wakeup] is still [true], this is fine because we don't promise to do that. - If [need_wakeup = false], a wake-up event will arrive and wake us up soon. *) - Trace.suspend_domain Begin; - let cons fd acc = fd :: acc in - let read = FdSet.fold cons t.poll.to_read [] in - let write = FdSet.fold cons t.poll.to_write [] in - match Unix.select read write [] timeout with - | exception Unix.(Unix_error (EINTR, _, _)) -> - Trace.suspend_domain End; - next t - | readable, writeable, _ -> - Trace.suspend_domain End; - Atomic.set t.need_wakeup false; - Lf_queue.push t.run_q IO; (* Re-inject IO job in the run queue *) - List.iter (ready t [ `W ]) writeable; - List.iter (ready t [ `R ]) readable; - next t - ) - -let with_sched fn = - let run_q = Lf_queue.create () in - Lf_queue.push run_q IO; - let sleep_q = Zzz.create () in - (* Pipes on Windows cannot be nonblocking through the OCaml API. *) - let eventfd_r, eventfd_w = Unix.socketpair ~cloexec:true Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unix.set_nonblock eventfd_r; - Unix.set_nonblock eventfd_w; - let eventfd = Rcfd.make eventfd_w in - let cleanup () = - Unix.close eventfd_r; - let was_open = Rcfd.close eventfd in - assert was_open - in - let poll = { to_read = FdSet.empty; to_write = FdSet.empty } in - let fd_map = Hashtbl.create 10 in - let thread_pool = Eio_unix.Private.Thread_pool.create ~sleep_q in - let t = { run_q; poll; fd_map; eventfd; eventfd_r; - active_ops = 0; need_wakeup = Atomic.make false; sleep_q; thread_pool } in - t.poll.to_read <- FdSet.add eventfd_r t.poll.to_read; - match fn t with - | x -> cleanup (); x - | exception ex -> - let bt = Printexc.get_raw_backtrace () in - cleanup (); - Printexc.raise_with_backtrace ex bt - -let await_readable t (k : unit Suspended.t) fd = - match Fiber_context.get_error k.fiber with - | Some e -> Suspended.discontinue k e - | None -> - t.active_ops <- t.active_ops + 1; - let waiters = get_waiters t fd in - let was_empty = Lwt_dllist.is_empty waiters.read in - let node = Lwt_dllist.add_l k waiters.read in - if was_empty then update t waiters fd; - Fiber_context.set_cancel_fn k.fiber (fun ex -> - Lwt_dllist.remove node; - if Lwt_dllist.is_empty waiters.read then - update t waiters fd; - t.active_ops <- t.active_ops - 1; - enqueue_failed_thread t k ex - ); - next t - -let await_writable t (k : unit Suspended.t) fd = - match Fiber_context.get_error k.fiber with - | Some e -> Suspended.discontinue k e - | None -> - t.active_ops <- t.active_ops + 1; - let waiters = get_waiters t fd in - let was_empty = Lwt_dllist.is_empty waiters.write in - let node = Lwt_dllist.add_l k waiters.write in - if was_empty then update t waiters fd; - Fiber_context.set_cancel_fn k.fiber (fun ex -> - Lwt_dllist.remove node; - if Lwt_dllist.is_empty waiters.write then - update t waiters fd; - t.active_ops <- t.active_ops - 1; - enqueue_failed_thread t k ex - ); - next t - -let get_enqueue t k = function - | Ok v -> enqueue_thread t k v - | Error ex -> enqueue_failed_thread t k ex - -let await_timeout t (k : unit Suspended.t) time = - match Fiber_context.get_error k.fiber with - | Some e -> Suspended.discontinue k e - | None -> - let node = Zzz.add t.sleep_q time (Fiber k) in - Fiber_context.set_cancel_fn k.fiber (fun ex -> - Zzz.remove t.sleep_q node; - enqueue_failed_thread t k ex - ); - next t - -let with_op t fn x = - t.active_ops <- t.active_ops + 1; - match fn x with - | r -> - t.active_ops <- t.active_ops - 1; - r - | exception ex -> - t.active_ops <- t.active_ops - 1; - raise ex - -[@@@alert "-unstable"] - -type _ Effect.t += Enter : (t -> 'a Eio_utils.Suspended.t -> [`Exit_scheduler]) -> 'a Effect.t -let enter fn = Effect.perform (Enter fn) - -let run ~extra_effects t main x = - let rec fork ~new_fiber:fiber fn = - let open Effect.Deep in - Trace.fiber (Fiber_context.tid fiber); - match_with fn () - { retc = (fun () -> Fiber_context.destroy fiber; next t); - exnc = (fun ex -> - Fiber_context.destroy fiber; - Printexc.raise_with_backtrace ex (Printexc.get_raw_backtrace ()) - ); - effc = fun (type a) (e : a Effect.t) -> - match e with - | Enter fn -> Some (fun k -> - match Fiber_context.get_error fiber with - | Some e -> discontinue k e - | None -> fn t { Suspended.k; fiber } - ) - | Eio.Private.Effects.Get_context -> Some (fun k -> continue k fiber) - | Eio.Private.Effects.Suspend f -> Some (fun k -> - let k = { Suspended.k; fiber } in - let enqueue = get_enqueue t k in - f fiber enqueue; - next t - ) - | Eio.Private.Effects.Fork (new_fiber, f) -> Some (fun k -> - let k = { Suspended.k; fiber } in - enqueue_at_head t k; - fork ~new_fiber f - ) - | Eio_unix.Private.Await_readable fd -> Some (fun k -> - await_readable t { Suspended.k; fiber } fd - ) - | Eio_unix.Private.Await_writable fd -> Some (fun k -> - await_writable t { Suspended.k; fiber } fd - ) - | Eio_unix.Private.Thread_pool.Run_in_systhread fn -> Some (fun k -> - let k = { Suspended.k; fiber } in - let enqueue x = enqueue_thread t k (x, t.thread_pool) in - Eio_unix.Private.Thread_pool.submit t.thread_pool ~ctx:fiber ~enqueue fn; - next t - ) - | e -> extra_effects.Effect.Deep.effc e - } - in - let result = ref None in - let `Exit_scheduler = - let new_fiber = Fiber_context.make_root () in - Domain_local_await.using - ~prepare_for_await:Eio_utils.Dla.prepare_for_await - ~while_running:(fun () -> - fork ~new_fiber (fun () -> - Eio_unix.Private.Thread_pool.run t.thread_pool @@ fun () -> - result := Some (with_op t main x); - ) - ) - in - match !result with - | Some x -> x - | None -> failwith "BUG in scheduler: deadlock detected" +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Suspended = Eio_utils.Suspended +module Zzz = Eio_utils.Zzz +module Lf_queue = Eio_utils.Lf_queue +module Fiber_context = Eio.Private.Fiber_context +module Trace = Eio.Private.Trace +module Rcfd = Eio_unix.Private.Rcfd + +type exit = [`Exit_scheduler] + +(* The type of items in the run queue. *) +type runnable = + | IO : runnable (* Reminder to check for IO *) + | Thread : 'a Suspended.t * 'a -> runnable (* Resume a fiber with a result value *) + | Failed_thread : 'a Suspended.t * exn -> runnable (* Resume a fiber with an exception *) + +(* For each FD we track which fibers are waiting for it to become readable/writeable. *) +type fd_event_waiters = { + read : unit Suspended.t Lwt_dllist.t; + write : unit Suspended.t Lwt_dllist.t; +} + +module FdCompare = struct + type t = Unix.file_descr + let compare = Stdlib.compare +end + +module FdSet = Set.Make (FdCompare) + +(* A structure for storing the file descriptors for select. *) +type poll = { + mutable to_read : FdSet.t; + mutable to_write : FdSet.t; +} + +type t = { + (* The queue of runnable fibers ready to be resumed. Note: other domains can also add work items here. *) + run_q : runnable Lf_queue.t; + + poll : poll; + fd_map : (Unix.file_descr, fd_event_waiters) Hashtbl.t; + + (* When adding to [run_q] from another domain, this domain may be sleeping and so won't see the event. + In that case, [need_wakeup = true] and you must signal using [eventfd]. *) + eventfd : Rcfd.t; (* For sending events. *) + eventfd_r : Unix.file_descr; (* For reading events. *) + + mutable active_ops : int; (* Exit when this is zero and [run_q] and [sleep_q] are empty. *) + + (* If [false], the main thread will check [run_q] before sleeping again + (possibly because an event has been or will be sent to [eventfd]). + It can therefore be set to [false] in either of these cases: + - By the receiving thread because it will check [run_q] before sleeping, or + - By the sending thread because it will signal the main thread later *) + need_wakeup : bool Atomic.t; + + sleep_q: Zzz.t; (* Fibers waiting for timers. *) + + thread_pool : Eio_unix.Private.Thread_pool.t; +} + +(* The message to send to [eventfd] (any character would do). *) +let wake_buffer = Bytes.of_string "!" + +(* This can be called from any systhread (including ones not running Eio), + and also from signal handlers or GC finalizers. It must not take any locks. *) +let wakeup t = + Atomic.set t.need_wakeup false; (* [t] will check [run_q] after getting the event below *) + Rcfd.use t.eventfd + ~if_closed:ignore (* Domain has shut down (presumably after handling the event) *) + (fun fd -> + (* This can fail if the pipe is full, but then a wake up is pending anyway. *) + ignore (Unix.single_write fd wake_buffer 0 1 : int); + ) + +(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) +let enqueue_thread t k x = + Lf_queue.push t.run_q (Thread (k, x)); + if Atomic.get t.need_wakeup then wakeup t + +(* Safe to call from anywhere (other systhreads, domains, signal handlers, GC finalizers) *) +let enqueue_failed_thread t k ex = + Lf_queue.push t.run_q (Failed_thread (k, ex)); + if Atomic.get t.need_wakeup then wakeup t + +(* Can only be called from our own domain, so no need to check for wakeup. *) +let enqueue_at_head t k = + Lf_queue.push_head t.run_q (Thread (k, ())) + +let get_waiters t fd = + match Hashtbl.find_opt t.fd_map fd with + | Some x -> x + | None -> + let x = { read = Lwt_dllist.create (); write = Lwt_dllist.create () } in + Hashtbl.add t.fd_map fd x; + x + +(* The OS told us that the event pipe is ready. Remove events. *) +let clear_event_fd t = + let buf = Bytes.create 8 in (* Read up to 8 events at a time *) + let got = Unix.read t.eventfd_r buf 0 (Bytes.length buf) in + assert (got > 0) + +(* Update [t.poll]'s entry for [fd] to match [waiters]. *) +let update t waiters fd = + let flags = + match not (Lwt_dllist.is_empty waiters.read), + not (Lwt_dllist.is_empty waiters.write) with + | false, false -> `Empty + | true, false -> `R + | false, true -> `W + | true, true -> `RW + in + match flags with + | `Empty -> ( + t.poll.to_read <- FdSet.remove fd t.poll.to_read; + t.poll.to_write <- FdSet.remove fd t.poll.to_write; + Hashtbl.remove t.fd_map fd + ) + | `R -> t.poll.to_read <- FdSet.add fd t.poll.to_read + | `W -> t.poll.to_write <- FdSet.add fd t.poll.to_write + | `RW -> + t.poll.to_read <- FdSet.add fd t.poll.to_read; + t.poll.to_write <- FdSet.add fd t.poll.to_write + +let resume t node = + t.active_ops <- t.active_ops - 1; + let k : unit Suspended.t = Lwt_dllist.get node in + Fiber_context.clear_cancel_fn k.fiber; + enqueue_thread t k () + +(* Called when poll indicates that an event we requested for [fd] is ready. *) +let ready t revents fd = + if fd == t.eventfd_r then ( + clear_event_fd t + (* The scheduler will now look at the run queue again and notice any new items. *) + ) else ( + let waiters = Hashtbl.find t.fd_map fd in + let pending = Lwt_dllist.create () in + if List.mem `W revents then + Lwt_dllist.transfer_l waiters.write pending; + if List.mem `R revents then + Lwt_dllist.transfer_l waiters.read pending; + (* If pending has things, it means we modified the waiters, refresh our view *) + if not (Lwt_dllist.is_empty pending) then + update t waiters fd; + Lwt_dllist.iter_node_r (resume t) pending + ) + +(* Switch control to the next ready continuation. + If none is ready, wait until we get an event to wake one and then switch. + Returns only if there is nothing to do and no active operations. *) +let rec next t : [`Exit_scheduler] = + (* Wakeup any paused fibers *) + match Lf_queue.pop t.run_q with + | None -> assert false (* We should always have an IO job, at least *) + | Some Thread (k, v) -> (* We already have a runnable task *) + Fiber_context.clear_cancel_fn k.fiber; + Suspended.continue k v + | Some Failed_thread (k, ex) -> + Fiber_context.clear_cancel_fn k.fiber; + Suspended.discontinue k ex + | Some IO -> (* Note: be sure to re-inject the IO task before continuing! *) + (* This is not a fair scheduler: timers always run before all other IO *) + let now = Mtime_clock.now () in + match Zzz.pop ~now t.sleep_q with + | `Due k -> + (* A sleeping task is now due *) + Lf_queue.push t.run_q IO; (* Re-inject IO job in the run queue *) + begin match k with + | Fiber k -> Suspended.continue k () + | Fn fn -> fn (); next t + end + | `Wait_until _ | `Nothing as next_due -> + let timeout = + match next_due with + | `Wait_until time -> + let time = Mtime.to_uint64_ns time in + let now = Mtime.to_uint64_ns now in + let diff_ns = Int64.sub time now in + (* Convert to seconds for Unix.select *) + let diff = Int64.(to_float diff_ns) /. 1_000_000_000. in + diff + | `Nothing -> (-1.) + in + if timeout < 0. && t.active_ops = 0 && Lf_queue.is_empty t.run_q then ( + (* Nothing further can happen at this point. *) + Lf_queue.close t.run_q; (* Just to catch bugs if something tries to enqueue later *) + `Exit_scheduler + ) else ( + Atomic.set t.need_wakeup true; + let timeout = + if Lf_queue.is_empty t.run_q then timeout + else ( + (* Either we're just checking for IO to avoid starvation, or + someone added a new job while we were setting [need_wakeup] to [true]. + They might or might not have seen that, so we can't be sure they'll send an event. *) + 0.0 + ) + in + (* At this point we're not going to check [run_q] again before sleeping. + If [need_wakeup] is still [true], this is fine because we don't promise to do that. + If [need_wakeup = false], a wake-up event will arrive and wake us up soon. *) + Trace.suspend_domain Begin; + let cons fd acc = fd :: acc in + let read = FdSet.fold cons t.poll.to_read [] in + let write = FdSet.fold cons t.poll.to_write [] in + match Unix.select read write [] timeout with + | exception Unix.(Unix_error (EINTR, _, _)) -> + Trace.suspend_domain End; + next t + | readable, writeable, _ -> + Trace.suspend_domain End; + Atomic.set t.need_wakeup false; + Lf_queue.push t.run_q IO; (* Re-inject IO job in the run queue *) + List.iter (ready t [ `W ]) writeable; + List.iter (ready t [ `R ]) readable; + next t + ) + +let with_sched fn = + let run_q = Lf_queue.create () in + Lf_queue.push run_q IO; + let sleep_q = Zzz.create () in + (* Pipes on Windows cannot be nonblocking through the OCaml API. *) + let eventfd_r, eventfd_w = Unix.socketpair ~cloexec:true Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.set_nonblock eventfd_r; + Unix.set_nonblock eventfd_w; + let eventfd = Rcfd.make eventfd_w in + let cleanup () = + Unix.close eventfd_r; + let was_open = Rcfd.close eventfd in + assert was_open + in + let poll = { to_read = FdSet.empty; to_write = FdSet.empty } in + let fd_map = Hashtbl.create 10 in + let thread_pool = Eio_unix.Private.Thread_pool.create ~sleep_q in + let t = { run_q; poll; fd_map; eventfd; eventfd_r; + active_ops = 0; need_wakeup = Atomic.make false; sleep_q; thread_pool } in + t.poll.to_read <- FdSet.add eventfd_r t.poll.to_read; + match fn t with + | x -> cleanup (); x + | exception ex -> + let bt = Printexc.get_raw_backtrace () in + cleanup (); + Printexc.raise_with_backtrace ex bt + +let await_readable t (k : unit Suspended.t) fd = + match Fiber_context.get_error k.fiber with + | Some e -> Suspended.discontinue k e + | None -> + t.active_ops <- t.active_ops + 1; + let waiters = get_waiters t fd in + let was_empty = Lwt_dllist.is_empty waiters.read in + let node = Lwt_dllist.add_l k waiters.read in + if was_empty then update t waiters fd; + Fiber_context.set_cancel_fn k.fiber (fun ex -> + Lwt_dllist.remove node; + if Lwt_dllist.is_empty waiters.read then + update t waiters fd; + t.active_ops <- t.active_ops - 1; + enqueue_failed_thread t k ex + ); + next t + +let await_writable t (k : unit Suspended.t) fd = + match Fiber_context.get_error k.fiber with + | Some e -> Suspended.discontinue k e + | None -> + t.active_ops <- t.active_ops + 1; + let waiters = get_waiters t fd in + let was_empty = Lwt_dllist.is_empty waiters.write in + let node = Lwt_dllist.add_l k waiters.write in + if was_empty then update t waiters fd; + Fiber_context.set_cancel_fn k.fiber (fun ex -> + Lwt_dllist.remove node; + if Lwt_dllist.is_empty waiters.write then + update t waiters fd; + t.active_ops <- t.active_ops - 1; + enqueue_failed_thread t k ex + ); + next t + +let get_enqueue t k = function + | Ok v -> enqueue_thread t k v + | Error ex -> enqueue_failed_thread t k ex + +let await_timeout t (k : unit Suspended.t) time = + match Fiber_context.get_error k.fiber with + | Some e -> Suspended.discontinue k e + | None -> + let node = Zzz.add t.sleep_q time (Fiber k) in + Fiber_context.set_cancel_fn k.fiber (fun ex -> + Zzz.remove t.sleep_q node; + enqueue_failed_thread t k ex + ); + next t + +let with_op t fn x = + t.active_ops <- t.active_ops + 1; + match fn x with + | r -> + t.active_ops <- t.active_ops - 1; + r + | exception ex -> + t.active_ops <- t.active_ops - 1; + raise ex + +[@@@alert "-unstable"] + +type _ Effect.t += Enter : (t -> 'a Eio_utils.Suspended.t -> [`Exit_scheduler]) -> 'a Effect.t +let enter fn = Effect.perform (Enter fn) + +let run ~extra_effects t main x = + let rec fork ~new_fiber:fiber fn = + let open Effect.Deep in + Trace.fiber (Fiber_context.tid fiber); + match_with fn () + { retc = (fun () -> Fiber_context.destroy fiber; next t); + exnc = (fun ex -> + Fiber_context.destroy fiber; + Printexc.raise_with_backtrace ex (Printexc.get_raw_backtrace ()) + ); + effc = fun (type a) (e : a Effect.t) -> + match e with + | Enter fn -> Some (fun k -> + match Fiber_context.get_error fiber with + | Some e -> discontinue k e + | None -> fn t { Suspended.k; fiber } + ) + | Eio.Private.Effects.Get_context -> Some (fun k -> continue k fiber) + | Eio.Private.Effects.Suspend f -> Some (fun k -> + let k = { Suspended.k; fiber } in + let enqueue = get_enqueue t k in + f fiber enqueue; + next t + ) + | Eio.Private.Effects.Fork (new_fiber, f) -> Some (fun k -> + let k = { Suspended.k; fiber } in + enqueue_at_head t k; + fork ~new_fiber f + ) + | Eio_unix.Private.Await_readable fd -> Some (fun k -> + await_readable t { Suspended.k; fiber } fd + ) + | Eio_unix.Private.Await_writable fd -> Some (fun k -> + await_writable t { Suspended.k; fiber } fd + ) + | Eio_unix.Private.Thread_pool.Run_in_systhread fn -> Some (fun k -> + let k = { Suspended.k; fiber } in + let enqueue x = enqueue_thread t k (x, t.thread_pool) in + Eio_unix.Private.Thread_pool.submit t.thread_pool ~ctx:fiber ~enqueue fn; + next t + ) + | e -> extra_effects.Effect.Deep.effc e + } + in + let result = ref None in + let `Exit_scheduler = + let new_fiber = Fiber_context.make_root () in + Domain_local_await.using + ~prepare_for_await:Eio_utils.Dla.prepare_for_await + ~while_running:(fun () -> + fork ~new_fiber (fun () -> + Eio_unix.Private.Thread_pool.run t.thread_pool @@ fun () -> + result := Some (with_op t main x); + ) + ) + in + match !result with + | Some x -> x + | None -> failwith "BUG in scheduler: deadlock detected" diff --git a/lib_eio_windows/sched.mli b/lib_eio_windows/sched.mli index 01fc1cbcb..cc17e01db 100755 --- a/lib_eio_windows/sched.mli +++ b/lib_eio_windows/sched.mli @@ -1,44 +1,44 @@ -(** The scheduler keeps track of all suspended fibers and resumes them as appropriate. - - Each Eio domain has one scheduler, which keeps a queue of runnable - processes plus a record of all fibers waiting for IO operations to complete. *) - -type t - -type exit -(** This is equivalent to [unit], but indicates that a function returning this will call {!next} - and so does not return until the whole event loop is finished. Such functions should normally - be called in tail position. *) - -val with_sched : (t -> 'a) -> 'a -(** [with_sched fn] sets up a scheduler and calls [fn t]. - Typically [fn] will call {!run}. - When [fn] returns, the scheduler's resources are freed. *) - -val run : - extra_effects:exit Effect.Deep.effect_handler -> - t -> ('a -> 'b) -> 'a -> 'b [@@alert "-unstable"] -(** [run ~extra_effects t f x] starts an event loop using [t] and runs [f x] as the root fiber within it. - - Unknown effects are passed to [extra_effects]. *) - -val next : t -> exit -(** [next t] asks the scheduler to transfer control to the next runnable fiber, - or wait for an event from the OS if there is none. This should normally be - called in tail position from an effect handler. *) - -val await_readable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit -(** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for reading. *) - -val await_writable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit -(** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for writing. *) - -val await_timeout : t -> unit Eio_utils.Suspended.t -> Mtime.t -> exit -(** [await_timeout t k time] adds [time, k] to the timer. - - When [time] is reached, [k] is resumed. Cancelling [k] removes the entry from the timer. *) - -val enter : (t -> 'a Eio_utils.Suspended.t -> exit) -> 'a -(** [enter fn] suspends the current fiber and runs [fn t k] in the scheduler's context. - - [fn] should either resume [k] immediately itself, or call one of the [await_*] functions above. *) +(** The scheduler keeps track of all suspended fibers and resumes them as appropriate. + + Each Eio domain has one scheduler, which keeps a queue of runnable + processes plus a record of all fibers waiting for IO operations to complete. *) + +type t + +type exit +(** This is equivalent to [unit], but indicates that a function returning this will call {!next} + and so does not return until the whole event loop is finished. Such functions should normally + be called in tail position. *) + +val with_sched : (t -> 'a) -> 'a +(** [with_sched fn] sets up a scheduler and calls [fn t]. + Typically [fn] will call {!run}. + When [fn] returns, the scheduler's resources are freed. *) + +val run : + extra_effects:exit Effect.Deep.effect_handler -> + t -> ('a -> 'b) -> 'a -> 'b [@@alert "-unstable"] +(** [run ~extra_effects t f x] starts an event loop using [t] and runs [f x] as the root fiber within it. + + Unknown effects are passed to [extra_effects]. *) + +val next : t -> exit +(** [next t] asks the scheduler to transfer control to the next runnable fiber, + or wait for an event from the OS if there is none. This should normally be + called in tail position from an effect handler. *) + +val await_readable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit +(** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for reading. *) + +val await_writable : t -> unit Eio_utils.Suspended.t -> Unix.file_descr -> exit +(** [await_readable t k fd] arranges for [k] to be resumed when [fd] is ready for writing. *) + +val await_timeout : t -> unit Eio_utils.Suspended.t -> Mtime.t -> exit +(** [await_timeout t k time] adds [time, k] to the timer. + + When [time] is reached, [k] is resumed. Cancelling [k] removes the entry from the timer. *) + +val enter : (t -> 'a Eio_utils.Suspended.t -> exit) -> 'a +(** [enter fn] suspends the current fiber and runs [fn t k] in the scheduler's context. + + [fn] should either resume [k] immediately itself, or call one of the [await_*] functions above. *) diff --git a/lib_eio_windows/test/dune b/lib_eio_windows/test/dune index 440913208..92d8f8dc4 100755 --- a/lib_eio_windows/test/dune +++ b/lib_eio_windows/test/dune @@ -1,5 +1,5 @@ -(test - (name test) - (package eio_windows) - (build_if (= %{os_type} "Win32")) - (libraries alcotest kcas eio.mock eio_windows)) +(test + (name test) + (package eio_windows) + (build_if (= %{os_type} "Win32")) + (libraries alcotest kcas eio.mock eio_windows)) diff --git a/lib_eio_windows/test/test_fs.ml b/lib_eio_windows/test/test_fs.ml index 75435927b..9140d64d6 100755 --- a/lib_eio_windows/test/test_fs.ml +++ b/lib_eio_windows/test/test_fs.ml @@ -158,6 +158,9 @@ let test_symlink env () = Unix.mkdir "another" 0o700; print_endline @@ Unix.realpath "to-subdir" |} *) + if not (Unix.has_symlink ()) then + Printf.printf "Skipping test_symlink on systems that don't support symlinks.\n" + else let cwd = Eio.Stdenv.cwd env in try_mkdir (cwd / "sandbox"); Unix.symlink ~to_dir:true ".." "sandbox\\to-root"; @@ -277,4 +280,5 @@ let tests env = [ "unlink", `Quick, test_unlink env; "failing-unlink", `Quick, try_failing_unlink env; "rmdir", `Quick, test_remove_dir env; + "mkdirs", `Quick, test_mkdirs env; ] \ No newline at end of file diff --git a/lib_eio_windows/time.ml b/lib_eio_windows/time.ml index 9e07c3956..c0595d53c 100755 --- a/lib_eio_windows/time.ml +++ b/lib_eio_windows/time.ml @@ -1,30 +1,30 @@ -open Eio.Std - -module Mono_clock = struct - type t = unit - type time = Mtime.t - - let now () = Mtime_clock.now () - let sleep_until () time = Low_level.sleep_until time -end - -let mono_clock : Mtime.t Eio.Time.clock_ty r = - let handler = Eio.Time.Pi.clock (module Mono_clock) in - Eio.Resource.T ((), handler) - -module Clock = struct - type t = unit - type time = float - - let now () = Unix.gettimeofday () - - let sleep_until () time = - (* todo: use the realtime clock directly instead of converting to monotonic time. - That is needed to handle adjustments to the system clock correctly. *) - let d = time -. Unix.gettimeofday () in - Eio.Time.Mono.sleep mono_clock d -end - -let clock : float Eio.Time.clock_ty r = - let handler = Eio.Time.Pi.clock (module Clock) in - Eio.Resource.T ((), handler) +open Eio.Std + +module Mono_clock = struct + type t = unit + type time = Mtime.t + + let now () = Mtime_clock.now () + let sleep_until () time = Low_level.sleep_until time +end + +let mono_clock : Mtime.t Eio.Time.clock_ty r = + let handler = Eio.Time.Pi.clock (module Mono_clock) in + Eio.Resource.T ((), handler) + +module Clock = struct + type t = unit + type time = float + + let now () = Unix.gettimeofday () + + let sleep_until () time = + (* todo: use the realtime clock directly instead of converting to monotonic time. + That is needed to handle adjustments to the system clock correctly. *) + let d = time -. Unix.gettimeofday () in + Eio.Time.Mono.sleep mono_clock d +end + +let clock : float Eio.Time.clock_ty r = + let handler = Eio.Time.Pi.clock (module Clock) in + Eio.Resource.T ((), handler) diff --git a/lib_main/dune b/lib_main/dune index 0cdf6327c..34ce274f5 100644 --- a/lib_main/dune +++ b/lib_main/dune @@ -1,14 +1,14 @@ -(library - (name eio_main) - (public_name eio_main) - (libraries - (select linux_backend.ml from - (eio_linux -> linux_backend.enabled.ml) - ( -> linux_backend.disabled.ml)) - (select posix_backend.ml from - (eio_posix -> posix_backend.enabled.ml) - ( -> posix_backend.disabled.ml)) - (select windows_backend.ml from - (eio_windows -> windows_backend.enabled.ml) - ( -> windows_backend.disabled.ml)) - )) +(library + (name eio_main) + (public_name eio_main) + (libraries + (select linux_backend.ml from + (eio_linux -> linux_backend.enabled.ml) + ( -> linux_backend.disabled.ml)) + (select posix_backend.ml from + (eio_posix -> posix_backend.enabled.ml) + ( -> posix_backend.disabled.ml)) + (select windows_backend.ml from + (eio_windows -> windows_backend.enabled.ml) + ( -> windows_backend.disabled.ml)) + )) diff --git a/lib_main/eio_main.ml b/lib_main/eio_main.ml index 2ccc6bad3..487024ff1 100644 --- a/lib_main/eio_main.ml +++ b/lib_main/eio_main.ml @@ -1,15 +1,15 @@ -let force run fn = - run ~fallback:(fun (`Msg msg) -> failwith msg) fn - -let run fn = - match Sys.getenv_opt "EIO_BACKEND" with - | Some ("io-uring" | "linux") -> force Linux_backend.run fn - | Some "posix" -> force Posix_backend.run fn - | Some "windows" -> force Windows_backend.run fn - | None | Some "" -> - Linux_backend.run fn ~fallback:(fun _ -> - Posix_backend.run fn ~fallback:(fun _ -> - force Windows_backend.run fn - ) - ) - | Some x -> Fmt.failwith "Unknown Eio backend %S (from $EIO_BACKEND)" x +let force run fn = + run ~fallback:(fun (`Msg msg) -> failwith msg) fn + +let run fn = + match Sys.getenv_opt "EIO_BACKEND" with + | Some ("io-uring" | "linux") -> force Linux_backend.run fn + | Some "posix" -> force Posix_backend.run fn + | Some "windows" -> force Windows_backend.run fn + | None | Some "" -> + Linux_backend.run fn ~fallback:(fun _ -> + Posix_backend.run fn ~fallback:(fun _ -> + force Windows_backend.run fn + ) + ) + | Some x -> Fmt.failwith "Unknown Eio backend %S (from $EIO_BACKEND)" x diff --git a/lib_main/eio_main.mli b/lib_main/eio_main.mli index df92b0efd..f6e22f38b 100644 --- a/lib_main/eio_main.mli +++ b/lib_main/eio_main.mli @@ -1,23 +1,23 @@ -(** Select a suitable event loop for Eio. *) - -val run : (Eio_unix.Stdenv.base -> 'a) -> 'a -(** [run fn] runs an event loop and then calls [fn env] within it. - - [env] provides access to the process's environment (file-system, network, etc). - [env] itself and the resources inside it can be shared safely between Eio domains. - - When [fn] ends, the event loop finishes. - - This should be called once, at the entry point of an application. - It {b must not} be called by libraries. - Doing so would force the library to depend on Unix - (making it unusable from unikernels or browsers), - prevent the user from choosing their own event loop, - and prevent using the library with other Eio libraries. - - [run] will select an appropriate event loop for the current platform. - On many systems, it will use {!Eio_posix.run}. - - On recent-enough versions of Linux, it will use {!Eio_linux.run}. - You can override this by setting the $EIO_BACKEND environment variable to - either "linux", "posix" or "windows". *) +(** Select a suitable event loop for Eio. *) + +val run : (Eio_unix.Stdenv.base -> 'a) -> 'a +(** [run fn] runs an event loop and then calls [fn env] within it. + + [env] provides access to the process's environment (file-system, network, etc). + [env] itself and the resources inside it can be shared safely between Eio domains. + + When [fn] ends, the event loop finishes. + + This should be called once, at the entry point of an application. + It {b must not} be called by libraries. + Doing so would force the library to depend on Unix + (making it unusable from unikernels or browsers), + prevent the user from choosing their own event loop, + and prevent using the library with other Eio libraries. + + [run] will select an appropriate event loop for the current platform. + On many systems, it will use {!Eio_posix.run}. + + On recent-enough versions of Linux, it will use {!Eio_linux.run}. + You can override this by setting the $EIO_BACKEND environment variable to + either "linux", "posix" or "windows". *) diff --git a/lib_main/linux_backend.disabled.ml b/lib_main/linux_backend.disabled.ml index c87dbf156..ce73ee9b2 100644 --- a/lib_main/linux_backend.disabled.ml +++ b/lib_main/linux_backend.disabled.ml @@ -1 +1 @@ -let run ~fallback _ = fallback (`Msg "The io_uring backend was disabled at compile-time") +let run ~fallback _ = fallback (`Msg "The io_uring backend was disabled at compile-time") diff --git a/lib_main/linux_backend.enabled.ml b/lib_main/linux_backend.enabled.ml index e08dc9738..2941cfa05 100644 --- a/lib_main/linux_backend.enabled.ml +++ b/lib_main/linux_backend.enabled.ml @@ -1 +1 @@ -let run ~fallback fn = Eio_linux.run ~fallback (fun env -> fn (env :> Eio_unix.Stdenv.base)) +let run ~fallback fn = Eio_linux.run ~fallback (fun env -> fn (env :> Eio_unix.Stdenv.base)) diff --git a/lib_main/posix_backend.disabled.ml b/lib_main/posix_backend.disabled.ml index 5d7a1b9b6..43a9a7c74 100644 --- a/lib_main/posix_backend.disabled.ml +++ b/lib_main/posix_backend.disabled.ml @@ -1 +1 @@ -let run ~fallback _ = fallback (`Msg "The POSIX backend was disabled at compile-time") +let run ~fallback _ = fallback (`Msg "The POSIX backend was disabled at compile-time") diff --git a/lib_main/posix_backend.enabled.ml b/lib_main/posix_backend.enabled.ml index 0c1ce2cda..705e2a18d 100644 --- a/lib_main/posix_backend.enabled.ml +++ b/lib_main/posix_backend.enabled.ml @@ -1 +1 @@ -let run ~fallback:_ fn = Eio_posix.run (fun env -> fn (env :> Eio_unix.Stdenv.base)) +let run ~fallback:_ fn = Eio_posix.run (fun env -> fn (env :> Eio_unix.Stdenv.base)) diff --git a/lib_main/windows_backend.disabled.ml b/lib_main/windows_backend.disabled.ml index 44bd75d4b..347a8ae34 100644 --- a/lib_main/windows_backend.disabled.ml +++ b/lib_main/windows_backend.disabled.ml @@ -1 +1 @@ -let run ~fallback _ = fallback (`Msg "The Windows backend was disabled at compile-time") +let run ~fallback _ = fallback (`Msg "The Windows backend was disabled at compile-time") diff --git a/lib_main/windows_backend.enabled.ml b/lib_main/windows_backend.enabled.ml index a682f955e..4045b1af9 100644 --- a/lib_main/windows_backend.enabled.ml +++ b/lib_main/windows_backend.enabled.ml @@ -1 +1 @@ -let run ~fallback:_ fn = Eio_windows.run (fun env -> fn (env :> Eio_unix.Stdenv.base)) +let run ~fallback:_ fn = Eio_windows.run (fun env -> fn (env :> Eio_unix.Stdenv.base)) diff --git a/stress/dune b/stress/dune index 8519a68b3..847637f01 100644 --- a/stress/dune +++ b/stress/dune @@ -1,3 +1,3 @@ -(executables - (names stress_semaphore stress_proc stress_release) - (libraries eio_main)) +(executables + (names stress_semaphore stress_proc stress_release) + (libraries eio_main)) diff --git a/stress/stress_proc.ml b/stress/stress_proc.ml index 4aceb7dd8..dda959e89 100644 --- a/stress/stress_proc.ml +++ b/stress/stress_proc.ml @@ -1,35 +1,35 @@ -open Eio.Std - -let n_domains = 4 -let n_rounds = 100 -let n_procs_per_round_per_domain = 100 / n_domains - -let run_in_domain mgr = - let echo n = Eio.Process.parse_out mgr Eio.Buf_read.line ["sh"; "-c"; "echo " ^ string_of_int n] in - Switch.run @@ fun sw -> - for j = 1 to n_procs_per_round_per_domain do - Fiber.fork ~sw (fun () -> - let result = echo j in - assert (int_of_string result = j); - (* traceln "OK: %d" j *) - ) - done - -let main ~dm mgr = - let t0 = Unix.gettimeofday () in - for i = 1 to n_rounds do - Switch.run ~name:"round" (fun sw -> - for _ = 1 to n_domains - 1 do - Fiber.fork ~sw (fun () -> Eio.Domain_manager.run dm (fun () -> run_in_domain mgr)) - done; - Fiber.fork ~sw (fun () -> run_in_domain mgr); - ); - if true then traceln "Finished round %d/%d" i n_rounds - done; - let t1 = Unix.gettimeofday () in - let n_procs = n_rounds * n_procs_per_round_per_domain * n_domains in - traceln "Finished process stress test: ran %d processes in %.2fs (using %d domains)" n_procs (t1 -. t0) n_domains - -let () = - Eio_main.run @@ fun env -> - main ~dm:env#domain_mgr env#process_mgr +open Eio.Std + +let n_domains = 4 +let n_rounds = 100 +let n_procs_per_round_per_domain = 100 / n_domains + +let run_in_domain mgr = + let echo n = Eio.Process.parse_out mgr Eio.Buf_read.line ["sh"; "-c"; "echo " ^ string_of_int n] in + Switch.run @@ fun sw -> + for j = 1 to n_procs_per_round_per_domain do + Fiber.fork ~sw (fun () -> + let result = echo j in + assert (int_of_string result = j); + (* traceln "OK: %d" j *) + ) + done + +let main ~dm mgr = + let t0 = Unix.gettimeofday () in + for i = 1 to n_rounds do + Switch.run ~name:"round" (fun sw -> + for _ = 1 to n_domains - 1 do + Fiber.fork ~sw (fun () -> Eio.Domain_manager.run dm (fun () -> run_in_domain mgr)) + done; + Fiber.fork ~sw (fun () -> run_in_domain mgr); + ); + if true then traceln "Finished round %d/%d" i n_rounds + done; + let t1 = Unix.gettimeofday () in + let n_procs = n_rounds * n_procs_per_round_per_domain * n_domains in + traceln "Finished process stress test: ran %d processes in %.2fs (using %d domains)" n_procs (t1 -. t0) n_domains + +let () = + Eio_main.run @@ fun env -> + main ~dm:env#domain_mgr env#process_mgr diff --git a/stress/stress_release.ml b/stress/stress_release.ml index b8a99eae0..eeed49a55 100644 --- a/stress/stress_release.ml +++ b/stress/stress_release.ml @@ -1,62 +1,62 @@ -open Eio.Std - -let n_domains = 3 -let n_rounds = 1000 - -(* Each worker domain loops, creating resources and attaching them to the - shared switch [sw]. It also randomly close resources, cancelling the hook. - The main domain finishes the switch while this is happening, freeing all - registered resources. At the end, we check that the number of resources - allocated matches the number freed. *) -let[@warning "-52"] run_domain ~sw ~hooks resources = - try - while true do - Atomic.incr resources; - let hook = Switch.on_release_cancellable sw (fun () -> Atomic.decr resources) in - if Random.bool () then ( - (* Manually close an existing resource. *) - let i = Random.int (Array.length hooks) in - if Switch.try_remove_hook hooks.(i) then - Atomic.decr resources - ); - if Random.bool () then ( - let i = Random.int (Array.length hooks) in - hooks.(i) <- hook; - ) - done - with Invalid_argument "Switch finished!" -> - () - -let main ~pool = - let resources = Array.init n_domains (fun _ -> Atomic.make 0) in - (* Keep up to 10 hooks so we can cancel them randomly too. *) - let hooks = Array.make 10 Switch.null_hook in - for _ = 1 to n_rounds do - (* if i mod 1000 = 0 then traceln "Round %d" i; *) - Switch.run (fun domains_sw -> - Switch.run (fun sw -> - resources |> Array.iter (fun resources -> - Fiber.fork ~sw:domains_sw (fun () -> - Eio.Executor_pool.submit_exn pool ~weight:1.0 (fun () -> run_domain ~sw ~hooks resources) - ) - ); - (* traceln "Wait for domains to start"; *) - while Atomic.get (resources.(n_domains - 1)) < 20 do - Domain.cpu_relax () - done; - ); - (* The child domains will start to finish as they find that - [sw] is not accepting new resources. They may each still - create one last resource. *) - ); - (* All child domains are now finished. *) - let x = Array.fold_left (fun acc resources -> acc + Atomic.get resources) 0 resources in - if x <> 0 then Fmt.failwith "%d resources still open at end!" x - done - -let () = - Eio_main.run @@ fun env -> - let domain_mgr = Eio.Stdenv.domain_mgr env in - Switch.run @@ fun sw -> - let pool = Eio.Executor_pool.create ~sw ~domain_count:n_domains domain_mgr in - main ~pool +open Eio.Std + +let n_domains = 3 +let n_rounds = 1000 + +(* Each worker domain loops, creating resources and attaching them to the + shared switch [sw]. It also randomly close resources, cancelling the hook. + The main domain finishes the switch while this is happening, freeing all + registered resources. At the end, we check that the number of resources + allocated matches the number freed. *) +let[@warning "-52"] run_domain ~sw ~hooks resources = + try + while true do + Atomic.incr resources; + let hook = Switch.on_release_cancellable sw (fun () -> Atomic.decr resources) in + if Random.bool () then ( + (* Manually close an existing resource. *) + let i = Random.int (Array.length hooks) in + if Switch.try_remove_hook hooks.(i) then + Atomic.decr resources + ); + if Random.bool () then ( + let i = Random.int (Array.length hooks) in + hooks.(i) <- hook; + ) + done + with Invalid_argument "Switch finished!" -> + () + +let main ~pool = + let resources = Array.init n_domains (fun _ -> Atomic.make 0) in + (* Keep up to 10 hooks so we can cancel them randomly too. *) + let hooks = Array.make 10 Switch.null_hook in + for _ = 1 to n_rounds do + (* if i mod 1000 = 0 then traceln "Round %d" i; *) + Switch.run (fun domains_sw -> + Switch.run (fun sw -> + resources |> Array.iter (fun resources -> + Fiber.fork ~sw:domains_sw (fun () -> + Eio.Executor_pool.submit_exn pool ~weight:1.0 (fun () -> run_domain ~sw ~hooks resources) + ) + ); + (* traceln "Wait for domains to start"; *) + while Atomic.get (resources.(n_domains - 1)) < 20 do + Domain.cpu_relax () + done; + ); + (* The child domains will start to finish as they find that + [sw] is not accepting new resources. They may each still + create one last resource. *) + ); + (* All child domains are now finished. *) + let x = Array.fold_left (fun acc resources -> acc + Atomic.get resources) 0 resources in + if x <> 0 then Fmt.failwith "%d resources still open at end!" x + done + +let () = + Eio_main.run @@ fun env -> + let domain_mgr = Eio.Stdenv.domain_mgr env in + Switch.run @@ fun sw -> + let pool = Eio.Executor_pool.create ~sw ~domain_count:n_domains domain_mgr in + main ~pool diff --git a/stress/stress_semaphore.ml b/stress/stress_semaphore.ml index 9e206f2a3..e8305b1d8 100644 --- a/stress/stress_semaphore.ml +++ b/stress/stress_semaphore.ml @@ -1,38 +1,38 @@ -open Eio.Std - -(* Three domains fighting over 2 semaphore tokens, - with domains cancelling if they don't get served quickly. *) - -let n_domains = 3 -let n_tokens = 2 -let n_iters = 100_000 - -let main ~domain_mgr = - let sem = Eio.Semaphore.make n_tokens in - Switch.run (fun sw -> - for _ = 1 to n_domains do - Fiber.fork ~sw (fun () -> - Eio.Domain_manager.run domain_mgr (fun () -> - let i = ref 0 in - while !i < n_iters do - let got = ref false in - Fiber.first - (fun () -> Eio.Semaphore.acquire sem; got := true) - (fun () -> Fiber.yield ()); - if !got then ( - incr i; - Eio.Semaphore.release sem; - ) else ( - (* traceln "yield" *) - ) - done - ) - ) - done; - ); - assert (Eio.Semaphore.get_value sem = n_tokens); - print_endline "OK" - -let () = - Eio_main.run @@ fun env -> - main ~domain_mgr:(Eio.Stdenv.domain_mgr env) +open Eio.Std + +(* Three domains fighting over 2 semaphore tokens, + with domains cancelling if they don't get served quickly. *) + +let n_domains = 3 +let n_tokens = 2 +let n_iters = 100_000 + +let main ~domain_mgr = + let sem = Eio.Semaphore.make n_tokens in + Switch.run (fun sw -> + for _ = 1 to n_domains do + Fiber.fork ~sw (fun () -> + Eio.Domain_manager.run domain_mgr (fun () -> + let i = ref 0 in + while !i < n_iters do + let got = ref false in + Fiber.first + (fun () -> Eio.Semaphore.acquire sem; got := true) + (fun () -> Fiber.yield ()); + if !got then ( + incr i; + Eio.Semaphore.release sem; + ) else ( + (* traceln "yield" *) + ) + done + ) + ) + done; + ); + assert (Eio.Semaphore.get_value sem = n_tokens); + print_endline "OK" + +let () = + Eio_main.run @@ fun env -> + main ~domain_mgr:(Eio.Stdenv.domain_mgr env) diff --git a/tests/buf_reader.md b/tests/buf_reader.md index cecce486e..6211cc2c3 100644 --- a/tests/buf_reader.md +++ b/tests/buf_reader.md @@ -1,681 +1,681 @@ -```ocaml -# #require "eio";; -``` -```ocaml -module R = Eio.Buf_read;; -open R.Syntax;; - -let traceln fmt = Fmt.pr ("+" ^^ fmt ^^ "@.") - -let peek t = - let s = Cstruct.to_string (R.peek t) in - assert (String.length s = R.buffered_bytes t); - s - -let ensure t n = - R.ensure t n; - peek t - -(* The next data to be returned by `mock_flow`. `[]` to raise `End_of_file`: *) -let next = ref [] - -let mock_flow = - let module X = struct - type t = unit - - let read_methods = [] - - let single_read () buf = - match !next with - | [] -> - traceln "mock_flow returning Eof"; - raise End_of_file - | x :: xs -> - let len = min (Cstruct.length buf) (String.length x) in - traceln "mock_flow returning %d bytes" len; - Cstruct.blit_from_string x 0 buf 0 len; - let x' = String.sub x len (String.length x - len) in - next := (if x' = "" then xs else x' :: xs); - len - end in - let ops = Eio.Flow.Pi.source (module X) in - Eio.Resource.T ((), ops) - -let read flow n = - let buf = Cstruct.create n in - let len = Eio.Flow.single_read flow buf in - traceln "Read %S" (Cstruct.to_string buf ~len) - -let is_digit = function - | '0'..'9' -> true - | _ -> false - -let test ?(max_size=10) input p = - next := input; - let i = R.of_flow mock_flow ~max_size in - p i - -let parse_exn p flow ~max_size = - match R.parse_exn p flow ~max_size with - | x -> traceln "Ok: %S" x - | exception Failure msg -> traceln "Failure: %s" msg -``` - - -## A simple run-through - -```ocaml -# let i = R.of_flow (Eio.Flow.string_source "Hello") ~max_size:100;; -val i : R.t = -# peek i;; -- : string = "" -# ensure i 1;; -- : string = "Hello" -# R.consume i 1;; -- : unit = () -# peek i;; -- : string = "ello" -# ensure i 4;; -- : string = "ello" -# ensure i 5;; -Exception: End_of_file. -# peek i;; -- : string = "ello" -# R.consume i 4;; -- : unit = () -# peek i;; -- : string = "" -``` - -## Minimising reads on the underlying flow - -```ocaml -# let i = R.of_flow mock_flow ~initial_size:4 ~max_size:10;; -val i : R.t = -``` - -The first read fills the initial buffer: -```ocaml -# next := ["hello world!"]; ensure i 1;; -+mock_flow returning 4 bytes -- : string = "hell" -``` - -The next read forces a resize (doubling to 8): -```ocaml -# ensure i 5;; -+mock_flow returning 4 bytes -- : string = "hello wo" -``` - -Now the buffer is at max-size (10): -```ocaml -# ensure i 9;; -+mock_flow returning 2 bytes -- : string = "hello worl" -# ensure i 10;; -- : string = "hello worl" -# ensure i 11;; -Exception: Eio__Buf_read.Buffer_limit_exceeded. -``` - -Sometimes, doubling isn't enough. Here we go straight to 10 bytes: - -```ocaml -# let i = R.of_flow mock_flow ~initial_size:4 ~max_size:10;; -val i : R.t = -# next := ["hello world!"]; ensure i 10;; -+mock_flow returning 10 bytes -- : string = "hello worl" -``` - -## End-of-file - -After getting end-of-file, we don't use the flow any more: - -```ocaml -# let i = R.of_flow mock_flow ~initial_size:4 ~max_size:10;; -val i : R.t = -# next := ["hi"]; ensure i 10;; -+mock_flow returning 2 bytes -+mock_flow returning Eof -Exception: End_of_file. -# peek i;; -- : string = "hi" -# ensure i 10;; -Exception: End_of_file. -# R.take_all i;; -- : string = "hi" -# R.take_all i;; -- : string = "" -``` - -## Multiple reads - -We might need several reads to fulfill the user's request: -```ocaml -# let i = R.of_flow mock_flow ~initial_size:4 ~max_size:10;; -val i : R.t = -# next := ["one"; "two"; "three"]; ensure i 10;; -+mock_flow returning 3 bytes -+mock_flow returning 3 bytes -+mock_flow returning 4 bytes -- : string = "onetwothre" -# R.consume i 4; ensure i 7;; -+mock_flow returning 1 bytes -- : string = "wothree" -``` - -## Reading lines - -```ocaml -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = -# next := ["one"; "\ntwo\n"; "three\n"]; R.line i;; -+mock_flow returning 3 bytes -+mock_flow returning 5 bytes -- : string = "one" -# R.line i;; -- : string = "two" -# R.line i;; -+mock_flow returning 6 bytes -- : string = "three" -# R.line i;; -+mock_flow returning Eof -Exception: End_of_file. -``` - -DOS lines: - -```ocaml -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = -# next := ["one\r"; "\ntwo\r\n"; "three\r\n"]; R.line i;; -+mock_flow returning 4 bytes -+mock_flow returning 6 bytes -- : string = "one" -# R.line i;; -- : string = "two" -# R.line i;; -+mock_flow returning 7 bytes -- : string = "three" -# R.line i;; -+mock_flow returning Eof -Exception: End_of_file. -``` - -Missing EOL: - -```ocaml -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = -# next := ["on"; "e\ntwo"]; R.line i;; -+mock_flow returning 2 bytes -+mock_flow returning 5 bytes -- : string = "one" -# R.line i;; -+mock_flow returning Eof -- : string = "two" -``` - -Multiple lines in one read: - -```ocaml -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = -# next := ["one\ntwo\n\nthree"]; R.line i;; -+mock_flow returning 14 bytes -- : string = "one" -# R.line i;; -- : string = "two" -# R.line i;; -- : string = "" -# R.line i;; -+mock_flow returning Eof -- : string = "three" -# R.line i;; -Exception: End_of_file. -``` - -## Flow interface - -```ocaml -# let bflow = R.of_flow mock_flow ~max_size:100 |> R.as_flow;; -val bflow : Eio__Flow.source_ty Eio.Std.r = - Eio__.Resource.T (, ) -# next := ["foo"; "bar"]; read bflow 2;; -+mock_flow returning 3 bytes -+Read "fo" -- : unit = () -# read bflow 2;; -+Read "o" -- : unit = () -# read bflow 2;; -+mock_flow returning 3 bytes -+Read "ba" -- : unit = () -# read bflow 2;; -+Read "r" -- : unit = () -# read bflow 2;; -+mock_flow returning Eof -Exception: End_of_file. -``` - -## Characters - -```ocaml -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = - -# next := ["ab"; "c"]; R.any_char i;; -+mock_flow returning 2 bytes -- : char = 'a' - -# R.peek_char i;; -- : char option = Some 'b' - -# R.any_char i;; -- : char = 'b' - -# R.any_char i;; -+mock_flow returning 1 bytes -- : char = 'c' - -# R.any_char i;; -+mock_flow returning Eof -Exception: End_of_file. - -# R.peek_char i;; -- : char option = None -``` - -## Fixed-length strings - -```ocaml -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = -# next := ["ab"; "c"]; R.take 1 i;; -+mock_flow returning 2 bytes -- : string = "a" -# R.take 3 i;; -+mock_flow returning 1 bytes -+mock_flow returning Eof -Exception: End_of_file. -# R.take 2 i;; -- : string = "bc" -``` - -## Literals - -```ocaml -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = -# next := ["ab"; "c"]; R.char 'A' i;; -+mock_flow returning 2 bytes -Exception: Failure "Expected 'A' but got 'a'". -# R.char 'a' i;; -- : unit = () -# R.string "BC" i;; -Exception: Failure "Expected \"BC\" but got \"b\"". -# R.string "bC" i;; -+mock_flow returning 1 bytes -Exception: Failure "Expected \"bC\" but got \"bc\"". -# R.string "bcd" i;; -+mock_flow returning Eof -Exception: End_of_file. -# R.string "bcd" i;; -Exception: End_of_file. -# R.string "bc" i;; -- : unit = () -# peek i;; -- : string = "" -``` - -## Scanning - -```ocaml -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = - -# next := ["aa"; "a0"; "123de"]; R.skip_while ((=) 'a') i;; -+mock_flow returning 2 bytes -+mock_flow returning 2 bytes -- : unit = () - -# R.take_while is_digit i;; -+mock_flow returning 5 bytes -- : string = "0123" - -# R.take_while (Fun.negate is_digit) i;; -+mock_flow returning Eof -- : string = "de" - -# test ["abc"; "def"; "ghi"] (R.skip 5 *> R.take_all);; -+mock_flow returning 3 bytes -+mock_flow returning 3 bytes -+mock_flow returning 3 bytes -+mock_flow returning Eof -- : string = "fghi" - -# test ~max_size:3 ["abcdefg"] (R.skip 5 *> R.take_all);; -+mock_flow returning 3 bytes -+mock_flow returning 3 bytes -+mock_flow returning 1 bytes -+mock_flow returning Eof -- : string = "fg" - -# let is_a = function - | 'a' -> true - | _ -> false;; -val is_a : char -> bool = - -# test ["aaabc"] (R.take_while1 is_a);; -+mock_flow returning 5 bytes -- : string = "aaa" - -# test ["aaabc"] (R.take_while1 (Fun.negate is_a));; -+mock_flow returning 5 bytes -Exception: Failure "take_while1". - -# test ["abc"] (R.take_while1 is_a);; -+mock_flow returning 3 bytes -- : string = "a" - -# test ["aaaaabc"] (R.skip_while1 is_a *> R.take_all);; -+mock_flow returning 7 bytes -+mock_flow returning Eof -- : string = "bc" - -# test ["bbbccc"] (R.skip_while1 is_a *> R.take_all);; -+mock_flow returning 6 bytes -Exception: Failure "skip_while1". - -# test ["abbbccc"] (R.skip_while1 is_a *> R.take_all);; -+mock_flow returning 7 bytes -+mock_flow returning Eof -- : string = "bbbccc" -``` - -## Big Endian -```ocaml -# R.parse_string_exn R.BE.uint16 "\128\001" |> Printf.sprintf "0x%x";; -- : string = "0x8001" -# R.parse_string_exn R.BE.uint32 "\128\064\032\001" |> Printf.sprintf "0x%lx";; -- : string = "0x80402001" -# R.parse_string_exn R.BE.uint48 "\128\064\032\016\008\001" |> Printf.sprintf "0x%Lx";; -- : string = "0x804020100801" -# R.parse_string_exn R.BE.uint64 "\128\064\032\016\008\004\002\001" |> Printf.sprintf "0x%Lx";; -- : string = "0x8040201008040201" -# R.parse_string_exn R.BE.float "\128\064\032\001" |> Printf.sprintf "0x%e";; -- : string = "0x-5.888953e-39" -# R.parse_string_exn R.BE.double "\128\064\032\016\008\004\002\001" |> Printf.sprintf "0x%e";; -- : string = "0x-1.793993e-307" -``` - -## Little Endian -```ocaml -# R.parse_string_exn R.LE.uint16 "\128\001" |> Printf.sprintf "0x%x";; -- : string = "0x180" -# R.parse_string_exn R.LE.uint32 "\128\064\032\001" |> Printf.sprintf "0x%lx";; -- : string = "0x1204080" -# R.parse_string_exn R.LE.uint48 "\128\064\032\016\008\001" |> Printf.sprintf "0x%Lx";; -- : string = "0x10810204080" -# R.parse_string_exn R.LE.uint64 "\128\064\032\016\008\004\002\001" |> Printf.sprintf "0x%Lx";; -- : string = "0x102040810204080" -# R.parse_string_exn R.LE.float "\128\064\032\001" |> Printf.sprintf "0x%e";; -- : string = "0x2.943364e-38" -# R.parse_string_exn R.LE.double "\128\064\032\016\008\004\002\001" |> Printf.sprintf "0x%e";; -- : string = "0x8.209689e-304" -``` - -## Take all - -```ocaml -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = -# next := ["20 text/gemini\r\n"; "# Introduction\n"; "# Conclusion\n"]; R.line i;; -+mock_flow returning 16 bytes -- : string = "20 text/gemini" -# R.take_all i;; -+mock_flow returning 15 bytes -+mock_flow returning 13 bytes -+mock_flow returning Eof -- : string = "# Introduction\n# Conclusion\n" -``` - -```ocaml -# let i = R.of_flow mock_flow ~max_size:10;; -val i : R.t = -# next := ["abc"; "def"; "ghi"; "jkl"]; R.take_all i;; -+mock_flow returning 3 bytes -+mock_flow returning 3 bytes -+mock_flow returning 3 bytes -+mock_flow returning 1 bytes -Exception: Eio__Buf_read.Buffer_limit_exceeded. -# R.take 3 i;; -- : string = "abc" -``` - -## Combinators - -Parsers can be combined in the usual ways: - -```ocaml -# test ["abc"] (R.map String.uppercase_ascii (R.take 2));; -+mock_flow returning 3 bytes -- : string = "AB" - -# test ["abc"] (R.pair R.any_char R.take_all);; -+mock_flow returning 3 bytes -+mock_flow returning Eof -- : char * string = ('a', "bc") - -# test ["abc"] (R.bind R.any_char R.char);; -+mock_flow returning 3 bytes -Exception: Failure "Expected 'a' but got 'b'". -``` - -Syntax: - -```ocaml -# test ["abc"] (let+ x = R.take 2 in String.uppercase_ascii x);; -+mock_flow returning 3 bytes -- : string = "AB" - -# test ["abc"] (let+ x = R.any_char and+ y = R.take_all in (x, y));; -+mock_flow returning 3 bytes -+mock_flow returning Eof -- : char * string = ('a', "bc") - -# test ["abc"] (let* x = R.any_char in R.char x);; -+mock_flow returning 3 bytes -Exception: Failure "Expected 'a' but got 'b'". - -# test ["aac"] (let* x = R.any_char in R.char x *> R.take_all);; -+mock_flow returning 3 bytes -+mock_flow returning Eof -- : string = "c" - -# test ["ab"] (R.any_char <* R.any_char);; -+mock_flow returning 2 bytes -- : char = 'a' - -# test ["ab"] (R.any_char *> R.any_char);; -+mock_flow returning 2 bytes -- : char = 'b' -``` - -## Error handling - -```ocaml -# test ["abc"] R.(format_errors (take 3));; -+mock_flow returning 3 bytes -- : (string, [> `Msg of string ]) result = Ok "abc" - -# test ["abc"] R.(format_errors (take 2 <* end_of_input));; -+mock_flow returning 3 bytes -- : (string, [> `Msg of string ]) result = -Error (`Msg "Unexpected data after parsing (at offset 2)") - -# test ["abc"] R.(format_errors (take 4 <* end_of_input));; -+mock_flow returning 3 bytes -+mock_flow returning Eof -- : (string, [> `Msg of string ]) result = -Error (`Msg "Unexpected end-of-file at offset 3") - -# test ~max_size:2 ["abc"] R.(format_errors line);; -+mock_flow returning 2 bytes -- : (string, [> `Msg of string ]) result = -Error (`Msg "Buffer size limit exceeded when reading at offset 0") -``` - -## Sequences - -```ocaml -# test ["one"; "\ntwo\n"; "three"] R.lines |> Seq.iter (traceln "%S");; -+mock_flow returning 3 bytes -+mock_flow returning 5 bytes -+"one" -+"two" -+mock_flow returning 5 bytes -+mock_flow returning Eof -+"three" -- : unit = () - -# test ["abcd1234"] R.(seq (take 2)) |> List.of_seq |> String.concat ",";; -+mock_flow returning 8 bytes -+mock_flow returning Eof -- : string = "ab,cd,12,34" - -# test ["abcd123"] R.(seq (take 2)) |> List.of_seq |> String.concat ",";; -+mock_flow returning 7 bytes -+mock_flow returning Eof -Exception: End_of_file. -``` - -A sequence node remembers its offset and fails if used out of sequence: - -```ocaml -# next := ["one"; "\ntwo\n"; "three"];; -- : unit = () -# let i = R.of_flow mock_flow ~max_size:100;; -val i : R.t = -# let seq = R.lines i;; -val seq : string Seq.t = -# let line, seq' = match seq () with Cons (a, b) -> (a, b) | _ -> assert false;; -+mock_flow returning 3 bytes -+mock_flow returning 5 bytes -val line : string = "one" -val seq' : string Seq.t = - -# seq ();; -Exception: -Invalid_argument - "Sequence is stale (expected to be used at offset 0, but stream is now at 4)". - -# seq' ();; -- : string Seq.node = Seq.Cons ("two", ) - -# seq' ();; -Exception: -Invalid_argument - "Sequence is stale (expected to be used at offset 4, but stream is now at 8)". -``` - -## Convenience wrapper - -`parse` turns parser errors into friendly messages: - -```ocaml -# R.(parse (string "FROM:" *> take_all)) (Eio.Flow.string_source "FROM:A") ~max_size:5;; -- : (string, [> `Msg of string ]) result = Ok "A" - -# R.(parse (string "FROM:" *> take_all)) (Eio.Flow.string_source "TO:B") ~max_size:5;; -- : (string, [> `Msg of string ]) result = -Error (`Msg "Expected \"FROM:\" but got \"TO:B\" (at offset 0)") - -# R.(parse (string "FROM:" *> take_all)) (Eio.Flow.string_source "FROM:ABCDE") ~max_size:5;; -- : (string, [> `Msg of string ]) result = -Error (`Msg "Buffer size limit exceeded when reading at offset 5") - -# R.(parse (string "END")) (Eio.Flow.string_source "ENDING") ~max_size:5;; -- : (unit, [> `Msg of string ]) result = -Error (`Msg "Unexpected data after parsing (at offset 3)") - -# R.(parse (string "END")) (Eio.Flow.string_source "E") ~max_size:5;; -- : (unit, [> `Msg of string ]) result = -Error (`Msg "Unexpected end-of-file at offset 1") -``` - -`parse_exn` is similar, but raises (we then catch it and print it nicely): - -```ocaml -# parse_exn R.(string "FROM:" *> take_all) (Eio.Flow.string_source "FROM:A") ~max_size:5;; -+Ok: "A" -- : unit = () - -# parse_exn R.(string "FROM:" *> take_all) (Eio.Flow.string_source "TO:B") ~max_size:5;; -+Failure: Expected "FROM:" but got "TO:B" (at offset 0) -- : unit = () - -# parse_exn R.(string "FROM:" *> take_all) (Eio.Flow.string_source "FROM:ABCDE") ~max_size:5;; -+Failure: Buffer size limit exceeded when reading at offset 5 -- : unit = () - -# parse_exn R.(take 3) (Eio.Flow.string_source "ENDING") ~max_size:5;; -+Failure: Unexpected data after parsing (at offset 3) -- : unit = () - -# parse_exn R.(take 3) (Eio.Flow.string_source "E") ~max_size:5;; -+Failure: Unexpected end-of-file at offset 1 -- : unit = () -``` - -## Parsing strings - -There are some convenience functions for parsing strings: - -```ocaml -# let r = R.of_string "hello\nworld\n";; -val r : R.t = -# R.line r;; -- : string = "hello" -# R.line r;; -- : string = "world" -# R.line r;; -Exception: End_of_file. -``` - -```ocaml -# R.parse_string R.line "foo\n";; -- : (string, [> `Msg of string ]) result = Ok "foo" - -# R.parse_string R.line "foo\nbar\n";; -- : (string, [> `Msg of string ]) result = -Error (`Msg "Unexpected data after parsing (at offset 4)") - -# R.parse_string_exn R.line "foo\n";; -- : string = "foo" - -# R.parse_string_exn R.line "foo\nbar\n";; -Exception: Failure "Unexpected data after parsing (at offset 4)". -``` - -## Test using mock flow - -```ocaml -# #require "eio.mock";; - -# let flow = Eio_mock.Flow.make "flow" in - Eio_mock.Flow.on_read flow [ - `Return "foo\nba"; - `Return "r\n"; - `Raise End_of_file; - ]; - R.parse_exn ~max_size:100 R.(line <*> line) flow;; -+flow: read "foo\n" -+ "ba" -+flow: read "r\n" -- : string * string = ("foo", "bar") -``` +```ocaml +# #require "eio";; +``` +```ocaml +module R = Eio.Buf_read;; +open R.Syntax;; + +let traceln fmt = Fmt.pr ("+" ^^ fmt ^^ "@.") + +let peek t = + let s = Cstruct.to_string (R.peek t) in + assert (String.length s = R.buffered_bytes t); + s + +let ensure t n = + R.ensure t n; + peek t + +(* The next data to be returned by `mock_flow`. `[]` to raise `End_of_file`: *) +let next = ref [] + +let mock_flow = + let module X = struct + type t = unit + + let read_methods = [] + + let single_read () buf = + match !next with + | [] -> + traceln "mock_flow returning Eof"; + raise End_of_file + | x :: xs -> + let len = min (Cstruct.length buf) (String.length x) in + traceln "mock_flow returning %d bytes" len; + Cstruct.blit_from_string x 0 buf 0 len; + let x' = String.sub x len (String.length x - len) in + next := (if x' = "" then xs else x' :: xs); + len + end in + let ops = Eio.Flow.Pi.source (module X) in + Eio.Resource.T ((), ops) + +let read flow n = + let buf = Cstruct.create n in + let len = Eio.Flow.single_read flow buf in + traceln "Read %S" (Cstruct.to_string buf ~len) + +let is_digit = function + | '0'..'9' -> true + | _ -> false + +let test ?(max_size=10) input p = + next := input; + let i = R.of_flow mock_flow ~max_size in + p i + +let parse_exn p flow ~max_size = + match R.parse_exn p flow ~max_size with + | x -> traceln "Ok: %S" x + | exception Failure msg -> traceln "Failure: %s" msg +``` + + +## A simple run-through + +```ocaml +# let i = R.of_flow (Eio.Flow.string_source "Hello") ~max_size:100;; +val i : R.t = +# peek i;; +- : string = "" +# ensure i 1;; +- : string = "Hello" +# R.consume i 1;; +- : unit = () +# peek i;; +- : string = "ello" +# ensure i 4;; +- : string = "ello" +# ensure i 5;; +Exception: End_of_file. +# peek i;; +- : string = "ello" +# R.consume i 4;; +- : unit = () +# peek i;; +- : string = "" +``` + +## Minimising reads on the underlying flow + +```ocaml +# let i = R.of_flow mock_flow ~initial_size:4 ~max_size:10;; +val i : R.t = +``` + +The first read fills the initial buffer: +```ocaml +# next := ["hello world!"]; ensure i 1;; ++mock_flow returning 4 bytes +- : string = "hell" +``` + +The next read forces a resize (doubling to 8): +```ocaml +# ensure i 5;; ++mock_flow returning 4 bytes +- : string = "hello wo" +``` + +Now the buffer is at max-size (10): +```ocaml +# ensure i 9;; ++mock_flow returning 2 bytes +- : string = "hello worl" +# ensure i 10;; +- : string = "hello worl" +# ensure i 11;; +Exception: Eio__Buf_read.Buffer_limit_exceeded. +``` + +Sometimes, doubling isn't enough. Here we go straight to 10 bytes: + +```ocaml +# let i = R.of_flow mock_flow ~initial_size:4 ~max_size:10;; +val i : R.t = +# next := ["hello world!"]; ensure i 10;; ++mock_flow returning 10 bytes +- : string = "hello worl" +``` + +## End-of-file + +After getting end-of-file, we don't use the flow any more: + +```ocaml +# let i = R.of_flow mock_flow ~initial_size:4 ~max_size:10;; +val i : R.t = +# next := ["hi"]; ensure i 10;; ++mock_flow returning 2 bytes ++mock_flow returning Eof +Exception: End_of_file. +# peek i;; +- : string = "hi" +# ensure i 10;; +Exception: End_of_file. +# R.take_all i;; +- : string = "hi" +# R.take_all i;; +- : string = "" +``` + +## Multiple reads + +We might need several reads to fulfill the user's request: +```ocaml +# let i = R.of_flow mock_flow ~initial_size:4 ~max_size:10;; +val i : R.t = +# next := ["one"; "two"; "three"]; ensure i 10;; ++mock_flow returning 3 bytes ++mock_flow returning 3 bytes ++mock_flow returning 4 bytes +- : string = "onetwothre" +# R.consume i 4; ensure i 7;; ++mock_flow returning 1 bytes +- : string = "wothree" +``` + +## Reading lines + +```ocaml +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = +# next := ["one"; "\ntwo\n"; "three\n"]; R.line i;; ++mock_flow returning 3 bytes ++mock_flow returning 5 bytes +- : string = "one" +# R.line i;; +- : string = "two" +# R.line i;; ++mock_flow returning 6 bytes +- : string = "three" +# R.line i;; ++mock_flow returning Eof +Exception: End_of_file. +``` + +DOS lines: + +```ocaml +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = +# next := ["one\r"; "\ntwo\r\n"; "three\r\n"]; R.line i;; ++mock_flow returning 4 bytes ++mock_flow returning 6 bytes +- : string = "one" +# R.line i;; +- : string = "two" +# R.line i;; ++mock_flow returning 7 bytes +- : string = "three" +# R.line i;; ++mock_flow returning Eof +Exception: End_of_file. +``` + +Missing EOL: + +```ocaml +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = +# next := ["on"; "e\ntwo"]; R.line i;; ++mock_flow returning 2 bytes ++mock_flow returning 5 bytes +- : string = "one" +# R.line i;; ++mock_flow returning Eof +- : string = "two" +``` + +Multiple lines in one read: + +```ocaml +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = +# next := ["one\ntwo\n\nthree"]; R.line i;; ++mock_flow returning 14 bytes +- : string = "one" +# R.line i;; +- : string = "two" +# R.line i;; +- : string = "" +# R.line i;; ++mock_flow returning Eof +- : string = "three" +# R.line i;; +Exception: End_of_file. +``` + +## Flow interface + +```ocaml +# let bflow = R.of_flow mock_flow ~max_size:100 |> R.as_flow;; +val bflow : Eio__Flow.source_ty Eio.Std.r = + Eio__.Resource.T (, ) +# next := ["foo"; "bar"]; read bflow 2;; ++mock_flow returning 3 bytes ++Read "fo" +- : unit = () +# read bflow 2;; ++Read "o" +- : unit = () +# read bflow 2;; ++mock_flow returning 3 bytes ++Read "ba" +- : unit = () +# read bflow 2;; ++Read "r" +- : unit = () +# read bflow 2;; ++mock_flow returning Eof +Exception: End_of_file. +``` + +## Characters + +```ocaml +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = + +# next := ["ab"; "c"]; R.any_char i;; ++mock_flow returning 2 bytes +- : char = 'a' + +# R.peek_char i;; +- : char option = Some 'b' + +# R.any_char i;; +- : char = 'b' + +# R.any_char i;; ++mock_flow returning 1 bytes +- : char = 'c' + +# R.any_char i;; ++mock_flow returning Eof +Exception: End_of_file. + +# R.peek_char i;; +- : char option = None +``` + +## Fixed-length strings + +```ocaml +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = +# next := ["ab"; "c"]; R.take 1 i;; ++mock_flow returning 2 bytes +- : string = "a" +# R.take 3 i;; ++mock_flow returning 1 bytes ++mock_flow returning Eof +Exception: End_of_file. +# R.take 2 i;; +- : string = "bc" +``` + +## Literals + +```ocaml +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = +# next := ["ab"; "c"]; R.char 'A' i;; ++mock_flow returning 2 bytes +Exception: Failure "Expected 'A' but got 'a'". +# R.char 'a' i;; +- : unit = () +# R.string "BC" i;; +Exception: Failure "Expected \"BC\" but got \"b\"". +# R.string "bC" i;; ++mock_flow returning 1 bytes +Exception: Failure "Expected \"bC\" but got \"bc\"". +# R.string "bcd" i;; ++mock_flow returning Eof +Exception: End_of_file. +# R.string "bcd" i;; +Exception: End_of_file. +# R.string "bc" i;; +- : unit = () +# peek i;; +- : string = "" +``` + +## Scanning + +```ocaml +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = + +# next := ["aa"; "a0"; "123de"]; R.skip_while ((=) 'a') i;; ++mock_flow returning 2 bytes ++mock_flow returning 2 bytes +- : unit = () + +# R.take_while is_digit i;; ++mock_flow returning 5 bytes +- : string = "0123" + +# R.take_while (Fun.negate is_digit) i;; ++mock_flow returning Eof +- : string = "de" + +# test ["abc"; "def"; "ghi"] (R.skip 5 *> R.take_all);; ++mock_flow returning 3 bytes ++mock_flow returning 3 bytes ++mock_flow returning 3 bytes ++mock_flow returning Eof +- : string = "fghi" + +# test ~max_size:3 ["abcdefg"] (R.skip 5 *> R.take_all);; ++mock_flow returning 3 bytes ++mock_flow returning 3 bytes ++mock_flow returning 1 bytes ++mock_flow returning Eof +- : string = "fg" + +# let is_a = function + | 'a' -> true + | _ -> false;; +val is_a : char -> bool = + +# test ["aaabc"] (R.take_while1 is_a);; ++mock_flow returning 5 bytes +- : string = "aaa" + +# test ["aaabc"] (R.take_while1 (Fun.negate is_a));; ++mock_flow returning 5 bytes +Exception: Failure "take_while1". + +# test ["abc"] (R.take_while1 is_a);; ++mock_flow returning 3 bytes +- : string = "a" + +# test ["aaaaabc"] (R.skip_while1 is_a *> R.take_all);; ++mock_flow returning 7 bytes ++mock_flow returning Eof +- : string = "bc" + +# test ["bbbccc"] (R.skip_while1 is_a *> R.take_all);; ++mock_flow returning 6 bytes +Exception: Failure "skip_while1". + +# test ["abbbccc"] (R.skip_while1 is_a *> R.take_all);; ++mock_flow returning 7 bytes ++mock_flow returning Eof +- : string = "bbbccc" +``` + +## Big Endian +```ocaml +# R.parse_string_exn R.BE.uint16 "\128\001" |> Printf.sprintf "0x%x";; +- : string = "0x8001" +# R.parse_string_exn R.BE.uint32 "\128\064\032\001" |> Printf.sprintf "0x%lx";; +- : string = "0x80402001" +# R.parse_string_exn R.BE.uint48 "\128\064\032\016\008\001" |> Printf.sprintf "0x%Lx";; +- : string = "0x804020100801" +# R.parse_string_exn R.BE.uint64 "\128\064\032\016\008\004\002\001" |> Printf.sprintf "0x%Lx";; +- : string = "0x8040201008040201" +# R.parse_string_exn R.BE.float "\128\064\032\001" |> Printf.sprintf "0x%e";; +- : string = "0x-5.888953e-39" +# R.parse_string_exn R.BE.double "\128\064\032\016\008\004\002\001" |> Printf.sprintf "0x%e";; +- : string = "0x-1.793993e-307" +``` + +## Little Endian +```ocaml +# R.parse_string_exn R.LE.uint16 "\128\001" |> Printf.sprintf "0x%x";; +- : string = "0x180" +# R.parse_string_exn R.LE.uint32 "\128\064\032\001" |> Printf.sprintf "0x%lx";; +- : string = "0x1204080" +# R.parse_string_exn R.LE.uint48 "\128\064\032\016\008\001" |> Printf.sprintf "0x%Lx";; +- : string = "0x10810204080" +# R.parse_string_exn R.LE.uint64 "\128\064\032\016\008\004\002\001" |> Printf.sprintf "0x%Lx";; +- : string = "0x102040810204080" +# R.parse_string_exn R.LE.float "\128\064\032\001" |> Printf.sprintf "0x%e";; +- : string = "0x2.943364e-38" +# R.parse_string_exn R.LE.double "\128\064\032\016\008\004\002\001" |> Printf.sprintf "0x%e";; +- : string = "0x8.209689e-304" +``` + +## Take all + +```ocaml +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = +# next := ["20 text/gemini\r\n"; "# Introduction\n"; "# Conclusion\n"]; R.line i;; ++mock_flow returning 16 bytes +- : string = "20 text/gemini" +# R.take_all i;; ++mock_flow returning 15 bytes ++mock_flow returning 13 bytes ++mock_flow returning Eof +- : string = "# Introduction\n# Conclusion\n" +``` + +```ocaml +# let i = R.of_flow mock_flow ~max_size:10;; +val i : R.t = +# next := ["abc"; "def"; "ghi"; "jkl"]; R.take_all i;; ++mock_flow returning 3 bytes ++mock_flow returning 3 bytes ++mock_flow returning 3 bytes ++mock_flow returning 1 bytes +Exception: Eio__Buf_read.Buffer_limit_exceeded. +# R.take 3 i;; +- : string = "abc" +``` + +## Combinators + +Parsers can be combined in the usual ways: + +```ocaml +# test ["abc"] (R.map String.uppercase_ascii (R.take 2));; ++mock_flow returning 3 bytes +- : string = "AB" + +# test ["abc"] (R.pair R.any_char R.take_all);; ++mock_flow returning 3 bytes ++mock_flow returning Eof +- : char * string = ('a', "bc") + +# test ["abc"] (R.bind R.any_char R.char);; ++mock_flow returning 3 bytes +Exception: Failure "Expected 'a' but got 'b'". +``` + +Syntax: + +```ocaml +# test ["abc"] (let+ x = R.take 2 in String.uppercase_ascii x);; ++mock_flow returning 3 bytes +- : string = "AB" + +# test ["abc"] (let+ x = R.any_char and+ y = R.take_all in (x, y));; ++mock_flow returning 3 bytes ++mock_flow returning Eof +- : char * string = ('a', "bc") + +# test ["abc"] (let* x = R.any_char in R.char x);; ++mock_flow returning 3 bytes +Exception: Failure "Expected 'a' but got 'b'". + +# test ["aac"] (let* x = R.any_char in R.char x *> R.take_all);; ++mock_flow returning 3 bytes ++mock_flow returning Eof +- : string = "c" + +# test ["ab"] (R.any_char <* R.any_char);; ++mock_flow returning 2 bytes +- : char = 'a' + +# test ["ab"] (R.any_char *> R.any_char);; ++mock_flow returning 2 bytes +- : char = 'b' +``` + +## Error handling + +```ocaml +# test ["abc"] R.(format_errors (take 3));; ++mock_flow returning 3 bytes +- : (string, [> `Msg of string ]) result = Ok "abc" + +# test ["abc"] R.(format_errors (take 2 <* end_of_input));; ++mock_flow returning 3 bytes +- : (string, [> `Msg of string ]) result = +Error (`Msg "Unexpected data after parsing (at offset 2)") + +# test ["abc"] R.(format_errors (take 4 <* end_of_input));; ++mock_flow returning 3 bytes ++mock_flow returning Eof +- : (string, [> `Msg of string ]) result = +Error (`Msg "Unexpected end-of-file at offset 3") + +# test ~max_size:2 ["abc"] R.(format_errors line);; ++mock_flow returning 2 bytes +- : (string, [> `Msg of string ]) result = +Error (`Msg "Buffer size limit exceeded when reading at offset 0") +``` + +## Sequences + +```ocaml +# test ["one"; "\ntwo\n"; "three"] R.lines |> Seq.iter (traceln "%S");; ++mock_flow returning 3 bytes ++mock_flow returning 5 bytes ++"one" ++"two" ++mock_flow returning 5 bytes ++mock_flow returning Eof ++"three" +- : unit = () + +# test ["abcd1234"] R.(seq (take 2)) |> List.of_seq |> String.concat ",";; ++mock_flow returning 8 bytes ++mock_flow returning Eof +- : string = "ab,cd,12,34" + +# test ["abcd123"] R.(seq (take 2)) |> List.of_seq |> String.concat ",";; ++mock_flow returning 7 bytes ++mock_flow returning Eof +Exception: End_of_file. +``` + +A sequence node remembers its offset and fails if used out of sequence: + +```ocaml +# next := ["one"; "\ntwo\n"; "three"];; +- : unit = () +# let i = R.of_flow mock_flow ~max_size:100;; +val i : R.t = +# let seq = R.lines i;; +val seq : string Seq.t = +# let line, seq' = match seq () with Cons (a, b) -> (a, b) | _ -> assert false;; ++mock_flow returning 3 bytes ++mock_flow returning 5 bytes +val line : string = "one" +val seq' : string Seq.t = + +# seq ();; +Exception: +Invalid_argument + "Sequence is stale (expected to be used at offset 0, but stream is now at 4)". + +# seq' ();; +- : string Seq.node = Seq.Cons ("two", ) + +# seq' ();; +Exception: +Invalid_argument + "Sequence is stale (expected to be used at offset 4, but stream is now at 8)". +``` + +## Convenience wrapper + +`parse` turns parser errors into friendly messages: + +```ocaml +# R.(parse (string "FROM:" *> take_all)) (Eio.Flow.string_source "FROM:A") ~max_size:5;; +- : (string, [> `Msg of string ]) result = Ok "A" + +# R.(parse (string "FROM:" *> take_all)) (Eio.Flow.string_source "TO:B") ~max_size:5;; +- : (string, [> `Msg of string ]) result = +Error (`Msg "Expected \"FROM:\" but got \"TO:B\" (at offset 0)") + +# R.(parse (string "FROM:" *> take_all)) (Eio.Flow.string_source "FROM:ABCDE") ~max_size:5;; +- : (string, [> `Msg of string ]) result = +Error (`Msg "Buffer size limit exceeded when reading at offset 5") + +# R.(parse (string "END")) (Eio.Flow.string_source "ENDING") ~max_size:5;; +- : (unit, [> `Msg of string ]) result = +Error (`Msg "Unexpected data after parsing (at offset 3)") + +# R.(parse (string "END")) (Eio.Flow.string_source "E") ~max_size:5;; +- : (unit, [> `Msg of string ]) result = +Error (`Msg "Unexpected end-of-file at offset 1") +``` + +`parse_exn` is similar, but raises (we then catch it and print it nicely): + +```ocaml +# parse_exn R.(string "FROM:" *> take_all) (Eio.Flow.string_source "FROM:A") ~max_size:5;; ++Ok: "A" +- : unit = () + +# parse_exn R.(string "FROM:" *> take_all) (Eio.Flow.string_source "TO:B") ~max_size:5;; ++Failure: Expected "FROM:" but got "TO:B" (at offset 0) +- : unit = () + +# parse_exn R.(string "FROM:" *> take_all) (Eio.Flow.string_source "FROM:ABCDE") ~max_size:5;; ++Failure: Buffer size limit exceeded when reading at offset 5 +- : unit = () + +# parse_exn R.(take 3) (Eio.Flow.string_source "ENDING") ~max_size:5;; ++Failure: Unexpected data after parsing (at offset 3) +- : unit = () + +# parse_exn R.(take 3) (Eio.Flow.string_source "E") ~max_size:5;; ++Failure: Unexpected end-of-file at offset 1 +- : unit = () +``` + +## Parsing strings + +There are some convenience functions for parsing strings: + +```ocaml +# let r = R.of_string "hello\nworld\n";; +val r : R.t = +# R.line r;; +- : string = "hello" +# R.line r;; +- : string = "world" +# R.line r;; +Exception: End_of_file. +``` + +```ocaml +# R.parse_string R.line "foo\n";; +- : (string, [> `Msg of string ]) result = Ok "foo" + +# R.parse_string R.line "foo\nbar\n";; +- : (string, [> `Msg of string ]) result = +Error (`Msg "Unexpected data after parsing (at offset 4)") + +# R.parse_string_exn R.line "foo\n";; +- : string = "foo" + +# R.parse_string_exn R.line "foo\nbar\n";; +Exception: Failure "Unexpected data after parsing (at offset 4)". +``` + +## Test using mock flow + +```ocaml +# #require "eio.mock";; + +# let flow = Eio_mock.Flow.make "flow" in + Eio_mock.Flow.on_read flow [ + `Return "foo\nba"; + `Return "r\n"; + `Raise End_of_file; + ]; + R.parse_exn ~max_size:100 R.(line <*> line) flow;; ++flow: read "foo\n" ++ "ba" ++flow: read "r\n" +- : string * string = ("foo", "bar") +``` diff --git a/tests/buf_write.md b/tests/buf_write.md index a5855d7f8..ac5ce71d8 100644 --- a/tests/buf_write.md +++ b/tests/buf_write.md @@ -1,584 +1,584 @@ -```ocaml -# #require "eio";; -# #require "eio.mock";; -``` -```ocaml -open Eio.Std - -module Write = Eio.Buf_write - -let flow = Eio_mock.Flow.make "flow" -``` - -## A simple run-through - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun w -> - Write.string w "Hello"; Write.char w ' '; Write.string w "world";; -+flow: wrote "Hello world" -- : unit = () -``` - -## Auto-commit - -If we yield then we flush the data so far: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun w -> - Write.string w "Hello"; Write.char w ' '; - Fiber.yield (); - Write.string w "world";; -+flow: wrote "Hello " -+flow: wrote "world" -- : unit = () -``` - -## Read source buffer - -If supported by the flow, we can avoid copying: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun w -> - Write.string w "Hello"; - Write.char w ' '; - Write.schedule_cstruct w (Cstruct.of_string "world"); - Write.char w '!';; -+flow: wrote ["Hello "; "world"; "!"] -- : unit = () -``` - -## Pausing - -Without pausing: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun w -> - Write.string w "Hello... "; - Fiber.yield (); - Write.string w "world";; -+flow: wrote "Hello... " -+flow: wrote "world" -- : unit = () -``` - -With pausing - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun w -> - Write.string w "Hello... "; - Write.pause w; - Fiber.yield (); - Write.unpause w; - Write.string w "world";; -+flow: wrote ["Hello... "; "world"] -- : unit = () -``` - -## Empty writes - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun t -> - Write.string t ""; - Write.bytes t (Bytes.make 0 '\000'); - Write.cstruct t Cstruct.empty; - Write.schedule_cstruct t Cstruct.empty;; -- : unit = () -``` - -## Endianness - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun t -> - Write.LE.uint16 t 5; - Fiber.yield (); - Write.BE.uint16 t 5;; -+flow: wrote "\005\000" -+flow: wrote "\000\005" -- : unit = () -``` - -## Writes - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun t -> - Write.string t "test"; - Fiber.yield (); - Write.bytes t (Bytes.of_string "test"); - Fiber.yield (); - Write.cstruct t (Cstruct.of_string ~off:1 ~len:4 "!test!"); - Fiber.yield (); - Write.char t 'A';;; -+flow: wrote "test" -+flow: wrote "test" -+flow: wrote "test" -+flow: wrote "A" -- : unit = () -``` - -## Multiple writes - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let f t = - Write.string t "te"; - Write.string t "st"; - Write.string t "te"; - Write.string t "st"; - Write.char t 't'; - Write.char t 'e' - in - traceln "With room:"; - Write.with_flow flow f; - traceln "Without room:"; - Write.with_flow ~initial_size:1 flow f;; -+With room: -+flow: wrote "testtestte" -+Without room: -+flow: wrote ["te"; "st"; "te"; "st"; "te"] -- : unit = () -``` - -## Formatting - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun t -> - Write.printf t "Write.printf can force a full flush@.@[It also@,flushes to [t] automatically"; - Write.string t " at the end, but without flushing [t] itself.\n"; - (* Create a formatter for full control: *) - let f = Write.make_formatter t in - Format.pp_set_geometry f ~max_indent:4 ~margin:10; - (* - "@ " breakable space - "@[" open vertical box, indentation: 6 (overriden by our geometry settings) - "%s" print string - "@ " breakable space - "%i" print int - "@." print newline + explicit flush - "%a" print arbitrary type - "@]" close box - "@ " breakable space - *) - Fmt.pf f "Space@ @[%s@ %i@.%a@]@ " - "This is a test" 123 - Eio.Net.Sockaddr.pp (`Tcp (Eio.Net.Ipaddr.V6.loopback, 8080)); - Write.printf t "This is a %s call to printf" "second"; - Fmt.pf f "@.Flushed. %s@." "Goodbye" -+flow: wrote "Write.printf can force a full flush\n" -+flow: wrote "It also\n" -+ " flushes to [t] automatically at the end, but without flushing [t] itself.\n" -+ "Space\n" -+ "This is a test\n" -+ " 123\n" -+flow: wrote "tcp:[::1]:8080This is a second call to printf\n" -+ "\n" -+flow: wrote "Flushed. Goodbye\n" -- : unit = () -``` - -## Flushing - -```ocaml -let p1, r2 = Promise.create ();; - -Eio_mock.Flow.on_copy_bytes flow [ - `Await p1; -] -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun t -> - Fiber.both - (fun () -> - Write.flush t; - Write.string t "Hello"; - traceln "Flushing..."; - Write.flush t; - traceln "Flushed" - ) - (fun () -> - traceln "Write now completes..."; - Promise.resolve_ok r2 3 - );; -+Flushing... -+Write now completes... -+flow: wrote "Hel" -+flow: wrote "lo" -+Flushed -- : unit = () -``` - -Multiple flushes: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Flow.on_copy_bytes flow [ - `Yield_then (`Return 1); - `Yield_then (`Return 2); - `Yield_then (`Return 2); - `Yield_then (`Return 2); - ]; - Write.with_flow flow @@ fun t -> - Fiber.all [ - (fun () -> Write.string t "ab"; Write.flush t; traceln "1st flush"); - (fun () -> Write.string t "cd"; Write.flush t; traceln "2nd flush"); - (fun () -> Write.string t "ef"; Write.flush t; traceln "3rd flush"); - ]; - traceln "Done";; -+flow: wrote "a" -+flow: wrote ["b"; "c"] -+1st flush -+flow: wrote ["d"; "e"] -+2nd flush -+flow: wrote "f" -+3rd flush -+Done -- : unit = () -``` - -Check flush waits for the write to succeed: - -```ocaml -module Slow_writer = struct - type t = unit - - let copy t ~src = - let buf = Cstruct.create 10 in - try - while true do - let len = Eio.Flow.single_read src buf in - Fiber.yield (); - traceln "Write %S" (Cstruct.to_string buf ~len) - done - with End_of_file -> () - - let single_write t bufs = - copy t ~src:(Eio.Flow.cstruct_source bufs); - Cstruct.lenv bufs -end -let slow_writer = - let ops = Eio.Flow.Pi.sink (module Slow_writer) in - Eio.Resource.T ((), ops) -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow slow_writer @@ fun t -> - Write.string t "test"; - Write.flush t; - traceln "Flush complete" -+Write "test" -+Flush complete -- : unit = () -``` - -## Scheduling - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun t -> - Write.schedule_cstruct t (Cstruct.of_string "one"); - Write.string t "two"; - Fiber.yield (); - Write.string t "one"; - Write.schedule_cstruct t (Cstruct.of_string "two"); - Fiber.yield (); - Write.schedule_cstruct t (Cstruct.of_string "end"); - Fiber.yield (); - traceln "Should all be flushed by now.";;; -+flow: wrote ["one"; "two"] -+flow: wrote ["one"; "two"] -+flow: wrote "end" -+Should all be flushed by now. -- : unit = () -``` - -## Cancellation - -Cancelled while waiting for the underlying flow to perform the write: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let flow = Eio_mock.Flow.make "flow" in - Eio_mock.Flow.on_copy_bytes flow [`Run Fiber.await_cancel]; - Fiber.both - (fun () -> - Write.with_flow flow @@ fun t -> - Write.string t "Hello"; traceln "Did write" - ) - (fun () -> Fiber.yield (); failwith "Simulated error");; -+Did write -Exception: Failure "Simulated error". -``` - -Cancelled while waiting for some data: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let t = Write.create ~sw 100 in - Fiber.both - (fun () -> ignore (Write.await_batch t); assert false) - (fun () -> failwith "Simulated error");; -Exception: Failure "Simulated error". -``` - -## Invalid offset - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Write.with_flow flow @@ fun t -> - try Write.string t "hi" ~off:100; assert false - with Invalid_argument _ -> ();; -- : unit = () -``` - -## Serialize - -```ocaml -let foobar ~sw = - let t = Write.create ~sw 100 in - Write.string t "foo"; - Write.cstruct t (Cstruct.of_string "bar"); - Write.close t; - t -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - Write.serialize (foobar ~sw) @@ fun bufs -> - traceln "Write %a" Fmt.(Dump.list (using Cstruct.to_string Dump.string)) bufs; - Ok (Cstruct.lenv bufs);; -+Write ["foobar"] -- : (unit, [> `Closed ]) result = Ok () -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - Write.serialize (foobar ~sw) @@ fun bufs -> - assert (bufs <> []); - traceln "Write %a" Fmt.(Dump.list (using Cstruct.to_string Dump.string)) bufs; - Error `Closed;; -+Write ["foobar"] -- : (unit, [> `Closed ]) result = Error `Closed -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - Write.serialize_to_string (foobar ~sw);; -- : string = "foobar" -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - Write.serialize_to_cstruct (foobar ~sw) |> Cstruct.to_string;; -- : string = "foobar" -``` - -## Exceptions - -We still flush the output on error: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Flow.on_copy_bytes flow [`Return 1; `Yield_then (`Return 1)]; - Write.with_flow flow @@ fun t -> - Write.string t "foo"; - failwith "Simulated error";; -+flow: wrote "f" -+flow: wrote "o" -+flow: wrote "o" -Exception: Failure "Simulated error". -``` - -But we don't flush if cancelled: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let flow = Eio_mock.Flow.make "flow" in - Eio_mock.Flow.on_copy_bytes flow [`Run Fiber.await_cancel]; - Fiber.both - (fun () -> - Write.with_flow flow @@ fun t -> - Write.string t "foo"; - Fiber.await_cancel () - ) - (fun () -> failwith "Simulated error");; -Exception: Failure "Simulated error". -``` - -## Cleanup - -Ensure that we don't lose flushing fibers if the writer is aborted: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun main_sw -> - Switch.run (fun sw -> - let t = Write.create ~sw 100 in - Fiber.fork ~sw:main_sw - (fun () -> - Write.string t "foo"; - try Write.flush t; assert false - with ex -> traceln "Flush failed: %a" Fmt.exn ex - ); - traceln "Finishing writer switch" - ); - Fiber.yield (); - traceln "Finishing main switch";; -+Finishing writer switch -+Flush failed: Eio__Buf_write.Flush_aborted -+Finishing main switch -- : unit = () -``` - -And with `with_flow`: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Flow.on_copy_bytes flow [`Raise (Failure "Simulated IO error")]; - Switch.run @@ fun sw -> - Write.with_flow flow @@ fun t -> - Fiber.fork ~sw (fun () -> - Write.string t "foo"; - try Write.flush t; assert false - with ex -> traceln "Flush failed: %a" Fmt.exn ex - ); - traceln "with_flow returning; t will be closed";; -+with_flow returning; t will be closed -+Flush failed: Eio__Buf_write.Flush_aborted -Exception: Failure "Simulated IO error". -``` - -But the flush does succeed in the normal case: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Flow.on_copy_bytes flow [`Yield_then (`Return 2); `Return 1]; - Switch.run @@ fun sw -> - Write.with_flow flow @@ fun t -> - Fiber.fork ~sw (fun () -> - Write.string t "foo"; - Write.flush t; - traceln "Flush succeeded" - ); - traceln "with_flow returning; t should be closed but not aborted";; -+with_flow returning; t should be closed but not aborted -+flow: wrote "fo" -+flow: wrote "o" -+Flush succeeded -- : unit = () -``` - -If we don't pass a switch then we can still cancel flushes manually: - -```ocaml -# let t = Write.create 100 in - Eio_mock.Backend.run @@ fun () -> - Fiber.both - (fun () -> - try Write.string t "hi"; Write.flush t - with Write.Flush_aborted -> traceln "Aborted" - ) - (fun () -> Write.abort t);; -+Aborted -- : unit = () -``` - -## Round-trips with Buf_read - -```ocaml -module Read = Eio.Buf_read - -let test (x : 'a) (f : Write.t -> 'a -> unit) (g : Read.t -> 'a) = - let encoded = - let t = Write.create 10 in - f t x; - Write.serialize_to_string t - in - let decoded = Read.parse_string_exn g encoded in - if x <> decoded then Fmt.failwith "Failed to round-trip: %S" encoded; - encoded - -let to_hex data = - let b = Buffer.create (String.length data * 2) in - data |> String.iter (fun c -> - Buffer.add_string b (Printf.sprintf "%02x" (Char.code c)) - ); - Buffer.contents b -``` - -```ocaml -# test "test" (Write.string ?off:None ?len:None) Read.take_all;; -- : string = "test" - -# test '\253' Write.char Read.any_char |> String.escaped;; -- : string = "\\253" - -# test 0xa5 Write.uint8 Read.uint8 |> to_hex;; -- : string = "a5" -``` - -Big-endian: - -```ocaml -# test 0xa123 Write.BE.uint16 Read.BE.uint16 |> to_hex;; -- : string = "a123" - -# test 0xa1234567l Write.BE.uint32 Read.BE.uint32 |> to_hex;; -- : string = "a1234567" - -# test 0xa1234567890aL Write.BE.uint48 Read.BE.uint48 |> to_hex;; -- : string = "a1234567890a" - -# test 0xa1234567890abcdeL Write.BE.uint64 Read.BE.uint64 |> to_hex;; -- : string = "a1234567890abcde" - -# test 32.25 Write.BE.float Read.BE.float |> to_hex;; -- : string = "42010000" - -# test 32.25 Write.BE.double Read.BE.double |> to_hex;; -- : string = "4040200000000000" -``` - -Little-endian (using `to_hex'` to reverse the output): - -```ocaml -let to_hex' d = - let l = String.length d in - String.init l (fun i -> d.[l - i - 1]) - |> to_hex -``` - -```ocaml -# test 0xa123 Write.LE.uint16 Read.LE.uint16 |> to_hex';; -- : string = "a123" - -# test 0xa1234567l Write.LE.uint32 Read.LE.uint32 |> to_hex';; -- : string = "a1234567" - -# test 0xa1234567890aL Write.LE.uint48 Read.LE.uint48 |> to_hex';; -- : string = "a1234567890a" - -# test 0xa1234567890abcdeL Write.LE.uint64 Read.LE.uint64 |> to_hex';; -- : string = "a1234567890abcde" - -# test 32.25 Write.LE.float Read.LE.float |> to_hex';; -- : string = "42010000" - -# test 32.25 Write.LE.double Read.LE.double |> to_hex';; -- : string = "4040200000000000" -``` +```ocaml +# #require "eio";; +# #require "eio.mock";; +``` +```ocaml +open Eio.Std + +module Write = Eio.Buf_write + +let flow = Eio_mock.Flow.make "flow" +``` + +## A simple run-through + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun w -> + Write.string w "Hello"; Write.char w ' '; Write.string w "world";; ++flow: wrote "Hello world" +- : unit = () +``` + +## Auto-commit + +If we yield then we flush the data so far: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun w -> + Write.string w "Hello"; Write.char w ' '; + Fiber.yield (); + Write.string w "world";; ++flow: wrote "Hello " ++flow: wrote "world" +- : unit = () +``` + +## Read source buffer + +If supported by the flow, we can avoid copying: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun w -> + Write.string w "Hello"; + Write.char w ' '; + Write.schedule_cstruct w (Cstruct.of_string "world"); + Write.char w '!';; ++flow: wrote ["Hello "; "world"; "!"] +- : unit = () +``` + +## Pausing + +Without pausing: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun w -> + Write.string w "Hello... "; + Fiber.yield (); + Write.string w "world";; ++flow: wrote "Hello... " ++flow: wrote "world" +- : unit = () +``` + +With pausing + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun w -> + Write.string w "Hello... "; + Write.pause w; + Fiber.yield (); + Write.unpause w; + Write.string w "world";; ++flow: wrote ["Hello... "; "world"] +- : unit = () +``` + +## Empty writes + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun t -> + Write.string t ""; + Write.bytes t (Bytes.make 0 '\000'); + Write.cstruct t Cstruct.empty; + Write.schedule_cstruct t Cstruct.empty;; +- : unit = () +``` + +## Endianness + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun t -> + Write.LE.uint16 t 5; + Fiber.yield (); + Write.BE.uint16 t 5;; ++flow: wrote "\005\000" ++flow: wrote "\000\005" +- : unit = () +``` + +## Writes + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun t -> + Write.string t "test"; + Fiber.yield (); + Write.bytes t (Bytes.of_string "test"); + Fiber.yield (); + Write.cstruct t (Cstruct.of_string ~off:1 ~len:4 "!test!"); + Fiber.yield (); + Write.char t 'A';;; ++flow: wrote "test" ++flow: wrote "test" ++flow: wrote "test" ++flow: wrote "A" +- : unit = () +``` + +## Multiple writes + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let f t = + Write.string t "te"; + Write.string t "st"; + Write.string t "te"; + Write.string t "st"; + Write.char t 't'; + Write.char t 'e' + in + traceln "With room:"; + Write.with_flow flow f; + traceln "Without room:"; + Write.with_flow ~initial_size:1 flow f;; ++With room: ++flow: wrote "testtestte" ++Without room: ++flow: wrote ["te"; "st"; "te"; "st"; "te"] +- : unit = () +``` + +## Formatting + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun t -> + Write.printf t "Write.printf can force a full flush@.@[It also@,flushes to [t] automatically"; + Write.string t " at the end, but without flushing [t] itself.\n"; + (* Create a formatter for full control: *) + let f = Write.make_formatter t in + Format.pp_set_geometry f ~max_indent:4 ~margin:10; + (* + "@ " breakable space + "@[" open vertical box, indentation: 6 (overriden by our geometry settings) + "%s" print string + "@ " breakable space + "%i" print int + "@." print newline + explicit flush + "%a" print arbitrary type + "@]" close box + "@ " breakable space + *) + Fmt.pf f "Space@ @[%s@ %i@.%a@]@ " + "This is a test" 123 + Eio.Net.Sockaddr.pp (`Tcp (Eio.Net.Ipaddr.V6.loopback, 8080)); + Write.printf t "This is a %s call to printf" "second"; + Fmt.pf f "@.Flushed. %s@." "Goodbye" ++flow: wrote "Write.printf can force a full flush\n" ++flow: wrote "It also\n" ++ " flushes to [t] automatically at the end, but without flushing [t] itself.\n" ++ "Space\n" ++ "This is a test\n" ++ " 123\n" ++flow: wrote "tcp:[::1]:8080This is a second call to printf\n" ++ "\n" ++flow: wrote "Flushed. Goodbye\n" +- : unit = () +``` + +## Flushing + +```ocaml +let p1, r2 = Promise.create ();; + +Eio_mock.Flow.on_copy_bytes flow [ + `Await p1; +] +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun t -> + Fiber.both + (fun () -> + Write.flush t; + Write.string t "Hello"; + traceln "Flushing..."; + Write.flush t; + traceln "Flushed" + ) + (fun () -> + traceln "Write now completes..."; + Promise.resolve_ok r2 3 + );; ++Flushing... ++Write now completes... ++flow: wrote "Hel" ++flow: wrote "lo" ++Flushed +- : unit = () +``` + +Multiple flushes: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Flow.on_copy_bytes flow [ + `Yield_then (`Return 1); + `Yield_then (`Return 2); + `Yield_then (`Return 2); + `Yield_then (`Return 2); + ]; + Write.with_flow flow @@ fun t -> + Fiber.all [ + (fun () -> Write.string t "ab"; Write.flush t; traceln "1st flush"); + (fun () -> Write.string t "cd"; Write.flush t; traceln "2nd flush"); + (fun () -> Write.string t "ef"; Write.flush t; traceln "3rd flush"); + ]; + traceln "Done";; ++flow: wrote "a" ++flow: wrote ["b"; "c"] ++1st flush ++flow: wrote ["d"; "e"] ++2nd flush ++flow: wrote "f" ++3rd flush ++Done +- : unit = () +``` + +Check flush waits for the write to succeed: + +```ocaml +module Slow_writer = struct + type t = unit + + let copy t ~src = + let buf = Cstruct.create 10 in + try + while true do + let len = Eio.Flow.single_read src buf in + Fiber.yield (); + traceln "Write %S" (Cstruct.to_string buf ~len) + done + with End_of_file -> () + + let single_write t bufs = + copy t ~src:(Eio.Flow.cstruct_source bufs); + Cstruct.lenv bufs +end +let slow_writer = + let ops = Eio.Flow.Pi.sink (module Slow_writer) in + Eio.Resource.T ((), ops) +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow slow_writer @@ fun t -> + Write.string t "test"; + Write.flush t; + traceln "Flush complete" ++Write "test" ++Flush complete +- : unit = () +``` + +## Scheduling + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun t -> + Write.schedule_cstruct t (Cstruct.of_string "one"); + Write.string t "two"; + Fiber.yield (); + Write.string t "one"; + Write.schedule_cstruct t (Cstruct.of_string "two"); + Fiber.yield (); + Write.schedule_cstruct t (Cstruct.of_string "end"); + Fiber.yield (); + traceln "Should all be flushed by now.";;; ++flow: wrote ["one"; "two"] ++flow: wrote ["one"; "two"] ++flow: wrote "end" ++Should all be flushed by now. +- : unit = () +``` + +## Cancellation + +Cancelled while waiting for the underlying flow to perform the write: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let flow = Eio_mock.Flow.make "flow" in + Eio_mock.Flow.on_copy_bytes flow [`Run Fiber.await_cancel]; + Fiber.both + (fun () -> + Write.with_flow flow @@ fun t -> + Write.string t "Hello"; traceln "Did write" + ) + (fun () -> Fiber.yield (); failwith "Simulated error");; ++Did write +Exception: Failure "Simulated error". +``` + +Cancelled while waiting for some data: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let t = Write.create ~sw 100 in + Fiber.both + (fun () -> ignore (Write.await_batch t); assert false) + (fun () -> failwith "Simulated error");; +Exception: Failure "Simulated error". +``` + +## Invalid offset + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Write.with_flow flow @@ fun t -> + try Write.string t "hi" ~off:100; assert false + with Invalid_argument _ -> ();; +- : unit = () +``` + +## Serialize + +```ocaml +let foobar ~sw = + let t = Write.create ~sw 100 in + Write.string t "foo"; + Write.cstruct t (Cstruct.of_string "bar"); + Write.close t; + t +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + Write.serialize (foobar ~sw) @@ fun bufs -> + traceln "Write %a" Fmt.(Dump.list (using Cstruct.to_string Dump.string)) bufs; + Ok (Cstruct.lenv bufs);; ++Write ["foobar"] +- : (unit, [> `Closed ]) result = Ok () +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + Write.serialize (foobar ~sw) @@ fun bufs -> + assert (bufs <> []); + traceln "Write %a" Fmt.(Dump.list (using Cstruct.to_string Dump.string)) bufs; + Error `Closed;; ++Write ["foobar"] +- : (unit, [> `Closed ]) result = Error `Closed +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + Write.serialize_to_string (foobar ~sw);; +- : string = "foobar" +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + Write.serialize_to_cstruct (foobar ~sw) |> Cstruct.to_string;; +- : string = "foobar" +``` + +## Exceptions + +We still flush the output on error: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Flow.on_copy_bytes flow [`Return 1; `Yield_then (`Return 1)]; + Write.with_flow flow @@ fun t -> + Write.string t "foo"; + failwith "Simulated error";; ++flow: wrote "f" ++flow: wrote "o" ++flow: wrote "o" +Exception: Failure "Simulated error". +``` + +But we don't flush if cancelled: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let flow = Eio_mock.Flow.make "flow" in + Eio_mock.Flow.on_copy_bytes flow [`Run Fiber.await_cancel]; + Fiber.both + (fun () -> + Write.with_flow flow @@ fun t -> + Write.string t "foo"; + Fiber.await_cancel () + ) + (fun () -> failwith "Simulated error");; +Exception: Failure "Simulated error". +``` + +## Cleanup + +Ensure that we don't lose flushing fibers if the writer is aborted: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun main_sw -> + Switch.run (fun sw -> + let t = Write.create ~sw 100 in + Fiber.fork ~sw:main_sw + (fun () -> + Write.string t "foo"; + try Write.flush t; assert false + with ex -> traceln "Flush failed: %a" Fmt.exn ex + ); + traceln "Finishing writer switch" + ); + Fiber.yield (); + traceln "Finishing main switch";; ++Finishing writer switch ++Flush failed: Eio__Buf_write.Flush_aborted ++Finishing main switch +- : unit = () +``` + +And with `with_flow`: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Flow.on_copy_bytes flow [`Raise (Failure "Simulated IO error")]; + Switch.run @@ fun sw -> + Write.with_flow flow @@ fun t -> + Fiber.fork ~sw (fun () -> + Write.string t "foo"; + try Write.flush t; assert false + with ex -> traceln "Flush failed: %a" Fmt.exn ex + ); + traceln "with_flow returning; t will be closed";; ++with_flow returning; t will be closed ++Flush failed: Eio__Buf_write.Flush_aborted +Exception: Failure "Simulated IO error". +``` + +But the flush does succeed in the normal case: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Flow.on_copy_bytes flow [`Yield_then (`Return 2); `Return 1]; + Switch.run @@ fun sw -> + Write.with_flow flow @@ fun t -> + Fiber.fork ~sw (fun () -> + Write.string t "foo"; + Write.flush t; + traceln "Flush succeeded" + ); + traceln "with_flow returning; t should be closed but not aborted";; ++with_flow returning; t should be closed but not aborted ++flow: wrote "fo" ++flow: wrote "o" ++Flush succeeded +- : unit = () +``` + +If we don't pass a switch then we can still cancel flushes manually: + +```ocaml +# let t = Write.create 100 in + Eio_mock.Backend.run @@ fun () -> + Fiber.both + (fun () -> + try Write.string t "hi"; Write.flush t + with Write.Flush_aborted -> traceln "Aborted" + ) + (fun () -> Write.abort t);; ++Aborted +- : unit = () +``` + +## Round-trips with Buf_read + +```ocaml +module Read = Eio.Buf_read + +let test (x : 'a) (f : Write.t -> 'a -> unit) (g : Read.t -> 'a) = + let encoded = + let t = Write.create 10 in + f t x; + Write.serialize_to_string t + in + let decoded = Read.parse_string_exn g encoded in + if x <> decoded then Fmt.failwith "Failed to round-trip: %S" encoded; + encoded + +let to_hex data = + let b = Buffer.create (String.length data * 2) in + data |> String.iter (fun c -> + Buffer.add_string b (Printf.sprintf "%02x" (Char.code c)) + ); + Buffer.contents b +``` + +```ocaml +# test "test" (Write.string ?off:None ?len:None) Read.take_all;; +- : string = "test" + +# test '\253' Write.char Read.any_char |> String.escaped;; +- : string = "\\253" + +# test 0xa5 Write.uint8 Read.uint8 |> to_hex;; +- : string = "a5" +``` + +Big-endian: + +```ocaml +# test 0xa123 Write.BE.uint16 Read.BE.uint16 |> to_hex;; +- : string = "a123" + +# test 0xa1234567l Write.BE.uint32 Read.BE.uint32 |> to_hex;; +- : string = "a1234567" + +# test 0xa1234567890aL Write.BE.uint48 Read.BE.uint48 |> to_hex;; +- : string = "a1234567890a" + +# test 0xa1234567890abcdeL Write.BE.uint64 Read.BE.uint64 |> to_hex;; +- : string = "a1234567890abcde" + +# test 32.25 Write.BE.float Read.BE.float |> to_hex;; +- : string = "42010000" + +# test 32.25 Write.BE.double Read.BE.double |> to_hex;; +- : string = "4040200000000000" +``` + +Little-endian (using `to_hex'` to reverse the output): + +```ocaml +let to_hex' d = + let l = String.length d in + String.init l (fun i -> d.[l - i - 1]) + |> to_hex +``` + +```ocaml +# test 0xa123 Write.LE.uint16 Read.LE.uint16 |> to_hex';; +- : string = "a123" + +# test 0xa1234567l Write.LE.uint32 Read.LE.uint32 |> to_hex';; +- : string = "a1234567" + +# test 0xa1234567890aL Write.LE.uint48 Read.LE.uint48 |> to_hex';; +- : string = "a1234567890a" + +# test 0xa1234567890abcdeL Write.LE.uint64 Read.LE.uint64 |> to_hex';; +- : string = "a1234567890abcde" + +# test 32.25 Write.LE.float Read.LE.float |> to_hex';; +- : string = "42010000" + +# test 32.25 Write.LE.double Read.LE.double |> to_hex';; +- : string = "4040200000000000" +``` diff --git a/tests/condition.md b/tests/condition.md index 8cb5fdfe1..7569d4e91 100644 --- a/tests/condition.md +++ b/tests/condition.md @@ -1,317 +1,317 @@ -# Setting up the environment - -```ocaml -# #require "eio.mock";; -``` - -```ocaml -open Eio.Std - -module C = Eio.Condition -``` - -# Test cases - -Simple case: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let condition = C.create () in - Fiber.both - (fun () -> - traceln "1: wait for condition"; - C.await_no_mutex condition; - traceln "1: finished") - (fun () -> - traceln "2: broadcast condition"; - C.broadcast condition; - traceln "2: finished");; -+1: wait for condition -+2: broadcast condition -+2: finished -+1: finished -- : unit = () -``` - -Broadcast when no one is waiting doesn't block: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let condition = C.create () in - traceln "broadcast condition"; - C.broadcast condition; - traceln "finished";; -+broadcast condition -+finished -- : unit = () -``` - -Broadcast wakes all waiters at once: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let condition = C.create () in - Fiber.all [ - (fun () -> - traceln "1: wait for condition"; - C.await_no_mutex condition; - traceln "1: finished"); - (fun () -> - traceln "2: wait for condition"; - C.await_no_mutex condition; - traceln "2: finished"); - (fun () -> - traceln "3: broadcast condition"; - C.broadcast condition; - traceln "3: finished") - ];; -+1: wait for condition -+2: wait for condition -+3: broadcast condition -+3: finished -+1: finished -+2: finished -- : unit = () -``` - -## Typical single-domain use - -```ocaml -let x = ref 0 -let cond = Eio.Condition.create () - -let set value = - x := value; - Eio.Condition.broadcast cond - -let await p = - (* Warning: only safe within a single-domain, and if [p] doesn't switch fibers! *) - while not (p !x) do - Eio.Condition.await_no_mutex cond - done -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.both - (fun () -> - traceln "x = %d" !x; - await ((=) 42); - traceln "x = %d" !x - ) - (fun () -> - set 5; - Fiber.yield (); - set 7; - set 42; - );; -+x = 0 -+x = 42 -- : unit = () -``` - -Cancellation while waiting: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.first - (fun () -> - await ((=) 0); - assert false; - ) - (fun () -> ()); - Fiber.both - (fun () -> - traceln "x = %d" !x; - await ((=) 0); - traceln "x = %d" !x - ) - (fun () -> - set 5; - Fiber.yield (); - set 0; - );; -+x = 42 -+x = 0 -- : unit = () -``` - -## Use with mutex - -```ocaml -let x = ref 0 -let cond = Eio.Condition.create () -let mutex = Eio.Mutex.create () - -let set value = - Eio.Mutex.use_rw ~protect:false mutex (fun () -> x := value); - Eio.Condition.broadcast cond - -let await p = - Eio.Mutex.use_ro mutex (fun () -> - while not (p !x) do - Eio.Condition.await cond mutex - done - ) -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.both - (fun () -> - traceln "x = %d" !x; - await ((=) 42); - traceln "x = %d" !x - ) - (fun () -> - set 5; - Fiber.yield (); - set 7; - set 42; - );; -+x = 0 -+x = 42 -- : unit = () -``` - -Cancellation while waiting: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.first - (fun () -> - await ((=) 0); - assert false; - ) - (fun () -> ()); - Fiber.both - (fun () -> - traceln "x = %d" !x; - await ((=) 0); - traceln "x = %d" !x - ) - (fun () -> - set 5; - Fiber.yield (); - set 0; - );; -+x = 42 -+x = 0 -- : unit = () -``` - -### Cancelling while the mutex is held - -`await` must always re-acquire the lock, and that lock operation must be non-cancellable: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - Fiber.fork ~sw - (fun () -> - traceln "Forked fiber locking"; - Eio.Mutex.lock mutex; - try - Eio.Condition.await cond mutex; - assert false; - with Eio.Cancel.Cancelled _ as ex -> - traceln "Forked fiber unlocking"; - Eio.Mutex.unlock mutex; - raise ex - ); - Eio.Cancel.protect - (fun () -> - traceln "Main fiber locking"; - Eio.Mutex.lock mutex; - Switch.fail sw (Failure "Simulated error"); - Fiber.yield (); - traceln "Main fiber unlocking"; - Eio.Mutex.unlock mutex; - ) -+Forked fiber locking -+Main fiber locking -+Main fiber unlocking -+Forked fiber unlocking -Exception: Failure "Simulated error". -``` - -### Looping - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let cond = Eio.Condition.create () in - let x = ref 0 in - let set v = - traceln "setting x=%d" v; - x := v; Eio.Condition.broadcast cond - in - Fiber.both - (fun () -> - Eio.Condition.loop_no_mutex cond (fun () -> - traceln "Checking x..."; - Fiber.yield (); - let seen = !x in - traceln "Saw x = %d" seen; - if seen = 3 then (traceln "Finished"; Some ()) - else None - ) - ) - (fun () -> - set 1; Fiber.yield (); - set 2; Fiber.yield (); - set 3; Fiber.yield (); - set 4; Fiber.yield (); - );; -+Checking x... -+setting x=1 -+Saw x = 1 -+setting x=2 -+Checking x... -+setting x=3 -+Saw x = 3 -+Finished -+setting x=4 -- : unit = () -``` - -Cancelling: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let cond = Eio.Condition.create () in - Fiber.both - (fun () -> Eio.Condition.loop_no_mutex cond (fun () -> traceln "Checking"; None)) - (fun () -> failwith "Simulated error");; -+Checking -Exception: Failure "Simulated error". -``` - -Cancelling after succeeding: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let cond = Eio.Condition.create () in - Fiber.both - (fun () -> Eio.Condition.loop_no_mutex cond (fun () -> traceln "Checking"; None)) - (fun () -> - traceln "Broadcasting"; - Eio.Condition.broadcast cond; - failwith "Simulated error" - );; -+Checking -+Broadcasting -+Checking -Exception: Failure "Simulated error". -``` - -User function raises: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let cond = Eio.Condition.create () in - Eio.Condition.loop_no_mutex cond (fun () -> Fiber.yield (); failwith "Simulated failure");; -Exception: Failure "Simulated failure". -``` +# Setting up the environment + +```ocaml +# #require "eio.mock";; +``` + +```ocaml +open Eio.Std + +module C = Eio.Condition +``` + +# Test cases + +Simple case: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let condition = C.create () in + Fiber.both + (fun () -> + traceln "1: wait for condition"; + C.await_no_mutex condition; + traceln "1: finished") + (fun () -> + traceln "2: broadcast condition"; + C.broadcast condition; + traceln "2: finished");; ++1: wait for condition ++2: broadcast condition ++2: finished ++1: finished +- : unit = () +``` + +Broadcast when no one is waiting doesn't block: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let condition = C.create () in + traceln "broadcast condition"; + C.broadcast condition; + traceln "finished";; ++broadcast condition ++finished +- : unit = () +``` + +Broadcast wakes all waiters at once: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let condition = C.create () in + Fiber.all [ + (fun () -> + traceln "1: wait for condition"; + C.await_no_mutex condition; + traceln "1: finished"); + (fun () -> + traceln "2: wait for condition"; + C.await_no_mutex condition; + traceln "2: finished"); + (fun () -> + traceln "3: broadcast condition"; + C.broadcast condition; + traceln "3: finished") + ];; ++1: wait for condition ++2: wait for condition ++3: broadcast condition ++3: finished ++1: finished ++2: finished +- : unit = () +``` + +## Typical single-domain use + +```ocaml +let x = ref 0 +let cond = Eio.Condition.create () + +let set value = + x := value; + Eio.Condition.broadcast cond + +let await p = + (* Warning: only safe within a single-domain, and if [p] doesn't switch fibers! *) + while not (p !x) do + Eio.Condition.await_no_mutex cond + done +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.both + (fun () -> + traceln "x = %d" !x; + await ((=) 42); + traceln "x = %d" !x + ) + (fun () -> + set 5; + Fiber.yield (); + set 7; + set 42; + );; ++x = 0 ++x = 42 +- : unit = () +``` + +Cancellation while waiting: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.first + (fun () -> + await ((=) 0); + assert false; + ) + (fun () -> ()); + Fiber.both + (fun () -> + traceln "x = %d" !x; + await ((=) 0); + traceln "x = %d" !x + ) + (fun () -> + set 5; + Fiber.yield (); + set 0; + );; ++x = 42 ++x = 0 +- : unit = () +``` + +## Use with mutex + +```ocaml +let x = ref 0 +let cond = Eio.Condition.create () +let mutex = Eio.Mutex.create () + +let set value = + Eio.Mutex.use_rw ~protect:false mutex (fun () -> x := value); + Eio.Condition.broadcast cond + +let await p = + Eio.Mutex.use_ro mutex (fun () -> + while not (p !x) do + Eio.Condition.await cond mutex + done + ) +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.both + (fun () -> + traceln "x = %d" !x; + await ((=) 42); + traceln "x = %d" !x + ) + (fun () -> + set 5; + Fiber.yield (); + set 7; + set 42; + );; ++x = 0 ++x = 42 +- : unit = () +``` + +Cancellation while waiting: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.first + (fun () -> + await ((=) 0); + assert false; + ) + (fun () -> ()); + Fiber.both + (fun () -> + traceln "x = %d" !x; + await ((=) 0); + traceln "x = %d" !x + ) + (fun () -> + set 5; + Fiber.yield (); + set 0; + );; ++x = 42 ++x = 0 +- : unit = () +``` + +### Cancelling while the mutex is held + +`await` must always re-acquire the lock, and that lock operation must be non-cancellable: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw + (fun () -> + traceln "Forked fiber locking"; + Eio.Mutex.lock mutex; + try + Eio.Condition.await cond mutex; + assert false; + with Eio.Cancel.Cancelled _ as ex -> + traceln "Forked fiber unlocking"; + Eio.Mutex.unlock mutex; + raise ex + ); + Eio.Cancel.protect + (fun () -> + traceln "Main fiber locking"; + Eio.Mutex.lock mutex; + Switch.fail sw (Failure "Simulated error"); + Fiber.yield (); + traceln "Main fiber unlocking"; + Eio.Mutex.unlock mutex; + ) ++Forked fiber locking ++Main fiber locking ++Main fiber unlocking ++Forked fiber unlocking +Exception: Failure "Simulated error". +``` + +### Looping + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let cond = Eio.Condition.create () in + let x = ref 0 in + let set v = + traceln "setting x=%d" v; + x := v; Eio.Condition.broadcast cond + in + Fiber.both + (fun () -> + Eio.Condition.loop_no_mutex cond (fun () -> + traceln "Checking x..."; + Fiber.yield (); + let seen = !x in + traceln "Saw x = %d" seen; + if seen = 3 then (traceln "Finished"; Some ()) + else None + ) + ) + (fun () -> + set 1; Fiber.yield (); + set 2; Fiber.yield (); + set 3; Fiber.yield (); + set 4; Fiber.yield (); + );; ++Checking x... ++setting x=1 ++Saw x = 1 ++setting x=2 ++Checking x... ++setting x=3 ++Saw x = 3 ++Finished ++setting x=4 +- : unit = () +``` + +Cancelling: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let cond = Eio.Condition.create () in + Fiber.both + (fun () -> Eio.Condition.loop_no_mutex cond (fun () -> traceln "Checking"; None)) + (fun () -> failwith "Simulated error");; ++Checking +Exception: Failure "Simulated error". +``` + +Cancelling after succeeding: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let cond = Eio.Condition.create () in + Fiber.both + (fun () -> Eio.Condition.loop_no_mutex cond (fun () -> traceln "Checking"; None)) + (fun () -> + traceln "Broadcasting"; + Eio.Condition.broadcast cond; + failwith "Simulated error" + );; ++Checking ++Broadcasting ++Checking +Exception: Failure "Simulated error". +``` + +User function raises: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let cond = Eio.Condition.create () in + Eio.Condition.loop_no_mutex cond (fun () -> Fiber.yield (); failwith "Simulated failure");; +Exception: Failure "Simulated failure". +``` diff --git a/tests/debug.md b/tests/debug.md index febc06905..ff574e9a2 100644 --- a/tests/debug.md +++ b/tests/debug.md @@ -1,28 +1,28 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -# open Eio.Std;; -``` - -## Overriding tracing - -```ocaml -# Eio_main.run @@ fun env -> - let debug = Eio.Stdenv.debug env in - let my_traceln = { - Eio.Debug.traceln = fun ?__POS__:_ fmt -> Fmt.epr ("++" ^^ fmt ^^ "@.") - } in - Fiber.both - (fun () -> - Fiber.with_binding debug#traceln my_traceln @@ fun () -> - Fiber.both - (fun () -> traceln "a") - (fun () -> Fiber.yield (); traceln "b") - ) - (fun () -> traceln "c");; -++a -+c -++b -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +# open Eio.Std;; +``` + +## Overriding tracing + +```ocaml +# Eio_main.run @@ fun env -> + let debug = Eio.Stdenv.debug env in + let my_traceln = { + Eio.Debug.traceln = fun ?__POS__:_ fmt -> Fmt.epr ("++" ^^ fmt ^^ "@.") + } in + Fiber.both + (fun () -> + Fiber.with_binding debug#traceln my_traceln @@ fun () -> + Fiber.both + (fun () -> traceln "a") + (fun () -> Fiber.yield (); traceln "b") + ) + (fun () -> traceln "c");; +++a ++c +++b +- : unit = () +``` diff --git a/tests/domains.md b/tests/domains.md index 886226d6e..408b21a98 100644 --- a/tests/domains.md +++ b/tests/domains.md @@ -1,205 +1,205 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -``` - -```ocaml -open Eio.Std - -let run (fn : Eio.Domain_manager.ty r -> unit) = - Eio_main.run @@ fun env -> - fn (Eio.Stdenv.domain_mgr env) -``` - -# Test cases - -Spawning a second domain: - -```ocaml -# run @@ fun mgr -> - let response = Eio.Domain_manager.run mgr (fun () -> "Hello from new domain") in - traceln "Got %S from spawned domain" response;; -+Got "Hello from new domain" from spawned domain -- : unit = () -``` - -The domain raises an exception: - -```ocaml -# run @@ fun mgr -> - Eio.Domain_manager.run mgr (fun () -> failwith "Exception from new domain");; -Exception: Failure "Exception from new domain". -``` - -We can still run other fibers in the main domain while waiting. -Here, we use a mutex to check that the parent domain really did run while waiting for the child domain. - -```ocaml -# run @@ fun mgr -> - let mutex = Stdlib.Mutex.create () in - Mutex.lock mutex; - Fiber.both - (fun () -> - traceln "Spawning new domain..."; - let response = Eio.Domain_manager.run mgr (fun () -> - Mutex.lock mutex; - Mutex.unlock mutex; - "Hello from new domain" - ) in - traceln "Got %S from spawned domain" response - ) - (fun () -> - traceln "Other fibers can still run"; - Mutex.unlock mutex - );; -+Spawning new domain... -+Other fibers can still run -+Got "Hello from new domain" from spawned domain -- : unit = () -``` - -Cancelling another domain: - -```ocaml -# run @@ fun mgr -> - Fiber.both - (fun () -> - try - Eio.Domain_manager.run mgr (fun () -> - try Fiber.await_cancel () - with ex -> traceln "Spawned domain got %a" Fmt.exn ex; raise ex - ) - with ex -> traceln "Spawning fiber got %a" Fmt.exn ex; raise ex - ) - (fun () -> failwith "Simulated error");; -+Spawned domain got Cancelled: Failure("Simulated error") -+Spawning fiber got Cancelled: Failure("Simulated error") -Exception: Failure "Simulated error". -``` - -Spawning when already cancelled - no new domain is started: - -```ocaml -# run @@ fun mgr -> - Switch.run @@ fun sw -> - Switch.fail sw (Failure "Simulated error"); - Eio.Domain_manager.run mgr (fun () -> traceln "Domain spawned - shouldn't happen!");; -Exception: Failure "Simulated error". -``` - -Using a cancellation context across domains is not permitted: - -```ocaml -# run @@ fun mgr -> - Switch.run @@ fun sw -> - let p, r = Promise.create () in - Fiber.both - (fun () -> - Eio.Domain_manager.run mgr @@ fun () -> - Eio.Cancel.sub @@ fun cc -> - Promise.resolve r cc; - Fiber.await_cancel () - ) - (fun () -> - let cc = Promise.await p in - Eio.Cancel.cancel cc Exit - );; -Exception: -Invalid_argument "Cancellation context accessed from wrong domain!". -``` - -Likewise, switches can't be shared: - -```ocaml -# run @@ fun mgr -> - Switch.run @@ fun sw -> - let p, r = Promise.create () in - Fiber.both - (fun () -> - Eio.Domain_manager.run mgr @@ fun () -> - Switch.run @@ fun sw -> - Promise.resolve r sw; - Fiber.await_cancel () - ) - (fun () -> - let sw = Promise.await p in - Switch.fail sw Exit - );; -Exception: Invalid_argument "Switch accessed from wrong domain!". -``` - -Registering a release handler across domains: - -```ocaml -# run @@ fun mgr -> - Switch.run @@ fun sw -> - Eio.Domain_manager.run mgr (fun () -> - Switch.on_release sw (fun () -> traceln "Handler called"); - traceln "Handler registered in new domain"; - ); - traceln "Sub-domain finished; ending switch" -+Handler registered in new domain -+Sub-domain finished; ending switch -+Handler called -- : unit = () -``` - -Cancelling a release handler across domains: - -```ocaml -# run @@ fun mgr -> - Switch.run @@ fun sw -> - let p, r = Promise.create () in - Fiber.both - (fun () -> - Eio.Domain_manager.run mgr @@ fun () -> - Switch.run @@ fun sw -> - let hook = Switch.on_release_cancellable sw (fun () -> traceln "BUG") in - Promise.resolve r hook; - Fiber.await_cancel () - ) - (fun () -> - let hook = Promise.await p in - let cancelled = Switch.try_remove_hook hook in - traceln "Cancelled: %b" cancelled; - raise Exit - );; -+Cancelled: true -Exception: Stdlib.Exit. -``` - -Can't fork into another domain: - -```ocaml -# run @@ fun mgr -> - Switch.run @@ fun sw -> - let p, r = Promise.create () in - Fiber.both - (fun () -> - Eio.Domain_manager.run mgr @@ fun () -> - Switch.run @@ fun sw -> - Promise.resolve r sw; - Fiber.await_cancel () - ) - (fun () -> - let sw = Promise.await p in - Fiber.fork ~sw ignore; - );; -Exception: Invalid_argument "Switch accessed from wrong domain!". -``` - -# Fiber-local storage - -Fiber-local bindings are not propagated when spawning fibers in other -domains (as the values may not be thread-safe): - -```ocaml -# run @@ fun mgr -> - let key = Fiber.create_key () in - Fiber.with_binding key 123 @@ fun () -> - Eio.Domain_manager.run mgr @@ fun () -> - traceln "Key => %a" Fmt.(option ~none:(const string "") int) (Fiber.get key);; -+Key => -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +``` + +```ocaml +open Eio.Std + +let run (fn : Eio.Domain_manager.ty r -> unit) = + Eio_main.run @@ fun env -> + fn (Eio.Stdenv.domain_mgr env) +``` + +# Test cases + +Spawning a second domain: + +```ocaml +# run @@ fun mgr -> + let response = Eio.Domain_manager.run mgr (fun () -> "Hello from new domain") in + traceln "Got %S from spawned domain" response;; ++Got "Hello from new domain" from spawned domain +- : unit = () +``` + +The domain raises an exception: + +```ocaml +# run @@ fun mgr -> + Eio.Domain_manager.run mgr (fun () -> failwith "Exception from new domain");; +Exception: Failure "Exception from new domain". +``` + +We can still run other fibers in the main domain while waiting. +Here, we use a mutex to check that the parent domain really did run while waiting for the child domain. + +```ocaml +# run @@ fun mgr -> + let mutex = Stdlib.Mutex.create () in + Mutex.lock mutex; + Fiber.both + (fun () -> + traceln "Spawning new domain..."; + let response = Eio.Domain_manager.run mgr (fun () -> + Mutex.lock mutex; + Mutex.unlock mutex; + "Hello from new domain" + ) in + traceln "Got %S from spawned domain" response + ) + (fun () -> + traceln "Other fibers can still run"; + Mutex.unlock mutex + );; ++Spawning new domain... ++Other fibers can still run ++Got "Hello from new domain" from spawned domain +- : unit = () +``` + +Cancelling another domain: + +```ocaml +# run @@ fun mgr -> + Fiber.both + (fun () -> + try + Eio.Domain_manager.run mgr (fun () -> + try Fiber.await_cancel () + with ex -> traceln "Spawned domain got %a" Fmt.exn ex; raise ex + ) + with ex -> traceln "Spawning fiber got %a" Fmt.exn ex; raise ex + ) + (fun () -> failwith "Simulated error");; ++Spawned domain got Cancelled: Failure("Simulated error") ++Spawning fiber got Cancelled: Failure("Simulated error") +Exception: Failure "Simulated error". +``` + +Spawning when already cancelled - no new domain is started: + +```ocaml +# run @@ fun mgr -> + Switch.run @@ fun sw -> + Switch.fail sw (Failure "Simulated error"); + Eio.Domain_manager.run mgr (fun () -> traceln "Domain spawned - shouldn't happen!");; +Exception: Failure "Simulated error". +``` + +Using a cancellation context across domains is not permitted: + +```ocaml +# run @@ fun mgr -> + Switch.run @@ fun sw -> + let p, r = Promise.create () in + Fiber.both + (fun () -> + Eio.Domain_manager.run mgr @@ fun () -> + Eio.Cancel.sub @@ fun cc -> + Promise.resolve r cc; + Fiber.await_cancel () + ) + (fun () -> + let cc = Promise.await p in + Eio.Cancel.cancel cc Exit + );; +Exception: +Invalid_argument "Cancellation context accessed from wrong domain!". +``` + +Likewise, switches can't be shared: + +```ocaml +# run @@ fun mgr -> + Switch.run @@ fun sw -> + let p, r = Promise.create () in + Fiber.both + (fun () -> + Eio.Domain_manager.run mgr @@ fun () -> + Switch.run @@ fun sw -> + Promise.resolve r sw; + Fiber.await_cancel () + ) + (fun () -> + let sw = Promise.await p in + Switch.fail sw Exit + );; +Exception: Invalid_argument "Switch accessed from wrong domain!". +``` + +Registering a release handler across domains: + +```ocaml +# run @@ fun mgr -> + Switch.run @@ fun sw -> + Eio.Domain_manager.run mgr (fun () -> + Switch.on_release sw (fun () -> traceln "Handler called"); + traceln "Handler registered in new domain"; + ); + traceln "Sub-domain finished; ending switch" ++Handler registered in new domain ++Sub-domain finished; ending switch ++Handler called +- : unit = () +``` + +Cancelling a release handler across domains: + +```ocaml +# run @@ fun mgr -> + Switch.run @@ fun sw -> + let p, r = Promise.create () in + Fiber.both + (fun () -> + Eio.Domain_manager.run mgr @@ fun () -> + Switch.run @@ fun sw -> + let hook = Switch.on_release_cancellable sw (fun () -> traceln "BUG") in + Promise.resolve r hook; + Fiber.await_cancel () + ) + (fun () -> + let hook = Promise.await p in + let cancelled = Switch.try_remove_hook hook in + traceln "Cancelled: %b" cancelled; + raise Exit + );; ++Cancelled: true +Exception: Stdlib.Exit. +``` + +Can't fork into another domain: + +```ocaml +# run @@ fun mgr -> + Switch.run @@ fun sw -> + let p, r = Promise.create () in + Fiber.both + (fun () -> + Eio.Domain_manager.run mgr @@ fun () -> + Switch.run @@ fun sw -> + Promise.resolve r sw; + Fiber.await_cancel () + ) + (fun () -> + let sw = Promise.await p in + Fiber.fork ~sw ignore; + );; +Exception: Invalid_argument "Switch accessed from wrong domain!". +``` + +# Fiber-local storage + +Fiber-local bindings are not propagated when spawning fibers in other +domains (as the values may not be thread-safe): + +```ocaml +# run @@ fun mgr -> + let key = Fiber.create_key () in + Fiber.with_binding key 123 @@ fun () -> + Eio.Domain_manager.run mgr @@ fun () -> + traceln "Key => %a" Fmt.(option ~none:(const string "") int) (Fiber.get key);; ++Key => +- : unit = () +``` diff --git a/tests/dune b/tests/dune index 31aec547a..a53e412eb 100644 --- a/tests/dune +++ b/tests/dune @@ -1,6 +1,6 @@ -(mdx - (package eio_main) - (enabled_if (<> %{os_type} "Win32")) - (deps - (env_var "EIO_BACKEND") - (package eio_main))) +(mdx + (package eio_main) + (enabled_if (<> %{os_type} "Win32")) + (deps + (env_var "EIO_BACKEND") + (package eio_main))) diff --git a/tests/executor_pool.md b/tests/executor_pool.md index 1b7afbfdd..207815a4e 100644 --- a/tests/executor_pool.md +++ b/tests/executor_pool.md @@ -1,349 +1,349 @@ -# Setting up the environment - -```ocaml -# #require "eio.mock";; -``` - -Creating some useful helper functions - -```ocaml -open Eio.Std - -module Executor_pool = Eio.Executor_pool - -let () = Eio.Exn.Backend.show := false - -let run fn = - Eio_mock.Backend.run_full @@ fun env -> - Eio_mock.Domain_manager.run @@ fun mgr -> - let clock = Eio.Stdenv.clock env in - let sleep ?weight ms = - let t0 = Eio.Time.now clock in - let t1 = t0 +. ms in - let w_info = weight |> Option.map (Format.sprintf " (weight: %.03f)") |> Option.value ~default:"" in - traceln "Sleeping %.0f%s: %.0f -> %.0f" ms w_info t0 t1; - Eio.Time.sleep clock ms - in - let duration expected f = - let t0 = Eio.Time.now clock in - let res = f () in - let t1 = Eio.Time.now clock in - let actual = t1 -. t0 in - if Float.(actual = expected) - then (traceln "Duration (valid): %.0f" expected; res) - else Fmt.failwith "Duration was not %.0f: %.0f" expected actual - in - fn mgr sleep duration -``` - -# Concurrency - -Runs jobs in parallel as much as possible (domains): - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let total = ref 0 in - let pool = Executor_pool.create ~sw ~domain_count:2 mgr in - duration 150. (fun () -> - List.init 5 (fun i -> i + 1) - |> Fiber.List.iter (fun i -> Executor_pool.submit_exn pool ~weight:1. (fun () -> - sleep 50.; - total := !total + i - )); - !total - );; -+[1] Sleeping 50: 0 -> 50 -+[2] Sleeping 50: 0 -> 50 -+mock time is now 50 -+[1] Sleeping 50: 50 -> 100 -+[2] Sleeping 50: 50 -> 100 -+mock time is now 100 -+[1] Sleeping 50: 100 -> 150 -+mock time is now 150 -+[0] Duration (valid): 150 -- : int = 15 -``` - -Runs jobs in parallel as much as possible (workers): - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let total = ref 0 in - let pool = Executor_pool.create ~sw ~domain_count:1 mgr in - duration 150. (fun () -> - List.init 5 (fun i -> i + 1) - |> Fiber.List.iter (fun i -> Executor_pool.submit_exn pool ~weight:0.5 (fun () -> - sleep 50.; - total := !total + i - )); - !total - );; -+[1] Sleeping 50: 0 -> 50 -+[1] Sleeping 50: 0 -> 50 -+mock time is now 50 -+[1] Sleeping 50: 50 -> 100 -+[1] Sleeping 50: 50 -> 100 -+mock time is now 100 -+[1] Sleeping 50: 100 -> 150 -+mock time is now 150 -+[0] Duration (valid): 150 -- : int = 15 -``` - -Runs jobs in parallel as much as possible (both): - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let total = ref 0 in - let pool = Executor_pool.create ~sw ~domain_count:2 mgr in - duration 100. (fun () -> - List.init 5 (fun i -> i + 1) - |> Fiber.List.iter (fun i -> Executor_pool.submit_exn pool ~weight:0.5 (fun () -> - sleep 50.; - total := !total + i - )); - !total - );; -+[1] Sleeping 50: 0 -> 50 -+[2] Sleeping 50: 0 -> 50 -+[1] Sleeping 50: 0 -> 50 -+[2] Sleeping 50: 0 -> 50 -+mock time is now 50 -+[1] Sleeping 50: 50 -> 100 -+mock time is now 100 -+[0] Duration (valid): 100 -- : int = 15 -``` - -Can exceed weight of 1.0: - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let pool = Executor_pool.create ~sw ~domain_count:2 mgr in - [ - List.init 10 (fun _ -> 0.25); - [ 1.0 ]; - List.init 7 (fun _ -> 0.25); - ] - |> List.concat - |> Fiber.List.iter (fun weight -> - Executor_pool.submit_exn pool ~weight (fun () -> sleep ~weight 100.) - ) - ;; -+[1] Sleeping 100 (weight: 0.250): 0 -> 100 -+[2] Sleeping 100 (weight: 0.250): 0 -> 100 -+[1] Sleeping 100 (weight: 0.250): 0 -> 100 -+[2] Sleeping 100 (weight: 0.250): 0 -> 100 -+[1] Sleeping 100 (weight: 0.250): 0 -> 100 -+[2] Sleeping 100 (weight: 0.250): 0 -> 100 -+[1] Sleeping 100 (weight: 0.250): 0 -> 100 -+[2] Sleeping 100 (weight: 0.250): 0 -> 100 -+mock time is now 100 -+[1] Sleeping 100 (weight: 0.250): 100 -> 200 -+[2] Sleeping 100 (weight: 0.250): 100 -> 200 -+[1] Sleeping 100 (weight: 1.000): 100 -> 200 -+[2] Sleeping 100 (weight: 0.250): 100 -> 200 -+[2] Sleeping 100 (weight: 0.250): 100 -> 200 -+[2] Sleeping 100 (weight: 0.250): 100 -> 200 -+mock time is now 200 -+[1] Sleeping 100 (weight: 0.250): 200 -> 300 -+[2] Sleeping 100 (weight: 0.250): 200 -> 300 -+[1] Sleeping 100 (weight: 0.250): 200 -> 300 -+[2] Sleeping 100 (weight: 0.250): 200 -> 300 -+mock time is now 300 -- : unit = () -``` - -# Weights - -Must be between 0 and 1: - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let pool = Executor_pool.create ~sw ~domain_count:2 mgr in - Executor_pool.submit_exn pool ~weight:(-5.) (fun () -> ()) - ;; -Exception: Invalid_argument "Executor_pool: weight -5 not >= 0.0 && <= 1.0". -``` -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let pool = Executor_pool.create ~sw ~domain_count:2 mgr in - Executor_pool.submit_exn pool ~weight:1.1 (fun () -> ()) - ;; -Exception: Invalid_argument "Executor_pool: weight 1.1 not >= 0.0 && <= 1.0". -``` - - -# Job error handling - -`Executor_pool.submit` returns a Result: - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let total = ref 0 in - let pool = Executor_pool.create ~sw ~domain_count:1 mgr in - duration 100. (fun () -> - let results = - List.init 5 (fun i -> i + 1) - |> Fiber.List.map (fun i -> Executor_pool.submit pool ~weight:0.25 (fun () -> - sleep 50.; - if i mod 2 = 0 - then failwith (Int.to_string i) - else (let x = !total in total := !total + i; x) - )) - in - results, !total - );; -+[1] Sleeping 50: 0 -> 50 -+[1] Sleeping 50: 0 -> 50 -+[1] Sleeping 50: 0 -> 50 -+[1] Sleeping 50: 0 -> 50 -+mock time is now 50 -+[1] Sleeping 50: 50 -> 100 -+mock time is now 100 -+[0] Duration (valid): 100 -- : (int, exn) result list * int = -([Ok 0; Error (Failure "2"); Ok 1; Error (Failure "4"); Ok 4], 9) -``` - -`Executor_pool.submit_exn` raises: - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let total = ref 0 in - let pool = Executor_pool.create ~sw ~domain_count:1 mgr in - List.init 5 (fun i -> i + 1) - |> Fiber.List.map (fun i -> Executor_pool.submit_exn pool ~weight:1. (fun () -> - traceln "Started %d" i; - let x = !total in - total := !total + i; - if x = 3 - then failwith (Int.to_string i) - else x - ));; -+[1] Started 1 -+[1] Started 2 -+[1] Started 3 -Exception: Failure "3". -``` - -# Blocking for capacity - -`Executor_pool.submit_exn` will block waiting for room in the queue: - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let pool = Executor_pool.create ~sw ~domain_count:1 mgr in - - let p1 = Fiber.fork_promise ~sw (fun () -> Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.)) in - - duration 50. (fun () -> Executor_pool.submit_exn pool ~weight:1. @@ fun () -> ()); - - duration 0. (fun () -> Promise.await_exn p1) - ;; -+[1] Sleeping 50: 0 -> 50 -+mock time is now 50 -+[0] Duration (valid): 50 -+[0] Duration (valid): 0 -- : unit = () -``` - -`Executor_pool.submit_fork` will not block if there's not enough room in the queue: - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let pool = Executor_pool.create ~sw ~domain_count:1 mgr in - - let p1 = duration 0. (fun () -> - Fiber.fork_promise ~sw (fun () -> Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.)) - ) - in - let p2 = duration 0. (fun () -> - Fiber.fork_promise ~sw (fun () -> Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.)) - ) - in - let p3 = duration 0. (fun () -> - Executor_pool.submit_fork ~sw pool ~weight:1. (fun () -> ()) - ) - in - - duration 100. (fun () -> - Promise.await_exn p1; - Promise.await_exn p2; - Promise.await_exn p3; - (* Value restriction :( *) - Promise.create_resolved (Ok ()) - ) - |> Promise.await_exn - ;; -+[0] Duration (valid): 0 -+[0] Duration (valid): 0 -+[0] Duration (valid): 0 -+[1] Sleeping 50: 0 -> 50 -+mock time is now 50 -+[1] Sleeping 50: 50 -> 100 -+mock time is now 100 -+[0] Duration (valid): 100 -- : unit = () -``` - -# Checks switch status - -```ocaml -# run @@ fun mgr sleep duration -> - let leak = ref None in - let count = ref 0 in - - let () = - try ( - Switch.run @@ fun sw -> - - let pool = Executor_pool.create ~sw ~domain_count:1 mgr in - leak := Some pool; - - let p1 = duration 0. (fun () -> - Fiber.fork_promise ~sw (fun () -> Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.; incr count)) - ) - in - Switch.fail sw (Failure "Abort mission!"); - Promise.await_exn p1; - Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.; incr count) ) - with _ -> () - in - match !leak with - | None -> assert false - | Some pool -> - Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.; incr count); - traceln "Count: %d" !count -+[0] Duration (valid): 0 -Exception: Invalid_argument "Stream closed". -``` - -If the worker is cancelled, the client still gets a reply: - -```ocaml -# run @@ fun mgr sleep duration -> - Switch.run @@ fun sw -> - let p = Executor_pool.create ~sw ~domain_count:1 mgr in - Fiber.both - (fun () -> - Eio.Cancel.protect @@ fun () -> - traceln "Submitting..."; - Executor_pool.submit_exn p ~weight:1. (fun () -> traceln "Running"); - assert false - ) - (fun () -> traceln "Simulated error"; Switch.fail sw Exit) -+[0] Submitting... -+[0] Simulated error -Exception: Stdlib.Exit. -``` +# Setting up the environment + +```ocaml +# #require "eio.mock";; +``` + +Creating some useful helper functions + +```ocaml +open Eio.Std + +module Executor_pool = Eio.Executor_pool + +let () = Eio.Exn.Backend.show := false + +let run fn = + Eio_mock.Backend.run_full @@ fun env -> + Eio_mock.Domain_manager.run @@ fun mgr -> + let clock = Eio.Stdenv.clock env in + let sleep ?weight ms = + let t0 = Eio.Time.now clock in + let t1 = t0 +. ms in + let w_info = weight |> Option.map (Format.sprintf " (weight: %.03f)") |> Option.value ~default:"" in + traceln "Sleeping %.0f%s: %.0f -> %.0f" ms w_info t0 t1; + Eio.Time.sleep clock ms + in + let duration expected f = + let t0 = Eio.Time.now clock in + let res = f () in + let t1 = Eio.Time.now clock in + let actual = t1 -. t0 in + if Float.(actual = expected) + then (traceln "Duration (valid): %.0f" expected; res) + else Fmt.failwith "Duration was not %.0f: %.0f" expected actual + in + fn mgr sleep duration +``` + +# Concurrency + +Runs jobs in parallel as much as possible (domains): + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let total = ref 0 in + let pool = Executor_pool.create ~sw ~domain_count:2 mgr in + duration 150. (fun () -> + List.init 5 (fun i -> i + 1) + |> Fiber.List.iter (fun i -> Executor_pool.submit_exn pool ~weight:1. (fun () -> + sleep 50.; + total := !total + i + )); + !total + );; ++[1] Sleeping 50: 0 -> 50 ++[2] Sleeping 50: 0 -> 50 ++mock time is now 50 ++[1] Sleeping 50: 50 -> 100 ++[2] Sleeping 50: 50 -> 100 ++mock time is now 100 ++[1] Sleeping 50: 100 -> 150 ++mock time is now 150 ++[0] Duration (valid): 150 +- : int = 15 +``` + +Runs jobs in parallel as much as possible (workers): + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let total = ref 0 in + let pool = Executor_pool.create ~sw ~domain_count:1 mgr in + duration 150. (fun () -> + List.init 5 (fun i -> i + 1) + |> Fiber.List.iter (fun i -> Executor_pool.submit_exn pool ~weight:0.5 (fun () -> + sleep 50.; + total := !total + i + )); + !total + );; ++[1] Sleeping 50: 0 -> 50 ++[1] Sleeping 50: 0 -> 50 ++mock time is now 50 ++[1] Sleeping 50: 50 -> 100 ++[1] Sleeping 50: 50 -> 100 ++mock time is now 100 ++[1] Sleeping 50: 100 -> 150 ++mock time is now 150 ++[0] Duration (valid): 150 +- : int = 15 +``` + +Runs jobs in parallel as much as possible (both): + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let total = ref 0 in + let pool = Executor_pool.create ~sw ~domain_count:2 mgr in + duration 100. (fun () -> + List.init 5 (fun i -> i + 1) + |> Fiber.List.iter (fun i -> Executor_pool.submit_exn pool ~weight:0.5 (fun () -> + sleep 50.; + total := !total + i + )); + !total + );; ++[1] Sleeping 50: 0 -> 50 ++[2] Sleeping 50: 0 -> 50 ++[1] Sleeping 50: 0 -> 50 ++[2] Sleeping 50: 0 -> 50 ++mock time is now 50 ++[1] Sleeping 50: 50 -> 100 ++mock time is now 100 ++[0] Duration (valid): 100 +- : int = 15 +``` + +Can exceed weight of 1.0: + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let pool = Executor_pool.create ~sw ~domain_count:2 mgr in + [ + List.init 10 (fun _ -> 0.25); + [ 1.0 ]; + List.init 7 (fun _ -> 0.25); + ] + |> List.concat + |> Fiber.List.iter (fun weight -> + Executor_pool.submit_exn pool ~weight (fun () -> sleep ~weight 100.) + ) + ;; ++[1] Sleeping 100 (weight: 0.250): 0 -> 100 ++[2] Sleeping 100 (weight: 0.250): 0 -> 100 ++[1] Sleeping 100 (weight: 0.250): 0 -> 100 ++[2] Sleeping 100 (weight: 0.250): 0 -> 100 ++[1] Sleeping 100 (weight: 0.250): 0 -> 100 ++[2] Sleeping 100 (weight: 0.250): 0 -> 100 ++[1] Sleeping 100 (weight: 0.250): 0 -> 100 ++[2] Sleeping 100 (weight: 0.250): 0 -> 100 ++mock time is now 100 ++[1] Sleeping 100 (weight: 0.250): 100 -> 200 ++[2] Sleeping 100 (weight: 0.250): 100 -> 200 ++[1] Sleeping 100 (weight: 1.000): 100 -> 200 ++[2] Sleeping 100 (weight: 0.250): 100 -> 200 ++[2] Sleeping 100 (weight: 0.250): 100 -> 200 ++[2] Sleeping 100 (weight: 0.250): 100 -> 200 ++mock time is now 200 ++[1] Sleeping 100 (weight: 0.250): 200 -> 300 ++[2] Sleeping 100 (weight: 0.250): 200 -> 300 ++[1] Sleeping 100 (weight: 0.250): 200 -> 300 ++[2] Sleeping 100 (weight: 0.250): 200 -> 300 ++mock time is now 300 +- : unit = () +``` + +# Weights + +Must be between 0 and 1: + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let pool = Executor_pool.create ~sw ~domain_count:2 mgr in + Executor_pool.submit_exn pool ~weight:(-5.) (fun () -> ()) + ;; +Exception: Invalid_argument "Executor_pool: weight -5 not >= 0.0 && <= 1.0". +``` +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let pool = Executor_pool.create ~sw ~domain_count:2 mgr in + Executor_pool.submit_exn pool ~weight:1.1 (fun () -> ()) + ;; +Exception: Invalid_argument "Executor_pool: weight 1.1 not >= 0.0 && <= 1.0". +``` + + +# Job error handling + +`Executor_pool.submit` returns a Result: + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let total = ref 0 in + let pool = Executor_pool.create ~sw ~domain_count:1 mgr in + duration 100. (fun () -> + let results = + List.init 5 (fun i -> i + 1) + |> Fiber.List.map (fun i -> Executor_pool.submit pool ~weight:0.25 (fun () -> + sleep 50.; + if i mod 2 = 0 + then failwith (Int.to_string i) + else (let x = !total in total := !total + i; x) + )) + in + results, !total + );; ++[1] Sleeping 50: 0 -> 50 ++[1] Sleeping 50: 0 -> 50 ++[1] Sleeping 50: 0 -> 50 ++[1] Sleeping 50: 0 -> 50 ++mock time is now 50 ++[1] Sleeping 50: 50 -> 100 ++mock time is now 100 ++[0] Duration (valid): 100 +- : (int, exn) result list * int = +([Ok 0; Error (Failure "2"); Ok 1; Error (Failure "4"); Ok 4], 9) +``` + +`Executor_pool.submit_exn` raises: + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let total = ref 0 in + let pool = Executor_pool.create ~sw ~domain_count:1 mgr in + List.init 5 (fun i -> i + 1) + |> Fiber.List.map (fun i -> Executor_pool.submit_exn pool ~weight:1. (fun () -> + traceln "Started %d" i; + let x = !total in + total := !total + i; + if x = 3 + then failwith (Int.to_string i) + else x + ));; ++[1] Started 1 ++[1] Started 2 ++[1] Started 3 +Exception: Failure "3". +``` + +# Blocking for capacity + +`Executor_pool.submit_exn` will block waiting for room in the queue: + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let pool = Executor_pool.create ~sw ~domain_count:1 mgr in + + let p1 = Fiber.fork_promise ~sw (fun () -> Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.)) in + + duration 50. (fun () -> Executor_pool.submit_exn pool ~weight:1. @@ fun () -> ()); + + duration 0. (fun () -> Promise.await_exn p1) + ;; ++[1] Sleeping 50: 0 -> 50 ++mock time is now 50 ++[0] Duration (valid): 50 ++[0] Duration (valid): 0 +- : unit = () +``` + +`Executor_pool.submit_fork` will not block if there's not enough room in the queue: + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let pool = Executor_pool.create ~sw ~domain_count:1 mgr in + + let p1 = duration 0. (fun () -> + Fiber.fork_promise ~sw (fun () -> Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.)) + ) + in + let p2 = duration 0. (fun () -> + Fiber.fork_promise ~sw (fun () -> Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.)) + ) + in + let p3 = duration 0. (fun () -> + Executor_pool.submit_fork ~sw pool ~weight:1. (fun () -> ()) + ) + in + + duration 100. (fun () -> + Promise.await_exn p1; + Promise.await_exn p2; + Promise.await_exn p3; + (* Value restriction :( *) + Promise.create_resolved (Ok ()) + ) + |> Promise.await_exn + ;; ++[0] Duration (valid): 0 ++[0] Duration (valid): 0 ++[0] Duration (valid): 0 ++[1] Sleeping 50: 0 -> 50 ++mock time is now 50 ++[1] Sleeping 50: 50 -> 100 ++mock time is now 100 ++[0] Duration (valid): 100 +- : unit = () +``` + +# Checks switch status + +```ocaml +# run @@ fun mgr sleep duration -> + let leak = ref None in + let count = ref 0 in + + let () = + try ( + Switch.run @@ fun sw -> + + let pool = Executor_pool.create ~sw ~domain_count:1 mgr in + leak := Some pool; + + let p1 = duration 0. (fun () -> + Fiber.fork_promise ~sw (fun () -> Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.; incr count)) + ) + in + Switch.fail sw (Failure "Abort mission!"); + Promise.await_exn p1; + Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.; incr count) ) + with _ -> () + in + match !leak with + | None -> assert false + | Some pool -> + Executor_pool.submit_exn pool ~weight:1. (fun () -> sleep 50.; incr count); + traceln "Count: %d" !count ++[0] Duration (valid): 0 +Exception: Invalid_argument "Stream closed". +``` + +If the worker is cancelled, the client still gets a reply: + +```ocaml +# run @@ fun mgr sleep duration -> + Switch.run @@ fun sw -> + let p = Executor_pool.create ~sw ~domain_count:1 mgr in + Fiber.both + (fun () -> + Eio.Cancel.protect @@ fun () -> + traceln "Submitting..."; + Executor_pool.submit_exn p ~weight:1. (fun () -> traceln "Running"); + assert false + ) + (fun () -> traceln "Simulated error"; Switch.fail sw Exit) ++[0] Submitting... ++[0] Simulated error +Exception: Stdlib.Exit. +``` diff --git a/tests/exn.md b/tests/exn.md index 07435c069..15e3cc6bb 100644 --- a/tests/exn.md +++ b/tests/exn.md @@ -1,85 +1,85 @@ -# Setting up the environment - -```ocaml -# #require "eio.mock";; -``` - -Adjust this to test backtrace printing: -```ocaml -let () = Printexc.record_backtrace false -``` - -```ocaml -let non_io a = - try failwith a - with ex -> ex, Printexc.get_raw_backtrace () - -let not_found = - try raise @@ Eio.Fs.err (Not_found Eio_mock.Simulated_failure) - with ex -> - let bt = Printexc.get_raw_backtrace () in - let ex = Eio.Exn.add_context ex "opening file 'foo'" in - ex, bt - -let denied = - try raise @@ Eio.Fs.err (Permission_denied Eio_mock.Simulated_failure) - with ex -> - let bt = Printexc.get_raw_backtrace () in - let ex = Eio.Exn.add_context ex "saving file 'bar'" in - ex, bt - -let combine a b = - fst @@ Eio.Exn.combine a b -``` - -## Combining exceptions - -Combining regular exceptions: - -```ocaml -# raise @@ combine (non_io "a") (non_io "b");; -Exception: Multiple exceptions: -- Failure("a") -- Failure("b") -``` - -An IO error and a regular exception becomes a regular (non-IO) multiple exception: - -```ocaml -# raise @@ combine (non_io "a") not_found;; -Exception: -Multiple exceptions: -- Failure("a") -- Eio.Io Fs Not_found Simulated_failure, - opening file 'foo' -``` - -Combining IO exceptions produces another IO exception, -so that if you want to e.g. log all IO errors and continue then that still works: - -```ocaml -# Fmt.pr "%a@." Eio.Exn.pp (combine denied not_found);; -Eio.Io Multiple_io -- Fs Permission_denied Simulated_failure, saving file 'bar' -- Fs Not_found Simulated_failure, opening file 'foo' -- : unit = () -``` - -They form a tree, because the context information may be useful too: - -```ocaml -let combined = - let e = Eio.Exn.combine denied not_found in - let ex = Eio.Exn.add_context (fst e) "processing request" in - ex, snd e -``` - -```ocaml -# Fmt.pr "%a@." Eio.Exn.pp (combine combined not_found);; -Eio.Io Multiple_io -- Multiple_io - - Fs Permission_denied Simulated_failure, saving file 'bar' - - Fs Not_found Simulated_failure, opening file 'foo', processing request -- Fs Not_found Simulated_failure, opening file 'foo' -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio.mock";; +``` + +Adjust this to test backtrace printing: +```ocaml +let () = Printexc.record_backtrace false +``` + +```ocaml +let non_io a = + try failwith a + with ex -> ex, Printexc.get_raw_backtrace () + +let not_found = + try raise @@ Eio.Fs.err (Not_found Eio_mock.Simulated_failure) + with ex -> + let bt = Printexc.get_raw_backtrace () in + let ex = Eio.Exn.add_context ex "opening file 'foo'" in + ex, bt + +let denied = + try raise @@ Eio.Fs.err (Permission_denied Eio_mock.Simulated_failure) + with ex -> + let bt = Printexc.get_raw_backtrace () in + let ex = Eio.Exn.add_context ex "saving file 'bar'" in + ex, bt + +let combine a b = + fst @@ Eio.Exn.combine a b +``` + +## Combining exceptions + +Combining regular exceptions: + +```ocaml +# raise @@ combine (non_io "a") (non_io "b");; +Exception: Multiple exceptions: +- Failure("a") +- Failure("b") +``` + +An IO error and a regular exception becomes a regular (non-IO) multiple exception: + +```ocaml +# raise @@ combine (non_io "a") not_found;; +Exception: +Multiple exceptions: +- Failure("a") +- Eio.Io Fs Not_found Simulated_failure, + opening file 'foo' +``` + +Combining IO exceptions produces another IO exception, +so that if you want to e.g. log all IO errors and continue then that still works: + +```ocaml +# Fmt.pr "%a@." Eio.Exn.pp (combine denied not_found);; +Eio.Io Multiple_io +- Fs Permission_denied Simulated_failure, saving file 'bar' +- Fs Not_found Simulated_failure, opening file 'foo' +- : unit = () +``` + +They form a tree, because the context information may be useful too: + +```ocaml +let combined = + let e = Eio.Exn.combine denied not_found in + let ex = Eio.Exn.add_context (fst e) "processing request" in + ex, snd e +``` + +```ocaml +# Fmt.pr "%a@." Eio.Exn.pp (combine combined not_found);; +Eio.Io Multiple_io +- Multiple_io + - Fs Permission_denied Simulated_failure, saving file 'bar' + - Fs Not_found Simulated_failure, opening file 'foo', processing request +- Fs Not_found Simulated_failure, opening file 'foo' +- : unit = () +``` diff --git a/tests/fd_passing.md b/tests/fd_passing.md index 6d6c86bd0..883ed68c3 100644 --- a/tests/fd_passing.md +++ b/tests/fd_passing.md @@ -1,83 +1,83 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -``` - -```ocaml -open Eio.Std - -let ( / ) = Eio.Path.( / ) - -let run ?clear:(paths = []) fn = - Eio_main.run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - List.iter (fun p -> Eio.Path.rmtree ~missing_ok:true (cwd / p)) paths; - fn env -``` - -```ocaml -(* Send [to_send] to [w] and get it from [r], then read it. *) -let test ~to_send r w = - Switch.run @@ fun sw -> - Fiber.both - (fun () -> Eio_unix.Net.send_msg w [Cstruct.of_string "x"] ~fds:to_send) - (fun () -> - let buf = Cstruct.of_string "?" in - let got, fds = Eio_unix.Net.recv_msg_with_fds ~sw r ~max_fds:2 [buf] in - let msg = Cstruct.to_string buf ~len:got in - traceln "Got: %S plus %d FDs" msg (List.length fds); - fds |> List.iter (fun fd -> - Eio_unix.Fd.use_exn "read" fd @@ fun fd -> - let len = Unix.lseek fd 0 Unix.SEEK_CUR in - ignore (Unix.lseek fd 0 Unix.SEEK_SET : int); - traceln "Read: %S" (really_input_string (Unix.in_channel_of_descr fd) len); - ) - ) - -let with_tmp_file dir id fn = - let path = (dir / (Printf.sprintf "tmp-%s.txt" id)) in - Eio.Path.with_open_out path ~create:(`Exclusive 0o600) @@ fun file -> - Fun.protect - (fun () -> - Eio.Flow.copy_string id file; - fn (Option.get (Eio_unix.Resource.fd_opt file)) - ) - ~finally:(fun () -> Eio.Path.unlink path) -``` - -## Tests - -Using a socket-pair: - -```ocaml -# run ~clear:["tmp-foo.txt"; "tmp-bar.txt"] @@ fun env -> - with_tmp_file env#cwd "foo" @@ fun fd1 -> - with_tmp_file env#cwd "bar" @@ fun fd2 -> - Switch.run @@ fun sw -> - let r, w = Eio_unix.Net.socketpair_stream ~sw ~domain:PF_UNIX ~protocol:0 () in - test ~to_send:[fd1; fd2] r w;; -+Got: "x" plus 2 FDs -+Read: "foo" -+Read: "bar" -- : unit = () -``` - -Using named sockets: - -```ocaml -# run ~clear:["tmp-foo.txt"] @@ fun env -> - let net = env#net in - with_tmp_file env#cwd "foo" @@ fun fd -> - Switch.run @@ fun sw -> - let addr = `Unix "test.socket" in - let server = Eio.Net.listen ~sw net ~reuse_addr:true ~backlog:1 addr in - let r, w = Fiber.pair - (fun () -> Eio.Net.connect ~sw net addr) - (fun () -> fst (Eio.Net.accept ~sw server)) - in - test ~to_send:[fd] r w;; -+Got: "x" plus 1 FDs -+Read: "foo" -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +``` + +```ocaml +open Eio.Std + +let ( / ) = Eio.Path.( / ) + +let run ?clear:(paths = []) fn = + Eio_main.run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + List.iter (fun p -> Eio.Path.rmtree ~missing_ok:true (cwd / p)) paths; + fn env +``` + +```ocaml +(* Send [to_send] to [w] and get it from [r], then read it. *) +let test ~to_send r w = + Switch.run @@ fun sw -> + Fiber.both + (fun () -> Eio_unix.Net.send_msg w [Cstruct.of_string "x"] ~fds:to_send) + (fun () -> + let buf = Cstruct.of_string "?" in + let got, fds = Eio_unix.Net.recv_msg_with_fds ~sw r ~max_fds:2 [buf] in + let msg = Cstruct.to_string buf ~len:got in + traceln "Got: %S plus %d FDs" msg (List.length fds); + fds |> List.iter (fun fd -> + Eio_unix.Fd.use_exn "read" fd @@ fun fd -> + let len = Unix.lseek fd 0 Unix.SEEK_CUR in + ignore (Unix.lseek fd 0 Unix.SEEK_SET : int); + traceln "Read: %S" (really_input_string (Unix.in_channel_of_descr fd) len); + ) + ) + +let with_tmp_file dir id fn = + let path = (dir / (Printf.sprintf "tmp-%s.txt" id)) in + Eio.Path.with_open_out path ~create:(`Exclusive 0o600) @@ fun file -> + Fun.protect + (fun () -> + Eio.Flow.copy_string id file; + fn (Option.get (Eio_unix.Resource.fd_opt file)) + ) + ~finally:(fun () -> Eio.Path.unlink path) +``` + +## Tests + +Using a socket-pair: + +```ocaml +# run ~clear:["tmp-foo.txt"; "tmp-bar.txt"] @@ fun env -> + with_tmp_file env#cwd "foo" @@ fun fd1 -> + with_tmp_file env#cwd "bar" @@ fun fd2 -> + Switch.run @@ fun sw -> + let r, w = Eio_unix.Net.socketpair_stream ~sw ~domain:PF_UNIX ~protocol:0 () in + test ~to_send:[fd1; fd2] r w;; ++Got: "x" plus 2 FDs ++Read: "foo" ++Read: "bar" +- : unit = () +``` + +Using named sockets: + +```ocaml +# run ~clear:["tmp-foo.txt"] @@ fun env -> + let net = env#net in + with_tmp_file env#cwd "foo" @@ fun fd -> + Switch.run @@ fun sw -> + let addr = `Unix "test.socket" in + let server = Eio.Net.listen ~sw net ~reuse_addr:true ~backlog:1 addr in + let r, w = Fiber.pair + (fun () -> Eio.Net.connect ~sw net addr) + (fun () -> fst (Eio.Net.accept ~sw server)) + in + test ~to_send:[fd] r w;; ++Got: "x" plus 1 FDs ++Read: "foo" +- : unit = () +``` diff --git a/tests/fiber.md b/tests/fiber.md index fe06a9a93..fafd9fe2f 100644 --- a/tests/fiber.md +++ b/tests/fiber.md @@ -1,973 +1,973 @@ -# Setting up the environment - -```ocaml -# #require "eio.mock";; -``` - -```ocaml -open Eio.Std - -let run fn = - Eio_mock.Backend.run @@ fun _ -> - traceln "%s" (fn ()) -``` - -# Fiber.first - -First finishes, second is cancelled: - -```ocaml -# run @@ fun () -> - let p, r = Promise.create () in - Fiber.first - (fun () -> "a") - (fun () -> Promise.await p);; -+a -- : unit = () -``` - -Second finishes, first is cancelled: - -```ocaml -# run @@ fun () -> - let p, r = Promise.create () in - Fiber.first - (fun () -> Promise.await p) - (fun () -> "b");; -+b -- : unit = () -``` - -If both succeed and no ~combine, we pick the first one by default: - -```ocaml -# run @@ fun () -> - Fiber.first - (fun () -> "a") - (fun () -> "b");; -+a -- : unit = () -``` - -If both succeed we let ~combine decide: - -```ocaml -# run @@ fun () -> - Fiber.first ~combine:(fun _ x -> x) - (fun () -> "a") - (fun () -> "b");; -+b -- : unit = () -``` - -It allows for safe Stream.take races (both): - -```ocaml -# run @@ fun () -> - let stream = Eio.Stream.create 1 in - Fiber.first ~combine:(fun x y -> x ^ y) - (fun () -> - Fiber.yield (); - Eio.Stream.add stream "b"; - "a" - ) - (fun () -> Eio.Stream.take stream);; -+ab -- : unit = () -``` - -It allows for safe Stream.take races (f is first): - -```ocaml -# run @@ fun () -> - let stream = Eio.Stream.create 1 in - let out = - Fiber.first ~combine:(fun x y -> x ^ y) - (fun () -> - Eio.Stream.add stream "b"; - Fiber.yield (); - "a" - ) - (fun () -> - Fiber.yield (); - Eio.Stream.take stream) - in - out ^ Int.to_string (Eio.Stream.length stream);; -+a1 -- : unit = () -``` - -It allows for safe Stream.take races (g is first): - -```ocaml -# run @@ fun () -> - let stream = Eio.Stream.create 1 in - let out = - Fiber.first ~combine:(fun x y -> x ^ y) - (fun () -> - Eio.Stream.add stream "b"; - Fiber.yield (); - "a" - ) - (fun () -> Eio.Stream.take stream) - in - out ^ Int.to_string (Eio.Stream.length stream);; -+b0 -- : unit = () -``` - -One crashes - report it: - -```ocaml -# run @@ fun () -> - Fiber.first - (fun () -> "a") - (fun () -> failwith "b crashed");; -Exception: Failure "b crashed". -``` - -```ocaml -# run @@ fun () -> - Fiber.first - (fun () -> failwith "a crashed") - (fun () -> "b");; -Exception: Failure "a crashed". -``` - -Both crash - report both: - -```ocaml -# run @@ fun () -> - Fiber.first - (fun () -> failwith "a crashed") - (fun () -> failwith "b crashed");; -Exception: Multiple exceptions: -- Failure("a crashed") -- Failure("b crashed") -``` - -Cancelled before it can crash: - -```ocaml -# run @@ fun () -> - Fiber.first - (fun () -> "a") - (fun () -> Fiber.yield (); failwith "b crashed");; -+a -- : unit = () -``` - -One claims to be cancelled (for some reason other than the other fiber finishing): - -```ocaml -# run @@ fun () -> - Fiber.first - (fun () -> raise (Eio.Cancel.Cancelled (Failure "cancel-a"))) - (fun () -> "b");; -Exception: Cancelled: Failure("cancel-a") -``` - -```ocaml -# run @@ fun () -> - Fiber.first - (fun () -> Fiber.yield (); "a") - (fun () -> raise (Eio.Cancel.Cancelled (Failure "cancel-b")));; -Exception: Cancelled: Failure("cancel-b") -``` - -Cancelled from parent: - -```ocaml -# run @@ fun () -> - let p, r = Promise.create () in - Fiber.both - (fun () -> - failwith @@ Fiber.first - (fun () -> Promise.await p) - (fun () -> Promise.await p) - ) - (fun () -> failwith "Parent cancel"); - "not-reached";; -Exception: Failure "Parent cancel". -``` - -Cancelled from parent while already cancelling: - -```ocaml -# run @@ fun () -> - Fiber.both - (fun () -> - let _ = Fiber.first - (fun () -> "a") - (fun () -> Fiber.yield (); failwith "cancel-b") - in - traceln "Parent cancel failed" - ) - (fun () -> traceln "Cancelling parent"; failwith "Parent cancel"); - "not-reached";; -+Cancelling parent -Exception: Failure "Parent cancel". -``` - -Cancelling in a sub-switch. We see the exception as `Cancelled Exit` when we're being asked to cancel, -but just as plain `Exit` after we leave the context in which the cancellation started: - -```ocaml -# run @@ fun () -> - let p, r = Promise.create () in - Fiber.both - (fun () -> - try - Switch.run (fun _ -> - try Promise.await p - with ex -> traceln "Nested exception: %a" Fmt.exn ex; raise ex - ) - with ex -> traceln "Parent exception: %a" Fmt.exn ex; raise ex - ) - (fun () -> raise Exit); - failwith "not-reached";; -+Nested exception: Cancelled: Stdlib.Exit -+Parent exception: Cancelled: Stdlib.Exit -Exception: Stdlib.Exit. -``` - -# Fiber.pair - -```ocaml -# run @@ fun () -> - let x, y = Fiber.pair (fun () -> "a") (fun () -> "b") in - x ^ y;; -+ab -- : unit = () -``` - -# Fiber.all - -```ocaml -# run @@ fun () -> - Fiber.all []; - Fiber.all (List.init 3 (fun x () -> traceln "fiber %d" x)); - "done";; -+fiber 0 -+fiber 1 -+fiber 2 -+done -- : unit = () -``` - -# Fiber.any - -```ocaml -# run @@ fun () -> - string_of_int @@ - Fiber.any (List.init 3 (fun x () -> traceln "%d" x; Fiber.yield (); x));; -+0 -+1 -+2 -+0 -- : unit = () -``` - -`Fiber.any` with combine collects all results: - -```ocaml -# run @@ fun () -> - Fiber.any - ~combine:(fun x y -> x @ y) - (List.init 3 (fun x () -> traceln "%d" x; [x])) - |> Fmt.(str "%a" (Dump.list int));; -+0 -+1 -+2 -+[0; 1; 2] -- : unit = () -``` - -# Fiber.n_any - -`Fiber.n_any` behaves just like `Fiber.any` when there's only one result: - -```ocaml -# run @@ fun () -> - Fiber.n_any (List.init 3 (fun x () -> traceln "%d" x; Fiber.yield (); x)) - |> Fmt.(str "%a" (Dump.list int));; -+0 -+1 -+2 -+[0] -- : unit = () -``` - -`Fiber.n_any` collects all results: - -```ocaml -# run @@ fun () -> - (Fiber.n_any (List.init 4 (fun x () -> - traceln "%d" x; - if x = 1 then Fiber.yield (); - x - ))) - |> Fmt.(str "%a" (Dump.list int));; -+0 -+1 -+2 -+3 -+[0; 2; 3] -- : unit = () -``` - -# Fiber.await_cancel - -```ocaml -# run @@ fun () -> - Fiber.both - (fun () -> - try Fiber.await_cancel () - with Eio.Cancel.Cancelled _ as ex -> - traceln "Caught: %a" Fmt.exn ex; - raise ex - ) - (fun () -> failwith "simulated error"); - "not reached";; -+Caught: Cancelled: Failure("simulated error") -Exception: Failure "simulated error". -``` - -# Fiber.fork_promise - -`Fiber.fork_promise ~sw` inherits the cancellation context from `sw`, not from the current fiber: - -```ocaml -# run @@ fun () -> - let switch = ref None in - Fiber.both - (fun () -> - Switch.run @@ fun sw -> - switch := Some sw; - Fiber.await_cancel () - ) - (fun () -> - let sw = Option.get !switch in - Eio.Cancel.protect @@ fun () -> - let child = Fiber.fork_promise ~sw (fun () -> - traceln "Forked child"; - Fiber.await_cancel () - ) in - Switch.fail sw Exit; - Promise.await_exn child - ); - "not reached";; -+Forked child -Exception: Stdlib.Exit. -``` - -# Scheduling order - -Forking runs the child first, and puts the calling fiber at the head of the run-queue. - -```ocaml -# run @@ fun () -> - Switch.run @@ fun sw -> - Fiber.fork ~sw (fun () -> traceln "1st child runs"; Fiber.yield (); traceln "Queued work"); - Fiber.fork ~sw (fun () -> traceln "2nd child runs immediately"); - traceln "Caller runs before queued work"; - "ok";; -+1st child runs -+2nd child runs immediately -+Caller runs before queued work -+Queued work -+ok -- : unit = () -``` - -Same with `both`: - -```ocaml -# run @@ fun () -> - Switch.run @@ fun sw -> - Fiber.fork ~sw (fun () -> traceln "Enqueuing work for later"; Fiber.yield (); traceln "Queued work"); - Fiber.both - (fun () -> traceln "1st branch") - (fun () -> traceln "2nd branch"); - "ok";; -+Enqueuing work for later -+1st branch -+2nd branch -+Queued work -+ok -- : unit = () -``` - -Same with `first`: - -```ocaml -# run @@ fun () -> - Switch.run @@ fun sw -> - Fiber.fork ~sw (fun () -> traceln "Enqueuing work for later"; Fiber.yield (); traceln "Queued work"); - Fiber.first - (fun () -> traceln "1st branch") - (fun () -> traceln "2nd branch"); - "ok";; -+Enqueuing work for later -+1st branch -+2nd branch -+Queued work -+ok -- : unit = () -``` - -# Forking while cancelled - -```ocaml -# run @@ fun () -> - Fiber.first - (fun () -> failwith "Simulated error") - (fun () -> - Fiber.both - (fun () -> traceln "Not reached") - (fun () -> traceln "Not reached"); - assert false - );; -Exception: Failure "Simulated error". -``` - -# Concurrent list operations - -```ocaml -let process fn x = - traceln "Start %d" x; - Fiber.yield (); - let y = fn x in - traceln "Finished %d" x; - y - -let is_even x = (x land 1 = 0) - -let string_even x = - if is_even x then Some (string_of_int x) - else None - -let crash_on_three x = - if x = 3 then failwith "Simulated error" - else string_even x -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.List.filter (process is_even) [1; 2; 3; 4] - |> traceln "%a" Fmt.(Dump.list int);; -+Start 1 -+Start 2 -+Start 3 -+Start 4 -+Finished 1 -+Finished 2 -+Finished 3 -+Finished 4 -+[2; 4] -- : unit = () -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.List.map (process string_even) [1; 2; 3; 4] - |> traceln "%a" Fmt.Dump.(list (option string));; -+Start 1 -+Start 2 -+Start 3 -+Start 4 -+Finished 1 -+Finished 2 -+Finished 3 -+Finished 4 -+[None; Some "2"; None; Some "4"] -- : unit = () -``` - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.List.filter_map (process string_even) [1; 2; 3; 4] - |> traceln "%a" Fmt.Dump.(list string);; -+Start 1 -+Start 2 -+Start 3 -+Start 4 -+Finished 1 -+Finished 2 -+Finished 3 -+Finished 4 -+["2"; "4"] -- : unit = () -``` - -If any fiber raises, everything is cancelled: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.List.filter_map (process crash_on_three) [1; 2; 3; 4] - |> traceln "%a" Fmt.Dump.(list string);; -+Start 1 -+Start 2 -+Start 3 -+Start 4 -+Finished 1 -+Finished 2 -Exception: Failure "Simulated error". -``` - -The number of concurrent fibers can be limited: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let ps = Array.init 4 (fun _ -> Promise.create ()) in - let await i = Promise.await (fst ps.(i)) in - let finish i = Promise.resolve (snd (ps.(i))) in - Fiber.both - (fun () -> - Fiber.List.map ~max_fibers:2 (process await) (List.init 4 Fun.id) - |> traceln "%a" Fmt.(Dump.list string) - ) - (fun () -> - finish 1 "one"; - Fiber.yield (); - finish 2 "two"; - Fiber.yield (); Fiber.yield (); - finish 0 "zero"; - Fiber.yield (); Fiber.yield (); - finish 3 "three"; - );; -+Start 0 -+Start 1 -+Finished 1 -+Start 2 -+Finished 2 -+Start 3 -+Finished 0 -+Finished 3 -+[zero; one; two; three] -- : unit = () -``` - -Handling exceptions while waiting for a free fiber: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let ps = Array.init 2 (fun _ -> Promise.create ()) in - let await i = Promise.await_exn (fst ps.(i)) in - let finish i = Promise.resolve (snd (ps.(i))) in - Fiber.both - (fun () -> - Fiber.List.map ~max_fibers:1 (process await) (List.init 2 Fun.id) - |> traceln "%a" Fmt.(Dump.list string) - ) - (fun () -> - Fiber.yield (); - finish 0 (Error (Failure "Simulated error")) - );; -+Start 0 -Exception: Failure "Simulated error". -``` - -Simple iteration: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let ps = Array.init 4 (fun _ -> Promise.create ()) in - let await i = Promise.await (fst ps.(i)) in - let finish i = Promise.resolve (snd (ps.(i))) () in - Fiber.both - (fun () -> - Fiber.List.iter ~max_fibers:2 (process await) (List.init 4 Fun.id) - ) - (fun () -> - finish 1; - Fiber.yield (); - finish 2; - Fiber.yield (); Fiber.yield (); - finish 0; - Fiber.yield (); Fiber.yield (); - finish 3; - );; -+Start 0 -+Start 1 -+Finished 1 -+Start 2 -+Finished 2 -+Start 3 -+Finished 0 -+Finished 3 -- : unit = () -``` - -# Daemon fibers - -A daemon fiber runs until the non-daemon threads finish: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - Fiber.fork_daemon ~sw (fun () -> - for i = 1 to 10 do - traceln "Daemon running"; - Fiber.yield () - done; - failwith "Test failed" - ); - traceln "Main running 1"; - Fiber.yield (); - traceln "Main running 2";; -+Daemon running -+Main running 1 -+Daemon running -+Main running 2 -- : unit = () -``` - -A more complex example with multiple daemon and non-daemon fibers: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - Fiber.fork ~sw (fun () -> - traceln "Worker 1 starting"; - Fiber.yield (); - traceln "Worker 1 running"; - Fiber.yield (); - traceln "Worker 1 finished" - ); - Fiber.fork ~sw (fun () -> - traceln "Worker 2 starting"; - Fiber.yield (); - traceln "Worker 2 finished" - ); - Fiber.fork_daemon ~sw (fun () -> - try - for i = 1 to 10 do - traceln "Daemon 1 running"; - Fiber.yield () - done; - failwith "Test failed" - with Eio.Cancel.Cancelled _ as ex -> - traceln "Daemon cancelled; trying to spawn more fibers"; - Fiber.fork_daemon ~sw (fun () -> failwith "Shouldn't start"); - Fiber.fork ~sw (fun () -> failwith "Shouldn't start"); - raise ex - ); - Fiber.fork_daemon ~sw (fun () -> - traceln "Daemon 2 running"; - Fiber.yield (); - traceln "Daemon 2 finished"; - `Stop_daemon - ); - traceln "Main running"; - Fiber.yield (); - traceln "Main finished";; -+Worker 1 starting -+Worker 2 starting -+Daemon 1 running -+Daemon 2 running -+Main running -+Worker 1 running -+Worker 2 finished -+Daemon 1 running -+Daemon 2 finished -+Main finished -+Worker 1 finished -+Daemon cancelled; trying to spawn more fibers -- : unit = () -``` - -Failing daemon fibers still get their errors reported: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - Fiber.fork_daemon ~sw (fun () -> - Fiber.yield (); - failwith "Simulated error" - ); - Fiber.yield ();; -Exception: Failure "Simulated error". -``` - -# Fiber-local storage - -Creating a context key: - -```ocaml -# let key : int Fiber.key = Fiber.create_key ();; -val key : int Fiber.key = - -# let trace_key () = - let value = Fiber.get key in - traceln "Key => %a" Fmt.(option ~none:(const string "") int) value;; -val trace_key : unit -> unit = -``` - -Keys default to being unset - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - trace_key ();; -+Key => -- : unit = () -``` - -`with_binding` can be used to define a key. - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.with_binding key 123 @@ fun () -> trace_key ();; -+Key => 123 -- : unit = () -``` - -`with_binding` will shadow variables defined in outer scopes. - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.with_binding key 123 @@ fun () -> - trace_key (); - Fiber.with_binding key 456 (fun () -> trace_key ()); - trace_key ();; -+Key => 123 -+Key => 456 -+Key => 123 -- : unit = () -``` - -Values are propagated when forking: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.with_binding key 123 @@ fun () -> - Switch.run @@ fun sw -> - Fiber.fork ~sw trace_key;; -+Key => 123 -- : unit = () -``` - -Bindings can also be removed: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.with_binding key 123 @@ fun () -> - trace_key (); - Fiber.without_binding key (fun () -> trace_key ()); - trace_key ();; -+Key => 123 -+Key => -+Key => 123 -- : unit = () -``` - -Values are inherited from the currently running fiber, rather than the switch. - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - Fiber.with_binding key 123 @@ fun () -> - Fiber.fork ~sw trace_key;; -+Key => 123 -- : unit = () -``` - -## fork_seq - -The simple case where everything works: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let seq = - Fiber.fork_seq ~sw (fun yield -> - traceln "Generator fiber starting"; - for i = 1 to 3 do - traceln "Yielding %d" i; - yield i - done - ) - in - traceln "Requesting 1st item"; - match seq () with - | Nil -> assert false - | Cons (x, seq) -> - traceln "hd = %d" x; - traceln "Requesting remaining items"; - List.of_seq seq;; -+Requesting 1st item -+Generator fiber starting -+Yielding 1 -+hd = 1 -+Requesting remaining items -+Yielding 2 -+Yielding 3 -- : int list = [2; 3] -``` - -The generator raises: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let seq = - Fiber.fork_seq ~sw (fun yield -> - traceln "Generator fiber starting"; - raise (Failure "Simulated error") - ) - in - Eio.Cancel.protect (fun () -> (* (ensure we get the exception from the sequence) *) - traceln "Requesting an item"; - try - ignore (seq ()); - assert false - with ex -> traceln "Consumer got exception: %a" Fmt.exn ex - );; -+Requesting an item -+Generator fiber starting -+Consumer got exception: Failure("Simulated error") -- : unit = () -``` - -The sequence is used after the switch is finished: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let seq = - Switch.run (fun sw -> - Fiber.fork_seq ~sw (fun _yield -> assert false) - ) - in - traceln "Requesting an item"; - seq ();; -+Requesting an item -Exception: -Invalid_argument "Coroutine has already failed: Cancelled: Stdlib.Exit". -``` - -The sequence is used after the switch is finished, and the generator has started: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let seq = - Switch.run (fun sw -> - let seq = - Fiber.fork_seq ~sw (fun yield -> - try yield 1 - with ex -> traceln "Generator caught: %a" Fmt.exn ex; raise ex - ) - in - traceln "Requesting an item"; - match seq () with - | Nil -> assert false - | Cons (x, seq) -> - traceln "Got %d" x; - seq - ) - in - traceln "Switch finished. Requesting another item..."; - seq ();; -+Requesting an item -+Got 1 -+Generator caught: Cancelled: Stdlib.Exit -+Switch finished. Requesting another item... -Exception: -Invalid_argument "Coroutine has already failed: Cancelled: Stdlib.Exit". -``` - -Using a sequence after it has finished normally: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let seq = Fiber.fork_seq ~sw (fun yield -> yield 1; traceln "Generator done") in - let next = Seq.to_dispenser seq in - traceln "Got %a" Fmt.(Dump.option int) (next ()); - traceln "Got %a" Fmt.(Dump.option int) (next ()); - next ();; -+Got Some 1 -+Generator done -+Got None -Exception: Invalid_argument "Coroutine has already finished!". -``` - -Trying to resume twice: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let seq = Fiber.fork_seq ~sw (fun _yield -> Fiber.await_cancel ()) in - Fiber.both - (fun () -> ignore (seq ())) - (fun () -> ignore (seq ()));; -Exception: Invalid_argument "Coroutine is still running!". -``` - -Generator yields twice for a single request: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let seq = Fiber.fork_seq ~sw (fun yield -> Fiber.both yield yield) in - seq ();; -Exception: Invalid_argument "Coroutine has already yielded!". -``` - -Yielding from a different fiber (note: end-of-sequence is still sent when the original fiber exits): - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let seq = Fiber.fork_seq ~sw (fun yield -> - let p = Fiber.fork_promise ~sw (fun () -> Fiber.yield (); yield "Second fiber") in - Promise.await_exn p; - yield "Original fiber" - ) in - List.of_seq seq;; -- : string list = ["Second fiber"; "Original fiber"] -``` - -The consumer cancels: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let seq = Fiber.fork_seq ~sw (fun yield -> - traceln "Working..."; - try - Fiber.yield (); - yield 1 - with ex -> traceln "Generator caught: %a" Fmt.exn ex; raise ex - ) in - Fiber.first - (fun () -> seq ()) - (fun () -> Nil);; -+Working... -+Generator caught: Cancelled: Eio__core__Fiber.Not_first -- : int Seq.node = Seq.Nil -``` - -The generator is cancelled while queued to be resumed. -It runs, but cancels at the next opportunity: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Switch.run @@ fun sw -> - let seq = Fiber.fork_seq ~sw (fun yield -> - traceln "Working..."; - try Fiber.check () - with ex -> traceln "Generator caught: %a" Fmt.exn ex; raise ex - ) in - traceln "Enqueue resume"; - Fiber.both - (fun () -> ignore (seq () : _ Seq.node); assert false) - (fun () -> - traceln "Cancel generator"; - Switch.fail sw Exit - ) -+Enqueue resume -+Cancel generator -+Working... -+Generator caught: Cancelled: Stdlib.Exit -Exception: Stdlib.Exit. -``` +# Setting up the environment + +```ocaml +# #require "eio.mock";; +``` + +```ocaml +open Eio.Std + +let run fn = + Eio_mock.Backend.run @@ fun _ -> + traceln "%s" (fn ()) +``` + +# Fiber.first + +First finishes, second is cancelled: + +```ocaml +# run @@ fun () -> + let p, r = Promise.create () in + Fiber.first + (fun () -> "a") + (fun () -> Promise.await p);; ++a +- : unit = () +``` + +Second finishes, first is cancelled: + +```ocaml +# run @@ fun () -> + let p, r = Promise.create () in + Fiber.first + (fun () -> Promise.await p) + (fun () -> "b");; ++b +- : unit = () +``` + +If both succeed and no ~combine, we pick the first one by default: + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> "a") + (fun () -> "b");; ++a +- : unit = () +``` + +If both succeed we let ~combine decide: + +```ocaml +# run @@ fun () -> + Fiber.first ~combine:(fun _ x -> x) + (fun () -> "a") + (fun () -> "b");; ++b +- : unit = () +``` + +It allows for safe Stream.take races (both): + +```ocaml +# run @@ fun () -> + let stream = Eio.Stream.create 1 in + Fiber.first ~combine:(fun x y -> x ^ y) + (fun () -> + Fiber.yield (); + Eio.Stream.add stream "b"; + "a" + ) + (fun () -> Eio.Stream.take stream);; ++ab +- : unit = () +``` + +It allows for safe Stream.take races (f is first): + +```ocaml +# run @@ fun () -> + let stream = Eio.Stream.create 1 in + let out = + Fiber.first ~combine:(fun x y -> x ^ y) + (fun () -> + Eio.Stream.add stream "b"; + Fiber.yield (); + "a" + ) + (fun () -> + Fiber.yield (); + Eio.Stream.take stream) + in + out ^ Int.to_string (Eio.Stream.length stream);; ++a1 +- : unit = () +``` + +It allows for safe Stream.take races (g is first): + +```ocaml +# run @@ fun () -> + let stream = Eio.Stream.create 1 in + let out = + Fiber.first ~combine:(fun x y -> x ^ y) + (fun () -> + Eio.Stream.add stream "b"; + Fiber.yield (); + "a" + ) + (fun () -> Eio.Stream.take stream) + in + out ^ Int.to_string (Eio.Stream.length stream);; ++b0 +- : unit = () +``` + +One crashes - report it: + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> "a") + (fun () -> failwith "b crashed");; +Exception: Failure "b crashed". +``` + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> failwith "a crashed") + (fun () -> "b");; +Exception: Failure "a crashed". +``` + +Both crash - report both: + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> failwith "a crashed") + (fun () -> failwith "b crashed");; +Exception: Multiple exceptions: +- Failure("a crashed") +- Failure("b crashed") +``` + +Cancelled before it can crash: + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> "a") + (fun () -> Fiber.yield (); failwith "b crashed");; ++a +- : unit = () +``` + +One claims to be cancelled (for some reason other than the other fiber finishing): + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> raise (Eio.Cancel.Cancelled (Failure "cancel-a"))) + (fun () -> "b");; +Exception: Cancelled: Failure("cancel-a") +``` + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> Fiber.yield (); "a") + (fun () -> raise (Eio.Cancel.Cancelled (Failure "cancel-b")));; +Exception: Cancelled: Failure("cancel-b") +``` + +Cancelled from parent: + +```ocaml +# run @@ fun () -> + let p, r = Promise.create () in + Fiber.both + (fun () -> + failwith @@ Fiber.first + (fun () -> Promise.await p) + (fun () -> Promise.await p) + ) + (fun () -> failwith "Parent cancel"); + "not-reached";; +Exception: Failure "Parent cancel". +``` + +Cancelled from parent while already cancelling: + +```ocaml +# run @@ fun () -> + Fiber.both + (fun () -> + let _ = Fiber.first + (fun () -> "a") + (fun () -> Fiber.yield (); failwith "cancel-b") + in + traceln "Parent cancel failed" + ) + (fun () -> traceln "Cancelling parent"; failwith "Parent cancel"); + "not-reached";; ++Cancelling parent +Exception: Failure "Parent cancel". +``` + +Cancelling in a sub-switch. We see the exception as `Cancelled Exit` when we're being asked to cancel, +but just as plain `Exit` after we leave the context in which the cancellation started: + +```ocaml +# run @@ fun () -> + let p, r = Promise.create () in + Fiber.both + (fun () -> + try + Switch.run (fun _ -> + try Promise.await p + with ex -> traceln "Nested exception: %a" Fmt.exn ex; raise ex + ) + with ex -> traceln "Parent exception: %a" Fmt.exn ex; raise ex + ) + (fun () -> raise Exit); + failwith "not-reached";; ++Nested exception: Cancelled: Stdlib.Exit ++Parent exception: Cancelled: Stdlib.Exit +Exception: Stdlib.Exit. +``` + +# Fiber.pair + +```ocaml +# run @@ fun () -> + let x, y = Fiber.pair (fun () -> "a") (fun () -> "b") in + x ^ y;; ++ab +- : unit = () +``` + +# Fiber.all + +```ocaml +# run @@ fun () -> + Fiber.all []; + Fiber.all (List.init 3 (fun x () -> traceln "fiber %d" x)); + "done";; ++fiber 0 ++fiber 1 ++fiber 2 ++done +- : unit = () +``` + +# Fiber.any + +```ocaml +# run @@ fun () -> + string_of_int @@ + Fiber.any (List.init 3 (fun x () -> traceln "%d" x; Fiber.yield (); x));; ++0 ++1 ++2 ++0 +- : unit = () +``` + +`Fiber.any` with combine collects all results: + +```ocaml +# run @@ fun () -> + Fiber.any + ~combine:(fun x y -> x @ y) + (List.init 3 (fun x () -> traceln "%d" x; [x])) + |> Fmt.(str "%a" (Dump.list int));; ++0 ++1 ++2 ++[0; 1; 2] +- : unit = () +``` + +# Fiber.n_any + +`Fiber.n_any` behaves just like `Fiber.any` when there's only one result: + +```ocaml +# run @@ fun () -> + Fiber.n_any (List.init 3 (fun x () -> traceln "%d" x; Fiber.yield (); x)) + |> Fmt.(str "%a" (Dump.list int));; ++0 ++1 ++2 ++[0] +- : unit = () +``` + +`Fiber.n_any` collects all results: + +```ocaml +# run @@ fun () -> + (Fiber.n_any (List.init 4 (fun x () -> + traceln "%d" x; + if x = 1 then Fiber.yield (); + x + ))) + |> Fmt.(str "%a" (Dump.list int));; ++0 ++1 ++2 ++3 ++[0; 2; 3] +- : unit = () +``` + +# Fiber.await_cancel + +```ocaml +# run @@ fun () -> + Fiber.both + (fun () -> + try Fiber.await_cancel () + with Eio.Cancel.Cancelled _ as ex -> + traceln "Caught: %a" Fmt.exn ex; + raise ex + ) + (fun () -> failwith "simulated error"); + "not reached";; ++Caught: Cancelled: Failure("simulated error") +Exception: Failure "simulated error". +``` + +# Fiber.fork_promise + +`Fiber.fork_promise ~sw` inherits the cancellation context from `sw`, not from the current fiber: + +```ocaml +# run @@ fun () -> + let switch = ref None in + Fiber.both + (fun () -> + Switch.run @@ fun sw -> + switch := Some sw; + Fiber.await_cancel () + ) + (fun () -> + let sw = Option.get !switch in + Eio.Cancel.protect @@ fun () -> + let child = Fiber.fork_promise ~sw (fun () -> + traceln "Forked child"; + Fiber.await_cancel () + ) in + Switch.fail sw Exit; + Promise.await_exn child + ); + "not reached";; ++Forked child +Exception: Stdlib.Exit. +``` + +# Scheduling order + +Forking runs the child first, and puts the calling fiber at the head of the run-queue. + +```ocaml +# run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> traceln "1st child runs"; Fiber.yield (); traceln "Queued work"); + Fiber.fork ~sw (fun () -> traceln "2nd child runs immediately"); + traceln "Caller runs before queued work"; + "ok";; ++1st child runs ++2nd child runs immediately ++Caller runs before queued work ++Queued work ++ok +- : unit = () +``` + +Same with `both`: + +```ocaml +# run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> traceln "Enqueuing work for later"; Fiber.yield (); traceln "Queued work"); + Fiber.both + (fun () -> traceln "1st branch") + (fun () -> traceln "2nd branch"); + "ok";; ++Enqueuing work for later ++1st branch ++2nd branch ++Queued work ++ok +- : unit = () +``` + +Same with `first`: + +```ocaml +# run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> traceln "Enqueuing work for later"; Fiber.yield (); traceln "Queued work"); + Fiber.first + (fun () -> traceln "1st branch") + (fun () -> traceln "2nd branch"); + "ok";; ++Enqueuing work for later ++1st branch ++2nd branch ++Queued work ++ok +- : unit = () +``` + +# Forking while cancelled + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> failwith "Simulated error") + (fun () -> + Fiber.both + (fun () -> traceln "Not reached") + (fun () -> traceln "Not reached"); + assert false + );; +Exception: Failure "Simulated error". +``` + +# Concurrent list operations + +```ocaml +let process fn x = + traceln "Start %d" x; + Fiber.yield (); + let y = fn x in + traceln "Finished %d" x; + y + +let is_even x = (x land 1 = 0) + +let string_even x = + if is_even x then Some (string_of_int x) + else None + +let crash_on_three x = + if x = 3 then failwith "Simulated error" + else string_even x +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.List.filter (process is_even) [1; 2; 3; 4] + |> traceln "%a" Fmt.(Dump.list int);; ++Start 1 ++Start 2 ++Start 3 ++Start 4 ++Finished 1 ++Finished 2 ++Finished 3 ++Finished 4 ++[2; 4] +- : unit = () +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.List.map (process string_even) [1; 2; 3; 4] + |> traceln "%a" Fmt.Dump.(list (option string));; ++Start 1 ++Start 2 ++Start 3 ++Start 4 ++Finished 1 ++Finished 2 ++Finished 3 ++Finished 4 ++[None; Some "2"; None; Some "4"] +- : unit = () +``` + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.List.filter_map (process string_even) [1; 2; 3; 4] + |> traceln "%a" Fmt.Dump.(list string);; ++Start 1 ++Start 2 ++Start 3 ++Start 4 ++Finished 1 ++Finished 2 ++Finished 3 ++Finished 4 ++["2"; "4"] +- : unit = () +``` + +If any fiber raises, everything is cancelled: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.List.filter_map (process crash_on_three) [1; 2; 3; 4] + |> traceln "%a" Fmt.Dump.(list string);; ++Start 1 ++Start 2 ++Start 3 ++Start 4 ++Finished 1 ++Finished 2 +Exception: Failure "Simulated error". +``` + +The number of concurrent fibers can be limited: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let ps = Array.init 4 (fun _ -> Promise.create ()) in + let await i = Promise.await (fst ps.(i)) in + let finish i = Promise.resolve (snd (ps.(i))) in + Fiber.both + (fun () -> + Fiber.List.map ~max_fibers:2 (process await) (List.init 4 Fun.id) + |> traceln "%a" Fmt.(Dump.list string) + ) + (fun () -> + finish 1 "one"; + Fiber.yield (); + finish 2 "two"; + Fiber.yield (); Fiber.yield (); + finish 0 "zero"; + Fiber.yield (); Fiber.yield (); + finish 3 "three"; + );; ++Start 0 ++Start 1 ++Finished 1 ++Start 2 ++Finished 2 ++Start 3 ++Finished 0 ++Finished 3 ++[zero; one; two; three] +- : unit = () +``` + +Handling exceptions while waiting for a free fiber: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let ps = Array.init 2 (fun _ -> Promise.create ()) in + let await i = Promise.await_exn (fst ps.(i)) in + let finish i = Promise.resolve (snd (ps.(i))) in + Fiber.both + (fun () -> + Fiber.List.map ~max_fibers:1 (process await) (List.init 2 Fun.id) + |> traceln "%a" Fmt.(Dump.list string) + ) + (fun () -> + Fiber.yield (); + finish 0 (Error (Failure "Simulated error")) + );; ++Start 0 +Exception: Failure "Simulated error". +``` + +Simple iteration: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let ps = Array.init 4 (fun _ -> Promise.create ()) in + let await i = Promise.await (fst ps.(i)) in + let finish i = Promise.resolve (snd (ps.(i))) () in + Fiber.both + (fun () -> + Fiber.List.iter ~max_fibers:2 (process await) (List.init 4 Fun.id) + ) + (fun () -> + finish 1; + Fiber.yield (); + finish 2; + Fiber.yield (); Fiber.yield (); + finish 0; + Fiber.yield (); Fiber.yield (); + finish 3; + );; ++Start 0 ++Start 1 ++Finished 1 ++Start 2 ++Finished 2 ++Start 3 ++Finished 0 ++Finished 3 +- : unit = () +``` + +# Daemon fibers + +A daemon fiber runs until the non-daemon threads finish: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork_daemon ~sw (fun () -> + for i = 1 to 10 do + traceln "Daemon running"; + Fiber.yield () + done; + failwith "Test failed" + ); + traceln "Main running 1"; + Fiber.yield (); + traceln "Main running 2";; ++Daemon running ++Main running 1 ++Daemon running ++Main running 2 +- : unit = () +``` + +A more complex example with multiple daemon and non-daemon fibers: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> + traceln "Worker 1 starting"; + Fiber.yield (); + traceln "Worker 1 running"; + Fiber.yield (); + traceln "Worker 1 finished" + ); + Fiber.fork ~sw (fun () -> + traceln "Worker 2 starting"; + Fiber.yield (); + traceln "Worker 2 finished" + ); + Fiber.fork_daemon ~sw (fun () -> + try + for i = 1 to 10 do + traceln "Daemon 1 running"; + Fiber.yield () + done; + failwith "Test failed" + with Eio.Cancel.Cancelled _ as ex -> + traceln "Daemon cancelled; trying to spawn more fibers"; + Fiber.fork_daemon ~sw (fun () -> failwith "Shouldn't start"); + Fiber.fork ~sw (fun () -> failwith "Shouldn't start"); + raise ex + ); + Fiber.fork_daemon ~sw (fun () -> + traceln "Daemon 2 running"; + Fiber.yield (); + traceln "Daemon 2 finished"; + `Stop_daemon + ); + traceln "Main running"; + Fiber.yield (); + traceln "Main finished";; ++Worker 1 starting ++Worker 2 starting ++Daemon 1 running ++Daemon 2 running ++Main running ++Worker 1 running ++Worker 2 finished ++Daemon 1 running ++Daemon 2 finished ++Main finished ++Worker 1 finished ++Daemon cancelled; trying to spawn more fibers +- : unit = () +``` + +Failing daemon fibers still get their errors reported: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork_daemon ~sw (fun () -> + Fiber.yield (); + failwith "Simulated error" + ); + Fiber.yield ();; +Exception: Failure "Simulated error". +``` + +# Fiber-local storage + +Creating a context key: + +```ocaml +# let key : int Fiber.key = Fiber.create_key ();; +val key : int Fiber.key = + +# let trace_key () = + let value = Fiber.get key in + traceln "Key => %a" Fmt.(option ~none:(const string "") int) value;; +val trace_key : unit -> unit = +``` + +Keys default to being unset + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + trace_key ();; ++Key => +- : unit = () +``` + +`with_binding` can be used to define a key. + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.with_binding key 123 @@ fun () -> trace_key ();; ++Key => 123 +- : unit = () +``` + +`with_binding` will shadow variables defined in outer scopes. + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.with_binding key 123 @@ fun () -> + trace_key (); + Fiber.with_binding key 456 (fun () -> trace_key ()); + trace_key ();; ++Key => 123 ++Key => 456 ++Key => 123 +- : unit = () +``` + +Values are propagated when forking: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.with_binding key 123 @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw trace_key;; ++Key => 123 +- : unit = () +``` + +Bindings can also be removed: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.with_binding key 123 @@ fun () -> + trace_key (); + Fiber.without_binding key (fun () -> trace_key ()); + trace_key ();; ++Key => 123 ++Key => ++Key => 123 +- : unit = () +``` + +Values are inherited from the currently running fiber, rather than the switch. + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.with_binding key 123 @@ fun () -> + Fiber.fork ~sw trace_key;; ++Key => 123 +- : unit = () +``` + +## fork_seq + +The simple case where everything works: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let seq = + Fiber.fork_seq ~sw (fun yield -> + traceln "Generator fiber starting"; + for i = 1 to 3 do + traceln "Yielding %d" i; + yield i + done + ) + in + traceln "Requesting 1st item"; + match seq () with + | Nil -> assert false + | Cons (x, seq) -> + traceln "hd = %d" x; + traceln "Requesting remaining items"; + List.of_seq seq;; ++Requesting 1st item ++Generator fiber starting ++Yielding 1 ++hd = 1 ++Requesting remaining items ++Yielding 2 ++Yielding 3 +- : int list = [2; 3] +``` + +The generator raises: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let seq = + Fiber.fork_seq ~sw (fun yield -> + traceln "Generator fiber starting"; + raise (Failure "Simulated error") + ) + in + Eio.Cancel.protect (fun () -> (* (ensure we get the exception from the sequence) *) + traceln "Requesting an item"; + try + ignore (seq ()); + assert false + with ex -> traceln "Consumer got exception: %a" Fmt.exn ex + );; ++Requesting an item ++Generator fiber starting ++Consumer got exception: Failure("Simulated error") +- : unit = () +``` + +The sequence is used after the switch is finished: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let seq = + Switch.run (fun sw -> + Fiber.fork_seq ~sw (fun _yield -> assert false) + ) + in + traceln "Requesting an item"; + seq ();; ++Requesting an item +Exception: +Invalid_argument "Coroutine has already failed: Cancelled: Stdlib.Exit". +``` + +The sequence is used after the switch is finished, and the generator has started: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let seq = + Switch.run (fun sw -> + let seq = + Fiber.fork_seq ~sw (fun yield -> + try yield 1 + with ex -> traceln "Generator caught: %a" Fmt.exn ex; raise ex + ) + in + traceln "Requesting an item"; + match seq () with + | Nil -> assert false + | Cons (x, seq) -> + traceln "Got %d" x; + seq + ) + in + traceln "Switch finished. Requesting another item..."; + seq ();; ++Requesting an item ++Got 1 ++Generator caught: Cancelled: Stdlib.Exit ++Switch finished. Requesting another item... +Exception: +Invalid_argument "Coroutine has already failed: Cancelled: Stdlib.Exit". +``` + +Using a sequence after it has finished normally: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> yield 1; traceln "Generator done") in + let next = Seq.to_dispenser seq in + traceln "Got %a" Fmt.(Dump.option int) (next ()); + traceln "Got %a" Fmt.(Dump.option int) (next ()); + next ();; ++Got Some 1 ++Generator done ++Got None +Exception: Invalid_argument "Coroutine has already finished!". +``` + +Trying to resume twice: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun _yield -> Fiber.await_cancel ()) in + Fiber.both + (fun () -> ignore (seq ())) + (fun () -> ignore (seq ()));; +Exception: Invalid_argument "Coroutine is still running!". +``` + +Generator yields twice for a single request: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> Fiber.both yield yield) in + seq ();; +Exception: Invalid_argument "Coroutine has already yielded!". +``` + +Yielding from a different fiber (note: end-of-sequence is still sent when the original fiber exits): + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> + let p = Fiber.fork_promise ~sw (fun () -> Fiber.yield (); yield "Second fiber") in + Promise.await_exn p; + yield "Original fiber" + ) in + List.of_seq seq;; +- : string list = ["Second fiber"; "Original fiber"] +``` + +The consumer cancels: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> + traceln "Working..."; + try + Fiber.yield (); + yield 1 + with ex -> traceln "Generator caught: %a" Fmt.exn ex; raise ex + ) in + Fiber.first + (fun () -> seq ()) + (fun () -> Nil);; ++Working... ++Generator caught: Cancelled: Eio__core__Fiber.Not_first +- : int Seq.node = Seq.Nil +``` + +The generator is cancelled while queued to be resumed. +It runs, but cancels at the next opportunity: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> + traceln "Working..."; + try Fiber.check () + with ex -> traceln "Generator caught: %a" Fmt.exn ex; raise ex + ) in + traceln "Enqueue resume"; + Fiber.both + (fun () -> ignore (seq () : _ Seq.node); assert false) + (fun () -> + traceln "Cancel generator"; + Switch.fail sw Exit + ) ++Enqueue resume ++Cancel generator ++Working... ++Generator caught: Cancelled: Stdlib.Exit +Exception: Stdlib.Exit. +``` diff --git a/tests/flow.md b/tests/flow.md index 02b406194..8a4c125ea 100644 --- a/tests/flow.md +++ b/tests/flow.md @@ -1,222 +1,222 @@ -## Setting up the environment - -```ocaml -# #require "eio_main";; -# #require "eio.mock";; -``` - -```ocaml -open Eio.Std - -let run fn = - Eio_main.run @@ fun _ -> - fn () - -let mock_source = - let module X = struct - type t = Cstruct.t list ref - - let read_methods = [] - - let single_read t buf = - match !t with - | [] -> raise End_of_file - | x :: xs -> - let len = min (Cstruct.length buf) (Cstruct.length x) in - Cstruct.blit x 0 buf 0 len; - t := Cstruct.shiftv (x :: xs) len; - len - end in - let ops = Eio.Flow.Pi.source (module X) in - fun items -> Eio.Resource.T (ref items, ops) -``` - -## read_exact - -```ocaml -# run @@ fun () -> - let data = List.map Cstruct.of_string ["foo"; "bar"] in - let test n = - let buf = Cstruct.create n in - Eio.Flow.read_exact (mock_source data) buf; - traceln "Got %S" (Cstruct.to_string buf) - in - test 0; - test 3; - test 5; - test 6; - test 7;; -+Got "" -+Got "foo" -+Got "fooba" -+Got "foobar" -Exception: End_of_file. -``` - -## copy - -```ocaml -# run @@ fun () -> - let src = Eio_mock.Flow.make "src" in - let dst = Eio_mock.Flow.make "dst" in - Eio_mock.Flow.on_read src [`Return "foo"; `Return "bar"]; - Eio.Flow.copy src dst;; -+src: read "foo" -+dst: wrote "foo" -+src: read "bar" -+dst: wrote "bar" -- : unit = () -``` - -Copying from a string src: - -```ocaml -# run @@ fun () -> - let src = Eio.Flow.string_source "foobar" in - let dst = Eio_mock.Flow.make "dst" in - Eio_mock.Flow.on_copy_bytes dst [`Return 3; `Return 5]; - Eio.Flow.copy src dst;; -+dst: wrote "foo" -+dst: wrote "bar" -- : unit = () -``` - -Copying from src using a plain buffer (the default): - -```ocaml -# run @@ fun () -> - let src = Eio.Flow.cstruct_source [Cstruct.of_string "foobar"] in - let dst = Eio_mock.Flow.make "dst" in - Eio_mock.Flow.on_copy_bytes dst [`Return 3; `Return 5]; - Eio.Flow.copy src dst;; -+dst: wrote "foo" -+dst: wrote "bar" -- : unit = () -``` - -Copying from src using `Read_source_buffer`: - -```ocaml -# run @@ fun () -> - let src = Eio.Flow.cstruct_source [Cstruct.of_string "foobar"] in - let dst = Eio_mock.Flow.make "dst" in - Eio_mock.Flow.set_copy_method dst `Read_source_buffer; - Eio_mock.Flow.on_copy_bytes dst [`Return 3; `Return 5]; - Eio.Flow.copy src dst;; -+dst: wrote (rsb) ["foo"] -+dst: wrote (rsb) ["bar"] -- : unit = () -``` - -## read_all - -```ocaml -# run @@ fun () -> - let each = String.init 256 Char.chr in - let data = List.init 40 (fun _ -> Cstruct.of_string each) in - let got = Eio.Flow.read_all (mock_source data) in - traceln "Input length: %d\nOutput length: %d\nEqual: %b" - (Cstruct.lenv data) (String.length got) (String.equal got (Cstruct.copyv data)); - ;; -+Input length: 10240 -+Output length: 10240 -+Equal: true -- : unit = () -``` - -## write - -```ocaml -# run @@ fun () -> - let dst = Eio_mock.Flow.make "dst" in - Eio_mock.Flow.on_copy_bytes dst [`Return 6]; - Eio.Flow.write dst [Cstruct.of_string "foobar"];; -+dst: wrote "foobar" -- : unit = () -``` - -## Pipes - -Writing to and reading from a pipe. - -```ocaml -# Eio_main.run @@ fun env -> - Switch.run @@ fun sw -> - let r, w = Eio_unix.pipe sw in - let msg = "Hello, world" in - Eio.Fiber.both - (fun () -> - let buf = Cstruct.create (String.length msg) in - let () = Eio.Flow.read_exact r buf in - traceln "Got: %s" (Cstruct.to_string buf) - ) - (fun () -> - Eio.Flow.copy_string msg w; - Eio.Flow.close w - );; -+Got: Hello, world -- : unit = () -``` - -Make sure we don't crash on SIGPIPE: - -```ocaml -# Eio_main.run @@ fun env -> - Switch.run @@ fun sw -> - let r, w = Eio_unix.pipe sw in - Eio.Flow.close r; - try - Eio.Flow.copy_string "Test" w; - assert false - with Eio.Io (Eio.Net.E Connection_reset _, _) -> - traceln "Connection_reset (good)";; -+Connection_reset (good) -- : unit = () -``` - -## IO_MAX - -Sending a very long vector over a flow should just send it in chunks, not fail: - -```ocaml -# Eio_main.run @@ fun env -> - Switch.run @@ fun sw -> - let r, w = Eio_unix.pipe sw in - let a = Cstruct.of_string "abc" in - let vecs = List.init 10_000 (Fun.const a) in - Fiber.both - (fun () -> - Eio.Flow.write w vecs; - Eio.Flow.close w - ) - (fun () -> - let got = Eio.Flow.read_all r in - traceln "Read %d bytes" (String.length got); - assert (got = Cstruct.to_string (Cstruct.concat vecs)) - ) -+Read 30000 bytes -- : unit = () -``` - -## Starvation - -Even if a fiber is already ready to run, we still perform IO from time to time: - -```ocaml -# run @@ fun _ -> - Switch.run @@ fun sw -> - let r, w = Eio_unix.pipe sw in - let rec spin () = Fiber.yield (); spin () in - Fiber.fork_daemon ~sw spin; - Fiber.both - (fun () -> - let buf = Cstruct.create 3 in - Eio.Flow.read_exact r buf; - traceln "Got %S" (Cstruct.to_string buf) - ) - (fun () -> - Eio.Flow.write w [Cstruct.of_string "msg"] - ) -+Got "msg" -- : unit = () -``` +## Setting up the environment + +```ocaml +# #require "eio_main";; +# #require "eio.mock";; +``` + +```ocaml +open Eio.Std + +let run fn = + Eio_main.run @@ fun _ -> + fn () + +let mock_source = + let module X = struct + type t = Cstruct.t list ref + + let read_methods = [] + + let single_read t buf = + match !t with + | [] -> raise End_of_file + | x :: xs -> + let len = min (Cstruct.length buf) (Cstruct.length x) in + Cstruct.blit x 0 buf 0 len; + t := Cstruct.shiftv (x :: xs) len; + len + end in + let ops = Eio.Flow.Pi.source (module X) in + fun items -> Eio.Resource.T (ref items, ops) +``` + +## read_exact + +```ocaml +# run @@ fun () -> + let data = List.map Cstruct.of_string ["foo"; "bar"] in + let test n = + let buf = Cstruct.create n in + Eio.Flow.read_exact (mock_source data) buf; + traceln "Got %S" (Cstruct.to_string buf) + in + test 0; + test 3; + test 5; + test 6; + test 7;; ++Got "" ++Got "foo" ++Got "fooba" ++Got "foobar" +Exception: End_of_file. +``` + +## copy + +```ocaml +# run @@ fun () -> + let src = Eio_mock.Flow.make "src" in + let dst = Eio_mock.Flow.make "dst" in + Eio_mock.Flow.on_read src [`Return "foo"; `Return "bar"]; + Eio.Flow.copy src dst;; ++src: read "foo" ++dst: wrote "foo" ++src: read "bar" ++dst: wrote "bar" +- : unit = () +``` + +Copying from a string src: + +```ocaml +# run @@ fun () -> + let src = Eio.Flow.string_source "foobar" in + let dst = Eio_mock.Flow.make "dst" in + Eio_mock.Flow.on_copy_bytes dst [`Return 3; `Return 5]; + Eio.Flow.copy src dst;; ++dst: wrote "foo" ++dst: wrote "bar" +- : unit = () +``` + +Copying from src using a plain buffer (the default): + +```ocaml +# run @@ fun () -> + let src = Eio.Flow.cstruct_source [Cstruct.of_string "foobar"] in + let dst = Eio_mock.Flow.make "dst" in + Eio_mock.Flow.on_copy_bytes dst [`Return 3; `Return 5]; + Eio.Flow.copy src dst;; ++dst: wrote "foo" ++dst: wrote "bar" +- : unit = () +``` + +Copying from src using `Read_source_buffer`: + +```ocaml +# run @@ fun () -> + let src = Eio.Flow.cstruct_source [Cstruct.of_string "foobar"] in + let dst = Eio_mock.Flow.make "dst" in + Eio_mock.Flow.set_copy_method dst `Read_source_buffer; + Eio_mock.Flow.on_copy_bytes dst [`Return 3; `Return 5]; + Eio.Flow.copy src dst;; ++dst: wrote (rsb) ["foo"] ++dst: wrote (rsb) ["bar"] +- : unit = () +``` + +## read_all + +```ocaml +# run @@ fun () -> + let each = String.init 256 Char.chr in + let data = List.init 40 (fun _ -> Cstruct.of_string each) in + let got = Eio.Flow.read_all (mock_source data) in + traceln "Input length: %d\nOutput length: %d\nEqual: %b" + (Cstruct.lenv data) (String.length got) (String.equal got (Cstruct.copyv data)); + ;; ++Input length: 10240 ++Output length: 10240 ++Equal: true +- : unit = () +``` + +## write + +```ocaml +# run @@ fun () -> + let dst = Eio_mock.Flow.make "dst" in + Eio_mock.Flow.on_copy_bytes dst [`Return 6]; + Eio.Flow.write dst [Cstruct.of_string "foobar"];; ++dst: wrote "foobar" +- : unit = () +``` + +## Pipes + +Writing to and reading from a pipe. + +```ocaml +# Eio_main.run @@ fun env -> + Switch.run @@ fun sw -> + let r, w = Eio_unix.pipe sw in + let msg = "Hello, world" in + Eio.Fiber.both + (fun () -> + let buf = Cstruct.create (String.length msg) in + let () = Eio.Flow.read_exact r buf in + traceln "Got: %s" (Cstruct.to_string buf) + ) + (fun () -> + Eio.Flow.copy_string msg w; + Eio.Flow.close w + );; ++Got: Hello, world +- : unit = () +``` + +Make sure we don't crash on SIGPIPE: + +```ocaml +# Eio_main.run @@ fun env -> + Switch.run @@ fun sw -> + let r, w = Eio_unix.pipe sw in + Eio.Flow.close r; + try + Eio.Flow.copy_string "Test" w; + assert false + with Eio.Io (Eio.Net.E Connection_reset _, _) -> + traceln "Connection_reset (good)";; ++Connection_reset (good) +- : unit = () +``` + +## IO_MAX + +Sending a very long vector over a flow should just send it in chunks, not fail: + +```ocaml +# Eio_main.run @@ fun env -> + Switch.run @@ fun sw -> + let r, w = Eio_unix.pipe sw in + let a = Cstruct.of_string "abc" in + let vecs = List.init 10_000 (Fun.const a) in + Fiber.both + (fun () -> + Eio.Flow.write w vecs; + Eio.Flow.close w + ) + (fun () -> + let got = Eio.Flow.read_all r in + traceln "Read %d bytes" (String.length got); + assert (got = Cstruct.to_string (Cstruct.concat vecs)) + ) ++Read 30000 bytes +- : unit = () +``` + +## Starvation + +Even if a fiber is already ready to run, we still perform IO from time to time: + +```ocaml +# run @@ fun _ -> + Switch.run @@ fun sw -> + let r, w = Eio_unix.pipe sw in + let rec spin () = Fiber.yield (); spin () in + Fiber.fork_daemon ~sw spin; + Fiber.both + (fun () -> + let buf = Cstruct.create 3 in + Eio.Flow.read_exact r buf; + traceln "Got %S" (Cstruct.to_string buf) + ) + (fun () -> + Eio.Flow.write w [Cstruct.of_string "msg"] + ) ++Got "msg" +- : unit = () +``` diff --git a/tests/fs.md b/tests/fs.md index 446874ad3..6a83a46e8 100644 --- a/tests/fs.md +++ b/tests/fs.md @@ -1,1013 +1,1013 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -# ignore @@ Unix.umask 0o022;; -- : unit = () -``` - -```ocaml - -module Int63 = Optint.Int63 -module Path = Eio.Path - -let () = Eio.Exn.Backend.show := false - -open Eio.Std - -let ( / ) = Path.( / ) - -let run ?clear:(paths = []) fn = - Eio_main.run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - List.iter (fun p -> Eio.Path.rmtree ~missing_ok:true (cwd / p)) paths; - fn env - -let try_read_file path = - match Path.load path with - | s -> traceln "read %a -> %S" Path.pp path s - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let try_write_file ~create ?append path content = - match Path.save ~create ?append path content with - | () -> traceln "write %a -> ok" Path.pp path - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let try_mkdir path = - match Path.mkdir path ~perm:0o700 with - | () -> traceln "mkdir %a -> ok" Path.pp path - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let try_mkdirs ?exists_ok path = - match Path.mkdirs ?exists_ok path ~perm:0o700 with - | () -> traceln "mkdirs %a -> ok" Path.pp path - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let try_rename p1 p2 = - match Path.rename p1 p2 with - | () -> traceln "rename %a to %a -> ok" Path.pp p1 Path.pp p2 - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let try_read_dir path = - match Path.read_dir path with - | names -> traceln "read_dir %a -> %a" Path.pp path Fmt.Dump.(list string) names - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let try_read_link path = - match Path.read_link path with - | target -> traceln "read_link %a -> %S" Path.pp path target - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let try_unlink path = - match Path.unlink path with - | () -> traceln "unlink %a -> ok" Path.pp path - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let try_rmdir path = - match Path.rmdir path with - | () -> traceln "rmdir %a -> ok" Path.pp path - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let try_rmtree ?missing_ok path = - match Path.rmtree ?missing_ok path with - | () -> traceln "rmtree %a -> ok" Path.pp path - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex - -let chdir path = - traceln "chdir %S" path; - Unix.chdir path - -let try_stat path = - let stat ~follow = - match Eio.Path.stat ~follow path with - | info -> Fmt.str "@[%a@]" Eio.File.Stat.pp_kind info.kind - | exception Eio.Io (e, _) -> Fmt.str "@[%a@]" Eio.Exn.pp_err e - in - let a = stat ~follow:false in - let b = stat ~follow:true in - if a = b then - traceln "%a -> %s" Eio.Path.pp path a - else - traceln "%a -> %s / %s" Eio.Path.pp path a b - -let try_symlink ~link_to path = - match Path.symlink ~link_to path with - | s -> traceln "symlink %a -> %S" Path.pp path link_to - | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex -``` - -# Basic test cases - -Creating a file and reading it back: - -```ocaml -# run ~clear:["test-file"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - Path.save ~create:(`Exclusive 0o666) (cwd / "test-file") "my-data"; - traceln "Got %S" @@ Path.load (cwd / "test-file");; -+Got "my-data" -- : unit = () -``` - -Check the file got the correct permissions (subject to the umask set above): - -```ocaml -# Printf.printf "Perm = %o\n" ((Unix.stat "test-file").st_perm);; -Perm = 644 -- : unit = () -``` - -# Sandboxing - -Trying to use cwd to access a file outside of that subtree fails: - -```ocaml -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - Path.save ~create:(`Exclusive 0o666) (cwd / "../test-file") "my-data"; - failwith "Should have failed";; -Exception: Eio.Io Fs Permission_denied _, - opening -``` - -Trying to use cwd to access an absolute path fails: - -```ocaml -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - Path.save ~create:(`Exclusive 0o666) (cwd / "/tmp/test-file") "my-data"; - failwith "Should have failed";; -Exception: Eio.Io Fs Permission_denied _, - opening -``` - -# Creation modes - -Exclusive create fails if already exists: - -```ocaml -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - Path.save ~create:(`Exclusive 0o666) (cwd / "test-file") "first-write"; - Path.save ~create:(`Exclusive 0o666) (cwd / "test-file") "first-write"; - failwith "Should have failed";; -Exception: Eio.Io Fs Already_exists _, - opening -``` - -If-missing create succeeds if already exists: - -```ocaml -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - let test_file = (cwd / "test-file") in - Path.save ~create:(`If_missing 0o666) test_file "1st-write-original"; - Path.save ~create:(`If_missing 0o666) test_file "2nd-write"; - traceln "Got %S" @@ Path.load test_file;; -+Got "2nd-write-original" -- : unit = () -``` - -Truncate create succeeds if already exists, and truncates: - -```ocaml -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - let test_file = (cwd / "test-file") in - Path.save ~create:(`Or_truncate 0o666) test_file "1st-write-original"; - Path.save ~create:(`Or_truncate 0o666) test_file "2nd-write"; - traceln "Got %S" @@ Path.load test_file;; -+Got "2nd-write" -- : unit = () -# Unix.unlink "test-file";; -- : unit = () -``` - -Error if no create and doesn't exist: - -```ocaml -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - let test_file = (cwd / "test-file") in - Path.save ~create:`Never test_file "1st-write-original"; - traceln "Got %S" @@ Path.load test_file;; -Exception: Eio.Io Fs Not_found _, - opening -``` - -Appending to an existing file: - -```ocaml -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - let test_file = (cwd / "test-file") in - Path.save ~create:(`Or_truncate 0o666) test_file "1st-write-original"; - Path.save ~create:`Never ~append:true test_file "2nd-write"; - traceln "Got %S" @@ Path.load test_file;; -+Got "1st-write-original2nd-write" -- : unit = () -# Unix.unlink "test-file";; -- : unit = () -``` - -# Mkdir - -```ocaml -# run ~clear:["subdir"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - try_mkdir (cwd / "subdir"); - try_mkdir (cwd / "subdir/nested"); - Path.save ~create:(`Exclusive 0o600) (cwd / "subdir/nested/test-file") "data"; - ();; -+mkdir -> ok -+mkdir -> ok -- : unit = () -# Unix.unlink "subdir/nested/test-file"; - Unix.rmdir "subdir/nested"; - Unix.rmdir "subdir";; -- : unit = () -``` - -Creating directories with nesting, symlinks, etc: - -```ocaml -# run ~clear:["to-subdir"; "to-root"; "dangle"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - Path.symlink ~link_to:"/" (cwd / "to-root"); - Path.symlink ~link_to:"subdir" (cwd / "to-subdir"); - Path.symlink ~link_to:"foo" (cwd / "dangle"); - try_mkdir (cwd / "subdir"); - try_mkdir (cwd / "to-subdir/nested"); - try_mkdir (cwd / "to-root/tmp/foo"); - try_mkdir (cwd / "../foo"); - try_mkdir (cwd / "to-subdir"); - try_mkdir (cwd / "dangle/foo"); - ();; -+mkdir -> ok -+mkdir -> ok -+Eio.Io Fs Permission_denied _, creating directory -+Eio.Io Fs Permission_denied _, creating directory -+Eio.Io Fs Already_exists _, creating directory -+Eio.Io Fs Not_found _, creating directory -- : unit = () -``` - -# Split - -```ocaml -let fake_dir : Eio.Fs.dir_ty r = Eio.Resource.T ((), Eio.Resource.handler []) -let split path = Eio.Path.split (fake_dir, path) |> Option.map (fun ((_, dirname), basename) -> dirname, basename) -``` - -```ocaml -# split "foo/bar"; -- : (string * string) option = Some ("foo", "bar") - -# split "/foo/bar"; -- : (string * string) option = Some ("/foo", "bar") - -# split "/foo/bar/baz"; -- : (string * string) option = Some ("/foo/bar", "baz") - -# split "/foo/bar//baz/"; -- : (string * string) option = Some ("/foo/bar", "baz") - -# split "bar"; -- : (string * string) option = Some ("", "bar") - -# split "/bar"; -- : (string * string) option = Some ("/", "bar") - -# split "."; -- : (string * string) option = Some ("", ".") - -# split "./"; -- : (string * string) option = Some ("", ".") - -# split ""; -- : (string * string) option = None - -# split "/"; -- : (string * string) option = None - -# split "///"; -- : (string * string) option = None -``` - -# Mkdirs - -Recursively creating directories with `mkdirs`. - -```ocaml -# run ~clear:["subdir1"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - let nested = cwd / "subdir1" / "subdir2" / "subdir3" in - try_mkdirs nested; - assert (Eio.Path.is_directory nested); - let one_more = Path.(nested / "subdir4") in - try_mkdirs one_more; - try_mkdirs ~exists_ok:true one_more; - try_mkdirs one_more; - assert (Eio.Path.is_directory one_more); - try_mkdirs (cwd / ".." / "outside"); -+mkdirs -> ok -+mkdirs -> ok -+mkdirs -> ok -+Eio.Io Fs Already_exists _, creating directory -+Eio.Io Fs Permission_denied _, examining , creating directory -- : unit = () -``` - -Some edge cases for `mkdirs`. - -```ocaml -# run ~clear:["test"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - try_mkdirs (cwd / "."); - try_mkdirs (cwd / "././"); - let lots_of_slashes = "./test//////////////test" in - try_mkdirs (cwd / lots_of_slashes); - assert (Eio.Path.is_directory (cwd / lots_of_slashes)); - try_mkdirs (cwd / "..");; -+Eio.Io Fs Already_exists _, creating directory -+Eio.Io Fs Already_exists _, creating directory -+mkdirs -> ok -+Eio.Io Fs Permission_denied _, creating directory -- : unit = () -``` - -# Unlink - -You can remove a file using unlink: - -```ocaml -# run ~clear:["file"; "subdir/file2"] @@ fun env -> - Switch.run @@ fun sw -> - let cwd = Eio.Stdenv.cwd env in - Path.save ~create:(`Exclusive 0o600) (cwd / "file") "data"; - Path.save ~create:(`Exclusive 0o600) (cwd / "subdir/file2") "data2"; - try_read_file (cwd / "file"); - try_read_file (cwd / "subdir/file2"); - assert (Eio.Path.kind ~follow:true (cwd / "file") = `Regular_file); - try_unlink (cwd / "file"); - assert (Eio.Path.kind ~follow:true (cwd / "file") = `Not_found); - try_unlink (cwd / "subdir/file2"); - try_read_file (cwd / "file"); - try_read_file (cwd / "subdir/file2"); - try_write_file ~create:(`Exclusive 0o600) (cwd / "subdir/file2") "data2"; - try_unlink (cwd / "to-subdir/file2"); - try_read_file (cwd / "subdir/file2");; -+read -> "data" -+read -> "data2" -+unlink -> ok -+unlink -> ok -+Eio.Io Fs Not_found _, opening -+Eio.Io Fs Not_found _, opening -+write -> ok -+unlink -> ok -+Eio.Io Fs Not_found _, opening -- : unit = () -``` - -Removing something that doesn't exist or is out of scope: - -```ocaml -# run @@ fun env -> - Switch.run @@ fun sw -> - let cwd = Eio.Stdenv.cwd env in - try_unlink (cwd / "missing"); - try_unlink (cwd / "../foo"); - try_unlink (cwd / "to-subdir/foo"); - try_unlink (cwd / "to-root/foo");; -+Eio.Io Fs Not_found _, removing file -+Eio.Io Fs Permission_denied _, removing file -+Eio.Io Fs Not_found _, removing file -+Eio.Io Fs Permission_denied _, removing file -- : unit = () -``` - -Reads and writes follow symlinks, but unlink operates on the symlink itself: - -```ocaml -# run ~clear:["link1"; "linkdir"; "linkroot"; "dir1"; "file2"] @@ fun env -> - Switch.run @@ fun sw -> - let cwd = Eio.Stdenv.cwd env in - let fs = Eio.Stdenv.fs env in - - try_mkdir (cwd / "dir1"); - let file1 = cwd / "dir1" / "file1" in - let file2 = cwd / "file2" in - try_write_file ~create:(`Exclusive 0o600) file1 "data1"; - try_write_file ~create:(`Exclusive 0o400) file2 "data2"; - Path.symlink ~link_to:"dir1/file1" (cwd / "link1"); - Path.symlink ~link_to:"../file2" (cwd / "dir1/link2"); - Path.symlink ~link_to:"dir1" (cwd / "linkdir"); - Path.symlink ~link_to:"/" (cwd / "linkroot"); - try_read_file file1; - try_read_file (cwd / "link1"); - try_read_file (cwd / "linkdir" / "file1"); - - try_stat file1; - try_stat (cwd / "link1"); - try_stat (cwd / "linkdir"); - try_stat (cwd / "linkroot"); - try_stat (fs / "linkroot"); - - Fun.protect ~finally:(fun () -> chdir "..") (fun () -> - chdir "dir1"; - try_read_file (cwd / "file1"); - (* Should remove link itself even though it's poiting outside of cwd *) - Path.unlink (cwd / "link2") - ); - try_read_file file2; - Path.unlink (cwd / "link1"); - Path.unlink (cwd / "linkdir"); - Path.unlink (cwd / "linkroot") -+mkdir -> ok -+write -> ok -+write -> ok -+read -> "data1" -+read -> "data1" -+read -> "data1" -+ -> regular file -+ -> symbolic link / regular file -+ -> symbolic link / directory -+ -> symbolic link / Fs Permission_denied _ -+ -> symbolic link / directory -+chdir "dir1" -+read -> "data1" -+chdir ".." -+read -> "data2" -- : unit = () -``` - -# Rmdir - -Similar to `unlink`, but works on directories: - -```ocaml -# run ~clear:["d1"; "subdir/d2"; "subdir/d3"] @@ fun env -> - Switch.run @@ fun sw -> - let cwd = Eio.Stdenv.cwd env in - try_mkdir (cwd / "d1"); - try_mkdir (cwd / "subdir/d2"); - try_read_dir (cwd / "d1"); - try_read_dir (cwd / "subdir/d2"); - try_rmdir (cwd / "d1"); - try_rmdir (cwd / "subdir/d2"); - try_read_dir (cwd / "d1"); - try_read_dir (cwd / "subdir/d2"); - try_mkdir (cwd / "subdir/d3"); - try_rmdir (cwd / "to-subdir/d3"); - try_read_dir (cwd / "subdir/d3");; -+mkdir -> ok -+mkdir -> ok -+read_dir -> [] -+read_dir -> [] -+rmdir -> ok -+rmdir -> ok -+Eio.Io Fs Not_found _, reading directory -+Eio.Io Fs Not_found _, reading directory -+mkdir -> ok -+rmdir -> ok -+Eio.Io Fs Not_found _, reading directory -- : unit = () -``` - -Removing something that doesn't exist or is out of scope: - -```ocaml -# run @@ fun env -> - Switch.run @@ fun sw -> - let cwd = Eio.Stdenv.cwd env in - try_rmdir (cwd / "missing"); - try_rmdir (cwd / "../foo"); - try_rmdir (cwd / "to-subdir/foo"); - try_rmdir (cwd / "to-root/foo");; -+Eio.Io Fs Not_found _, removing directory -+Eio.Io Fs Permission_denied _, removing directory -+Eio.Io Fs Not_found _, removing directory -+Eio.Io Fs Permission_denied _, removing directory -- : unit = () -``` - -# Recursive removal - -```ocaml -# run ~clear:["foo"] @@ fun env -> - Switch.run @@ fun sw -> - let cwd = Eio.Stdenv.cwd env in - let foo = cwd / "foo" in - try_mkdirs (foo / "bar"/ "baz"); - try_write_file ~create:(`Exclusive 0o600) (foo / "bar/file1") "data"; - try_rmtree foo; - assert (Path.kind ~follow:false foo = `Not_found); - traceln "A second rmtree is OK with missing_ok:"; - try_rmtree ~missing_ok:true foo; - traceln "But not without:"; - try_rmtree ~missing_ok:false foo; -+mkdirs -> ok -+write -> ok -+rmtree -> ok -+A second rmtree is OK with missing_ok: -+rmtree -> ok -+But not without: -+Eio.Io Fs Not_found _, removing file -- : unit = () -``` - -# Limiting to a subdirectory - -Create a sandbox, write a file with it, then read it from outside: - -```ocaml -# run ~clear:["sandbox"] @@ fun env -> - Switch.run @@ fun sw -> - let cwd = Eio.Stdenv.cwd env in - try_mkdir (cwd / "sandbox"); - let subdir = Path.open_dir ~sw (cwd / "sandbox") in - Path.save ~create:(`Exclusive 0o600) (subdir / "test-file") "data"; - try_mkdir (subdir / "../new-sandbox"); - traceln "Got %S" @@ Path.load (cwd / "sandbox/test-file");; -+mkdir -> ok -+Eio.Io Fs Permission_denied _, creating directory -+Got "data" -- : unit = () -``` - -```ocaml -# run ~clear:["foo"] @@ fun env -> - let fs = env#fs in - let cwd = env#cwd in - Path.mkdirs (cwd / "foo/bar") ~perm:0o700; - let test ?(succeeds=true) path = - Eio.Exn.Backend.show := succeeds; - try - Switch.run @@ fun sw -> - let _ : _ Path.t = Path.open_dir ~sw path in - traceln "open_dir %a -> OK" Path.pp path - with ex -> - traceln "@[%a@]" Eio.Exn.pp ex - in - let reject = test ~succeeds:false in - test (cwd / "foo/bar"); - reject (cwd / ".."); - test (cwd / "."); - reject (cwd / "/"); - test (cwd / "foo/bar/.."); - test (fs / "foo/bar"); - Path.symlink ~link_to:".." (cwd / "foo/up"); - test (cwd / "foo/up/foo/bar"); - reject (cwd / "foo/up/../bar"); - Path.symlink ~link_to:"/" (cwd / "foo/root"); - reject (cwd / "foo/root/.."); - reject (cwd / "missing"); -+open_dir -> OK -+Eio.Io Fs Permission_denied _, opening directory -+open_dir -> OK -+Eio.Io Fs Permission_denied _, opening directory -+open_dir -> OK -+open_dir -> OK -+open_dir -> OK -+Eio.Io Fs Permission_denied _, opening directory -+Eio.Io Fs Permission_denied _, opening directory -+Eio.Io Fs Not_found _, opening directory -- : unit = () - -# Eio.Exn.Backend.show := false -- : unit = () -``` - -# Unconfined FS access - -We create a directory and chdir into it. -Using `cwd` we can't access the parent, but using `fs` we can: - -```ocaml -# run ~clear:["fs-test"; "outside-cwd"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - let fs = Eio.Stdenv.fs env in - try_mkdir (cwd / "fs-test"); - chdir "fs-test"; - Fun.protect ~finally:(fun () -> chdir "..") (fun () -> - try_mkdir (cwd / "../outside-cwd"); - try_write_file ~create:(`Exclusive 0o600) (cwd / "../test-file") "data"; - try_mkdir (fs / "../outside-cwd"); - try_write_file ~create:(`Exclusive 0o600) (fs / "../test-file") "data"; - ); - Unix.unlink "test-file"; - Unix.rmdir "outside-cwd";; -+mkdir -> ok -+chdir "fs-test" -+Eio.Io Fs Permission_denied _, creating directory -+Eio.Io Fs Permission_denied _, opening -+mkdir -> ok -+write -> ok -+chdir ".." -- : unit = () -``` - -Reading directory entries under `cwd` and outside of `cwd`. - -```ocaml -# run ~clear:["readdir"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - try_mkdir (cwd / "readdir"); - Path.with_open_dir (cwd / "readdir") @@ fun tmpdir -> - try_mkdir (tmpdir / "test-1"); - try_mkdir (tmpdir / "test-2"); - try_write_file ~create:(`Exclusive 0o600) (tmpdir / "test-1/file") "data"; - try_read_dir tmpdir; - try_read_dir (tmpdir / "."); - try_read_dir (tmpdir / ".."); - try_read_dir (tmpdir / "test-3"); - Path.symlink ~link_to:"test-1" (cwd / "readdir/link-1"); - try_read_dir (tmpdir / "link-1"); -+mkdir -> ok -+mkdir -> ok -+mkdir -> ok -+write -> ok -+read_dir -> ["test-1"; "test-2"] -+read_dir -> ["test-1"; "test-2"] -+Eio.Io Fs Permission_denied _, reading directory -+Eio.Io Fs Not_found _, reading directory -+read_dir -> ["file"] -- : unit = () -``` - -An error from the underlying directory, not the sandbox: - -```ocaml -# run ~clear:["test-no-access"] @@ fun env -> - Unix.mkdir "test-no-access" 0;; -- : unit = () -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - try_read_dir (cwd / "test-no-access");; -+Eio.Io Fs Permission_denied _, reading directory -- : unit = () -# Unix.chmod "test-no-access" 0o700;; -- : unit = () -``` - -Can use `fs` to access absolute paths: - -```ocaml -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - let fs = Eio.Stdenv.fs env in - let b = Buffer.create 10 in - Path.with_open_in (fs / Filename.null) (fun flow -> Eio.Flow.copy flow (Eio.Flow.buffer_sink b)); - traceln "Read %S and got %S" Filename.null (Buffer.contents b); - traceln "Trying with cwd instead fails:"; - Path.with_open_in (cwd / Filename.null) (fun flow -> Eio.Flow.copy flow (Eio.Flow.buffer_sink b));;; -+Read "/dev/null" and got "" -+Trying with cwd instead fails: -Exception: Eio.Io Fs Permission_denied _, - opening -``` - -Symlinking and sandboxing: - -```ocaml -# run ~clear:["hello.txt"; "world.txt"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - Path.save ~create:(`Exclusive 0o600) (cwd / "hello.txt") "Hello World!"; - try_symlink ~link_to:"hello.txt" (cwd / "../world.txt"); - try_symlink ~link_to:"hello.txt" (cwd / "/world.txt"); - try_symlink ~link_to:"hello.txt" (cwd / "world.txt"); - traceln "world.txt -> hello.txt: %s" (Path.load (cwd / "world.txt")); - try_symlink ~link_to:"hello.txt" (cwd / "world.txt"); - try_symlink ~link_to:"/" (cwd / "root"); - try_read_dir (cwd / "root");; -+Eio.Io Fs Permission_denied _, creating symlink -> hello.txt -+Eio.Io Fs Permission_denied _, creating symlink -> hello.txt -+symlink -> "hello.txt" -+world.txt -> hello.txt: Hello World! -+Eio.Io Fs Already_exists _, creating symlink -> hello.txt -+symlink -> "/" -+Eio.Io Fs Permission_denied _, reading directory -- : unit = () -``` - -## Streamling lines - -```ocaml -# run ~clear:["test-data"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - Path.save ~create:(`Exclusive 0o600) (cwd / "test-data") "one\ntwo\nthree"; - Path.with_lines (cwd / "test-data") (fun lines -> - Seq.iter (traceln "Line: %s") lines - );; -+Line: one -+Line: two -+Line: three -- : unit = () -``` - -# Unix interop - -We can get the Unix FD from the flow and use it directly: - -```ocaml -# run @@ fun env -> - let fs = Eio.Stdenv.fs env in - Path.with_open_in (fs / Filename.null) (fun flow -> - match Eio_unix.Resource.fd_opt flow with - | None -> failwith "No Unix file descriptor!" - | Some fd -> - Eio_unix.Fd.use_exn "read" fd @@ fun fd -> - let got = Unix.read fd (Bytes.create 10) 0 10 in - traceln "Read %d bytes from null device" got - );; -+Read 0 bytes from null device -- : unit = () -``` - -We can also remove it from the flow completely and take ownership of it. -In that case, `with_open_in` will no longer close it on exit: - -```ocaml -# run @@ fun env -> - let fs = Eio.Stdenv.fs env in - let fd = Path.with_open_in (fs / Filename.null) (fun flow -> - Option.get (Eio_unix.Fd.remove (Option.get (Eio_unix.Resource.fd_opt flow))) - ) in - let got = Unix.read fd (Bytes.create 10) 0 10 in - traceln "Read %d bytes from null device" got; - Unix.close fd;; -+Read 0 bytes from null device -- : unit = () -``` - -# Use after close - -```ocaml -# run @@ fun env -> - let closed = Switch.run (fun sw -> Path.open_dir ~sw env#cwd) in - try - failwith (Path.read_dir closed |> String.concat ",") - with Invalid_argument _ -> traceln "Got Invalid_argument for closed FD";; -+Got Invalid_argument for closed FD -- : unit = () -``` - -# Rename - -```ocaml -let try_rename t = - try_mkdir (t / "tmp"); - try_rename (t / "tmp") (t / "dir"); - try_write_file (t / "foo") "FOO" ~create:(`Exclusive 0o600); - try_rename (t / "foo") (t / "dir/bar"); - try_read_file (t / "dir/bar"); - Path.with_open_dir (t / "dir") @@ fun dir -> - try_rename (dir / "bar") (t / "foo"); - try_read_file (t / "foo"); - Unix.chdir "dir"; - try_rename (t / "../foo") (t / "foo"); - Unix.chdir ".." -``` - -Confined: - -```ocaml -# run ~clear:["tmp"; "dir"; "foo"] @@ fun env -> try_rename env#cwd;; -+mkdir -> ok -+rename to -> ok -+write -> ok -+rename to -> ok -+read -> "FOO" -+rename to -> ok -+read -> "FOO" -+Eio.Io Fs Permission_denied _, renaming to -- : unit = () -``` - -Unconfined: - -```ocaml -# run @@ fun env -> try_rename env#fs;; -+mkdir -> ok -+rename to -> ok -+Eio.Io Fs Already_exists _, opening -+rename to -> ok -+read -> "FOO" -+rename to -> ok -+read -> "FOO" -+rename to -> ok -- : unit = () -``` - -# Stat - -```ocaml -# run ~clear:["stat_subdir"; "stat_reg"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - Switch.run @@ fun sw -> - try_mkdir (cwd / "stat_subdir"); - assert (Eio.Path.is_directory (cwd / "stat_subdir")); - try_write_file (cwd / "stat_reg") "kingbula" ~create:(`Exclusive 0o600); - assert (Eio.Path.is_file (cwd / "stat_reg")); -+mkdir -> ok -+write -> ok -- : unit = () -``` - -# Fstatat: - -```ocaml -# run ~clear:["stat_subdir2"; "symlink"; "broken-symlink"; "parent-symlink"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - Switch.run @@ fun sw -> - try_mkdir (cwd / "stat_subdir2"); - Path.symlink ~link_to:"stat_subdir2" (cwd / "symlink"); - Path.symlink ~link_to:"missing" (cwd / "broken-symlink"); - try_stat (cwd / "stat_subdir2"); - try_stat (cwd / "symlink"); - try_stat (cwd / "broken-symlink"); - try_stat cwd; - try_stat (cwd / ".."); - try_stat (cwd / "stat_subdir2/.."); - Path.symlink ~link_to:".." (cwd / "parent-symlink"); - try_stat (cwd / "parent-symlink"); - try_stat (cwd / "missing1" / "missing2"); -+mkdir -> ok -+ -> directory -+ -> symbolic link / directory -+ -> symbolic link / Fs Not_found _ -+ -> directory -+ -> Fs Permission_denied _ -+ -> directory -+ -> symbolic link / Fs Permission_denied _ -+ -> Fs Not_found _ -- : unit = () -``` - -# read_link - -```ocaml -# run ~clear:["file"; "symlink"] @@ fun env -> - let fs = Eio.Stdenv.fs env in - let cwd = Eio.Stdenv.cwd env in - Switch.run @@ fun sw -> - Path.symlink ~link_to:"file" (cwd / "symlink"); - try_read_link (cwd / "symlink"); - try_read_link (fs / "symlink"); - try_write_file (cwd / "file") "data" ~create:(`Exclusive 0o600); - try_read_link (cwd / "file"); - try_read_link (cwd / "../unknown"); -+read_link -> "file" -+read_link -> "file" -+write -> ok -+Eio.Io _, reading target of symlink -+Eio.Io Fs Permission_denied _, reading target of symlink -- : unit = () -``` - -# pread/pwrite - -Check reading and writing vectors at arbitrary offsets: - -```ocaml -# run ~clear:["test.txt"] @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - let path = cwd / "test.txt" in - Path.with_open_out path ~create:(`Exclusive 0o600) @@ fun file -> - Eio.Flow.copy_string "+-!" file; - Eio.File.pwrite_all file ~file_offset:(Int63.of_int 2) Cstruct.[of_string "abc"; of_string "123"]; - let buf1 = Cstruct.create 3 in - let buf2 = Cstruct.create 4 in - Eio.File.pread_exact file ~file_offset:(Int63.of_int 1) [buf1; buf2]; - traceln" %S/%S" (Cstruct.to_string buf1) (Cstruct.to_string buf2);; -+ "-ab"/"c123" -- : unit = () -``` - -Reading at the end of a file: - -```ocaml -# run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - let path = cwd / "test.txt" in - Path.with_open_out path ~create:(`Or_truncate 0o600) @@ fun file -> - Eio.Flow.copy_string "abc" file; - let buf = Cstruct.create 10 in - let got = Eio.File.pread file [buf] ~file_offset:(Int63.of_int 0) in - traceln "Read %S" (Cstruct.to_string buf ~len:got); - try - ignore (Eio.File.pread file [buf] ~file_offset:(Int63.of_int 3) : int); - assert false - with End_of_file -> - traceln "End-of-file";; -+Read "abc" -+End-of-file -- : unit = () -``` - -# Cancelling while readable - -Ensure reads can be cancelled promptly, even if there is no need to wait: - -```ocaml -# run @@ fun env -> - Eio.Path.with_open_out (env#fs / "/dev/zero") ~create:`Never @@ fun null -> - Fiber.both - (fun () -> - let buf = Cstruct.create 4 in - for _ = 1 to 10 do Eio.Flow.read_exact null buf done; - assert false) - (fun () -> failwith "Simulated error");; -Exception: Failure "Simulated error". -``` - -# Native paths - -```ocaml -# run ~clear:["native-sub"] @@ fun env -> - let cwd = Sys.getcwd () ^ "/" in - let test x = - let native = Eio.Path.native x in - let result = - native |> Option.map @@ fun native -> - if String.starts_with ~prefix:cwd native then - "./" ^ String.sub native (String.length cwd) (String.length native - String.length cwd) - else native - in - traceln "%a -> %a" Eio.Path.pp x Fmt.(Dump.option string) result - in - test env#fs; - test (env#fs / "/"); - test (env#fs / "/etc/hosts"); - test (env#fs / "."); - test (env#fs / "foo/bar"); - test env#cwd; - test (env#cwd / ".."); - let sub = env#cwd / "native-sub" in - Eio.Path.mkdir sub ~perm:0o700; - Eio.Path.with_open_dir sub @@ fun sub -> - test sub; - test (sub / "foo.txt"); - test (sub / "."); - test (sub / ".."); - test (sub / "/etc/passwd"); -+ -> Some . -+ -> Some / -+ -> Some /etc/hosts -+ -> Some . -+ -> Some ./foo/bar -+ -> Some . -+ -> Some ./.. -+ -> Some ./native-sub/ -+ -> Some ./native-sub/foo.txt -+ -> Some ./native-sub/. -+ -> Some ./native-sub/.. -+ -> Some /etc/passwd -- : unit = () -``` - -# Seek, truncate and sync - -```ocaml -# run @@ fun env -> - Eio.Path.with_open_out (env#cwd / "seek-test") ~create:(`If_missing 0o700) @@ fun file -> - Eio.File.truncate file (Int63.of_int 10); - assert ((Eio.File.stat file).size = (Int63.of_int 10)); - let pos = Eio.File.seek file (Int63.of_int 3) `Set in - traceln "seek from start: %a" Int63.pp pos; - let pos = Eio.File.seek file (Int63.of_int 2) `Cur in - traceln "relative seek: %a" Int63.pp pos; - let pos = Eio.File.seek file (Int63.of_int (-1)) `End in - traceln "seek from end: %a" Int63.pp pos; - Eio.File.sync file; (* (no way to check if this actually worked, but ensure it runs) *) -+seek from start: 3 -+relative seek: 5 -+seek from end: 9 -- : unit = () -``` - -# Extending paths - -```ocaml -# run @@ fun env -> - let base = fst env#cwd in - List.iter (fun (a, b) -> traceln "%S / %S = %S" a b (snd ((base, a) / b))) [ - "foo", "bar"; - "foo/", "bar"; - "foo", "/bar"; - "foo", ""; - "foo/", ""; - "", ""; - "", "bar"; - "/", ""; - ] -+"foo" / "bar" = "foo/bar" -+"foo/" / "bar" = "foo/bar" -+"foo" / "/bar" = "/bar" -+"foo" / "" = "foo/" -+"foo/" / "" = "foo/" -+"" / "" = "" -+"" / "bar" = "bar" -+"/" / "" = "/" -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +# ignore @@ Unix.umask 0o022;; +- : unit = () +``` + +```ocaml + +module Int63 = Optint.Int63 +module Path = Eio.Path + +let () = Eio.Exn.Backend.show := false + +open Eio.Std + +let ( / ) = Path.( / ) + +let run ?clear:(paths = []) fn = + Eio_main.run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + List.iter (fun p -> Eio.Path.rmtree ~missing_ok:true (cwd / p)) paths; + fn env + +let try_read_file path = + match Path.load path with + | s -> traceln "read %a -> %S" Path.pp path s + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let try_write_file ~create ?append path content = + match Path.save ~create ?append path content with + | () -> traceln "write %a -> ok" Path.pp path + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let try_mkdir path = + match Path.mkdir path ~perm:0o700 with + | () -> traceln "mkdir %a -> ok" Path.pp path + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let try_mkdirs ?exists_ok path = + match Path.mkdirs ?exists_ok path ~perm:0o700 with + | () -> traceln "mkdirs %a -> ok" Path.pp path + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let try_rename p1 p2 = + match Path.rename p1 p2 with + | () -> traceln "rename %a to %a -> ok" Path.pp p1 Path.pp p2 + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let try_read_dir path = + match Path.read_dir path with + | names -> traceln "read_dir %a -> %a" Path.pp path Fmt.Dump.(list string) names + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let try_read_link path = + match Path.read_link path with + | target -> traceln "read_link %a -> %S" Path.pp path target + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let try_unlink path = + match Path.unlink path with + | () -> traceln "unlink %a -> ok" Path.pp path + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let try_rmdir path = + match Path.rmdir path with + | () -> traceln "rmdir %a -> ok" Path.pp path + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let try_rmtree ?missing_ok path = + match Path.rmtree ?missing_ok path with + | () -> traceln "rmtree %a -> ok" Path.pp path + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex + +let chdir path = + traceln "chdir %S" path; + Unix.chdir path + +let try_stat path = + let stat ~follow = + match Eio.Path.stat ~follow path with + | info -> Fmt.str "@[%a@]" Eio.File.Stat.pp_kind info.kind + | exception Eio.Io (e, _) -> Fmt.str "@[%a@]" Eio.Exn.pp_err e + in + let a = stat ~follow:false in + let b = stat ~follow:true in + if a = b then + traceln "%a -> %s" Eio.Path.pp path a + else + traceln "%a -> %s / %s" Eio.Path.pp path a b + +let try_symlink ~link_to path = + match Path.symlink ~link_to path with + | s -> traceln "symlink %a -> %S" Path.pp path link_to + | exception ex -> traceln "@[%a@]" Eio.Exn.pp ex +``` + +# Basic test cases + +Creating a file and reading it back: + +```ocaml +# run ~clear:["test-file"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + Path.save ~create:(`Exclusive 0o666) (cwd / "test-file") "my-data"; + traceln "Got %S" @@ Path.load (cwd / "test-file");; ++Got "my-data" +- : unit = () +``` + +Check the file got the correct permissions (subject to the umask set above): + +```ocaml +# Printf.printf "Perm = %o\n" ((Unix.stat "test-file").st_perm);; +Perm = 644 +- : unit = () +``` + +# Sandboxing + +Trying to use cwd to access a file outside of that subtree fails: + +```ocaml +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + Path.save ~create:(`Exclusive 0o666) (cwd / "../test-file") "my-data"; + failwith "Should have failed";; +Exception: Eio.Io Fs Permission_denied _, + opening +``` + +Trying to use cwd to access an absolute path fails: + +```ocaml +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + Path.save ~create:(`Exclusive 0o666) (cwd / "/tmp/test-file") "my-data"; + failwith "Should have failed";; +Exception: Eio.Io Fs Permission_denied _, + opening +``` + +# Creation modes + +Exclusive create fails if already exists: + +```ocaml +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + Path.save ~create:(`Exclusive 0o666) (cwd / "test-file") "first-write"; + Path.save ~create:(`Exclusive 0o666) (cwd / "test-file") "first-write"; + failwith "Should have failed";; +Exception: Eio.Io Fs Already_exists _, + opening +``` + +If-missing create succeeds if already exists: + +```ocaml +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + let test_file = (cwd / "test-file") in + Path.save ~create:(`If_missing 0o666) test_file "1st-write-original"; + Path.save ~create:(`If_missing 0o666) test_file "2nd-write"; + traceln "Got %S" @@ Path.load test_file;; ++Got "2nd-write-original" +- : unit = () +``` + +Truncate create succeeds if already exists, and truncates: + +```ocaml +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + let test_file = (cwd / "test-file") in + Path.save ~create:(`Or_truncate 0o666) test_file "1st-write-original"; + Path.save ~create:(`Or_truncate 0o666) test_file "2nd-write"; + traceln "Got %S" @@ Path.load test_file;; ++Got "2nd-write" +- : unit = () +# Unix.unlink "test-file";; +- : unit = () +``` + +Error if no create and doesn't exist: + +```ocaml +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + let test_file = (cwd / "test-file") in + Path.save ~create:`Never test_file "1st-write-original"; + traceln "Got %S" @@ Path.load test_file;; +Exception: Eio.Io Fs Not_found _, + opening +``` + +Appending to an existing file: + +```ocaml +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + let test_file = (cwd / "test-file") in + Path.save ~create:(`Or_truncate 0o666) test_file "1st-write-original"; + Path.save ~create:`Never ~append:true test_file "2nd-write"; + traceln "Got %S" @@ Path.load test_file;; ++Got "1st-write-original2nd-write" +- : unit = () +# Unix.unlink "test-file";; +- : unit = () +``` + +# Mkdir + +```ocaml +# run ~clear:["subdir"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + try_mkdir (cwd / "subdir"); + try_mkdir (cwd / "subdir/nested"); + Path.save ~create:(`Exclusive 0o600) (cwd / "subdir/nested/test-file") "data"; + ();; ++mkdir -> ok ++mkdir -> ok +- : unit = () +# Unix.unlink "subdir/nested/test-file"; + Unix.rmdir "subdir/nested"; + Unix.rmdir "subdir";; +- : unit = () +``` + +Creating directories with nesting, symlinks, etc: + +```ocaml +# run ~clear:["to-subdir"; "to-root"; "dangle"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + Path.symlink ~link_to:"/" (cwd / "to-root"); + Path.symlink ~link_to:"subdir" (cwd / "to-subdir"); + Path.symlink ~link_to:"foo" (cwd / "dangle"); + try_mkdir (cwd / "subdir"); + try_mkdir (cwd / "to-subdir/nested"); + try_mkdir (cwd / "to-root/tmp/foo"); + try_mkdir (cwd / "../foo"); + try_mkdir (cwd / "to-subdir"); + try_mkdir (cwd / "dangle/foo"); + ();; ++mkdir -> ok ++mkdir -> ok ++Eio.Io Fs Permission_denied _, creating directory ++Eio.Io Fs Permission_denied _, creating directory ++Eio.Io Fs Already_exists _, creating directory ++Eio.Io Fs Not_found _, creating directory +- : unit = () +``` + +# Split + +```ocaml +let fake_dir : Eio.Fs.dir_ty r = Eio.Resource.T ((), Eio.Resource.handler []) +let split path = Eio.Path.split (fake_dir, path) |> Option.map (fun ((_, dirname), basename) -> dirname, basename) +``` + +```ocaml +# split "foo/bar"; +- : (string * string) option = Some ("foo", "bar") + +# split "/foo/bar"; +- : (string * string) option = Some ("/foo", "bar") + +# split "/foo/bar/baz"; +- : (string * string) option = Some ("/foo/bar", "baz") + +# split "/foo/bar//baz/"; +- : (string * string) option = Some ("/foo/bar", "baz") + +# split "bar"; +- : (string * string) option = Some ("", "bar") + +# split "/bar"; +- : (string * string) option = Some ("/", "bar") + +# split "."; +- : (string * string) option = Some ("", ".") + +# split "./"; +- : (string * string) option = Some ("", ".") + +# split ""; +- : (string * string) option = None + +# split "/"; +- : (string * string) option = None + +# split "///"; +- : (string * string) option = None +``` + +# Mkdirs + +Recursively creating directories with `mkdirs`. + +```ocaml +# run ~clear:["subdir1"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + let nested = cwd / "subdir1" / "subdir2" / "subdir3" in + try_mkdirs nested; + assert (Eio.Path.is_directory nested); + let one_more = Path.(nested / "subdir4") in + try_mkdirs one_more; + try_mkdirs ~exists_ok:true one_more; + try_mkdirs one_more; + assert (Eio.Path.is_directory one_more); + try_mkdirs (cwd / ".." / "outside"); ++mkdirs -> ok ++mkdirs -> ok ++mkdirs -> ok ++Eio.Io Fs Already_exists _, creating directory ++Eio.Io Fs Permission_denied _, examining , creating directory +- : unit = () +``` + +Some edge cases for `mkdirs`. + +```ocaml +# run ~clear:["test"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + try_mkdirs (cwd / "."); + try_mkdirs (cwd / "././"); + let lots_of_slashes = "./test//////////////test" in + try_mkdirs (cwd / lots_of_slashes); + assert (Eio.Path.is_directory (cwd / lots_of_slashes)); + try_mkdirs (cwd / "..");; ++Eio.Io Fs Already_exists _, creating directory ++Eio.Io Fs Already_exists _, creating directory ++mkdirs -> ok ++Eio.Io Fs Permission_denied _, creating directory +- : unit = () +``` + +# Unlink + +You can remove a file using unlink: + +```ocaml +# run ~clear:["file"; "subdir/file2"] @@ fun env -> + Switch.run @@ fun sw -> + let cwd = Eio.Stdenv.cwd env in + Path.save ~create:(`Exclusive 0o600) (cwd / "file") "data"; + Path.save ~create:(`Exclusive 0o600) (cwd / "subdir/file2") "data2"; + try_read_file (cwd / "file"); + try_read_file (cwd / "subdir/file2"); + assert (Eio.Path.kind ~follow:true (cwd / "file") = `Regular_file); + try_unlink (cwd / "file"); + assert (Eio.Path.kind ~follow:true (cwd / "file") = `Not_found); + try_unlink (cwd / "subdir/file2"); + try_read_file (cwd / "file"); + try_read_file (cwd / "subdir/file2"); + try_write_file ~create:(`Exclusive 0o600) (cwd / "subdir/file2") "data2"; + try_unlink (cwd / "to-subdir/file2"); + try_read_file (cwd / "subdir/file2");; ++read -> "data" ++read -> "data2" ++unlink -> ok ++unlink -> ok ++Eio.Io Fs Not_found _, opening ++Eio.Io Fs Not_found _, opening ++write -> ok ++unlink -> ok ++Eio.Io Fs Not_found _, opening +- : unit = () +``` + +Removing something that doesn't exist or is out of scope: + +```ocaml +# run @@ fun env -> + Switch.run @@ fun sw -> + let cwd = Eio.Stdenv.cwd env in + try_unlink (cwd / "missing"); + try_unlink (cwd / "../foo"); + try_unlink (cwd / "to-subdir/foo"); + try_unlink (cwd / "to-root/foo");; ++Eio.Io Fs Not_found _, removing file ++Eio.Io Fs Permission_denied _, removing file ++Eio.Io Fs Not_found _, removing file ++Eio.Io Fs Permission_denied _, removing file +- : unit = () +``` + +Reads and writes follow symlinks, but unlink operates on the symlink itself: + +```ocaml +# run ~clear:["link1"; "linkdir"; "linkroot"; "dir1"; "file2"] @@ fun env -> + Switch.run @@ fun sw -> + let cwd = Eio.Stdenv.cwd env in + let fs = Eio.Stdenv.fs env in + + try_mkdir (cwd / "dir1"); + let file1 = cwd / "dir1" / "file1" in + let file2 = cwd / "file2" in + try_write_file ~create:(`Exclusive 0o600) file1 "data1"; + try_write_file ~create:(`Exclusive 0o400) file2 "data2"; + Path.symlink ~link_to:"dir1/file1" (cwd / "link1"); + Path.symlink ~link_to:"../file2" (cwd / "dir1/link2"); + Path.symlink ~link_to:"dir1" (cwd / "linkdir"); + Path.symlink ~link_to:"/" (cwd / "linkroot"); + try_read_file file1; + try_read_file (cwd / "link1"); + try_read_file (cwd / "linkdir" / "file1"); + + try_stat file1; + try_stat (cwd / "link1"); + try_stat (cwd / "linkdir"); + try_stat (cwd / "linkroot"); + try_stat (fs / "linkroot"); + + Fun.protect ~finally:(fun () -> chdir "..") (fun () -> + chdir "dir1"; + try_read_file (cwd / "file1"); + (* Should remove link itself even though it's poiting outside of cwd *) + Path.unlink (cwd / "link2") + ); + try_read_file file2; + Path.unlink (cwd / "link1"); + Path.unlink (cwd / "linkdir"); + Path.unlink (cwd / "linkroot") ++mkdir -> ok ++write -> ok ++write -> ok ++read -> "data1" ++read -> "data1" ++read -> "data1" ++ -> regular file ++ -> symbolic link / regular file ++ -> symbolic link / directory ++ -> symbolic link / Fs Permission_denied _ ++ -> symbolic link / directory ++chdir "dir1" ++read -> "data1" ++chdir ".." ++read -> "data2" +- : unit = () +``` + +# Rmdir + +Similar to `unlink`, but works on directories: + +```ocaml +# run ~clear:["d1"; "subdir/d2"; "subdir/d3"] @@ fun env -> + Switch.run @@ fun sw -> + let cwd = Eio.Stdenv.cwd env in + try_mkdir (cwd / "d1"); + try_mkdir (cwd / "subdir/d2"); + try_read_dir (cwd / "d1"); + try_read_dir (cwd / "subdir/d2"); + try_rmdir (cwd / "d1"); + try_rmdir (cwd / "subdir/d2"); + try_read_dir (cwd / "d1"); + try_read_dir (cwd / "subdir/d2"); + try_mkdir (cwd / "subdir/d3"); + try_rmdir (cwd / "to-subdir/d3"); + try_read_dir (cwd / "subdir/d3");; ++mkdir -> ok ++mkdir -> ok ++read_dir -> [] ++read_dir -> [] ++rmdir -> ok ++rmdir -> ok ++Eio.Io Fs Not_found _, reading directory ++Eio.Io Fs Not_found _, reading directory ++mkdir -> ok ++rmdir -> ok ++Eio.Io Fs Not_found _, reading directory +- : unit = () +``` + +Removing something that doesn't exist or is out of scope: + +```ocaml +# run @@ fun env -> + Switch.run @@ fun sw -> + let cwd = Eio.Stdenv.cwd env in + try_rmdir (cwd / "missing"); + try_rmdir (cwd / "../foo"); + try_rmdir (cwd / "to-subdir/foo"); + try_rmdir (cwd / "to-root/foo");; ++Eio.Io Fs Not_found _, removing directory ++Eio.Io Fs Permission_denied _, removing directory ++Eio.Io Fs Not_found _, removing directory ++Eio.Io Fs Permission_denied _, removing directory +- : unit = () +``` + +# Recursive removal + +```ocaml +# run ~clear:["foo"] @@ fun env -> + Switch.run @@ fun sw -> + let cwd = Eio.Stdenv.cwd env in + let foo = cwd / "foo" in + try_mkdirs (foo / "bar"/ "baz"); + try_write_file ~create:(`Exclusive 0o600) (foo / "bar/file1") "data"; + try_rmtree foo; + assert (Path.kind ~follow:false foo = `Not_found); + traceln "A second rmtree is OK with missing_ok:"; + try_rmtree ~missing_ok:true foo; + traceln "But not without:"; + try_rmtree ~missing_ok:false foo; ++mkdirs -> ok ++write -> ok ++rmtree -> ok ++A second rmtree is OK with missing_ok: ++rmtree -> ok ++But not without: ++Eio.Io Fs Not_found _, removing file +- : unit = () +``` + +# Limiting to a subdirectory + +Create a sandbox, write a file with it, then read it from outside: + +```ocaml +# run ~clear:["sandbox"] @@ fun env -> + Switch.run @@ fun sw -> + let cwd = Eio.Stdenv.cwd env in + try_mkdir (cwd / "sandbox"); + let subdir = Path.open_dir ~sw (cwd / "sandbox") in + Path.save ~create:(`Exclusive 0o600) (subdir / "test-file") "data"; + try_mkdir (subdir / "../new-sandbox"); + traceln "Got %S" @@ Path.load (cwd / "sandbox/test-file");; ++mkdir -> ok ++Eio.Io Fs Permission_denied _, creating directory ++Got "data" +- : unit = () +``` + +```ocaml +# run ~clear:["foo"] @@ fun env -> + let fs = env#fs in + let cwd = env#cwd in + Path.mkdirs (cwd / "foo/bar") ~perm:0o700; + let test ?(succeeds=true) path = + Eio.Exn.Backend.show := succeeds; + try + Switch.run @@ fun sw -> + let _ : _ Path.t = Path.open_dir ~sw path in + traceln "open_dir %a -> OK" Path.pp path + with ex -> + traceln "@[%a@]" Eio.Exn.pp ex + in + let reject = test ~succeeds:false in + test (cwd / "foo/bar"); + reject (cwd / ".."); + test (cwd / "."); + reject (cwd / "/"); + test (cwd / "foo/bar/.."); + test (fs / "foo/bar"); + Path.symlink ~link_to:".." (cwd / "foo/up"); + test (cwd / "foo/up/foo/bar"); + reject (cwd / "foo/up/../bar"); + Path.symlink ~link_to:"/" (cwd / "foo/root"); + reject (cwd / "foo/root/.."); + reject (cwd / "missing"); ++open_dir -> OK ++Eio.Io Fs Permission_denied _, opening directory ++open_dir -> OK ++Eio.Io Fs Permission_denied _, opening directory ++open_dir -> OK ++open_dir -> OK ++open_dir -> OK ++Eio.Io Fs Permission_denied _, opening directory ++Eio.Io Fs Permission_denied _, opening directory ++Eio.Io Fs Not_found _, opening directory +- : unit = () + +# Eio.Exn.Backend.show := false +- : unit = () +``` + +# Unconfined FS access + +We create a directory and chdir into it. +Using `cwd` we can't access the parent, but using `fs` we can: + +```ocaml +# run ~clear:["fs-test"; "outside-cwd"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + let fs = Eio.Stdenv.fs env in + try_mkdir (cwd / "fs-test"); + chdir "fs-test"; + Fun.protect ~finally:(fun () -> chdir "..") (fun () -> + try_mkdir (cwd / "../outside-cwd"); + try_write_file ~create:(`Exclusive 0o600) (cwd / "../test-file") "data"; + try_mkdir (fs / "../outside-cwd"); + try_write_file ~create:(`Exclusive 0o600) (fs / "../test-file") "data"; + ); + Unix.unlink "test-file"; + Unix.rmdir "outside-cwd";; ++mkdir -> ok ++chdir "fs-test" ++Eio.Io Fs Permission_denied _, creating directory ++Eio.Io Fs Permission_denied _, opening ++mkdir -> ok ++write -> ok ++chdir ".." +- : unit = () +``` + +Reading directory entries under `cwd` and outside of `cwd`. + +```ocaml +# run ~clear:["readdir"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + try_mkdir (cwd / "readdir"); + Path.with_open_dir (cwd / "readdir") @@ fun tmpdir -> + try_mkdir (tmpdir / "test-1"); + try_mkdir (tmpdir / "test-2"); + try_write_file ~create:(`Exclusive 0o600) (tmpdir / "test-1/file") "data"; + try_read_dir tmpdir; + try_read_dir (tmpdir / "."); + try_read_dir (tmpdir / ".."); + try_read_dir (tmpdir / "test-3"); + Path.symlink ~link_to:"test-1" (cwd / "readdir/link-1"); + try_read_dir (tmpdir / "link-1"); ++mkdir -> ok ++mkdir -> ok ++mkdir -> ok ++write -> ok ++read_dir -> ["test-1"; "test-2"] ++read_dir -> ["test-1"; "test-2"] ++Eio.Io Fs Permission_denied _, reading directory ++Eio.Io Fs Not_found _, reading directory ++read_dir -> ["file"] +- : unit = () +``` + +An error from the underlying directory, not the sandbox: + +```ocaml +# run ~clear:["test-no-access"] @@ fun env -> + Unix.mkdir "test-no-access" 0;; +- : unit = () +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + try_read_dir (cwd / "test-no-access");; ++Eio.Io Fs Permission_denied _, reading directory +- : unit = () +# Unix.chmod "test-no-access" 0o700;; +- : unit = () +``` + +Can use `fs` to access absolute paths: + +```ocaml +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + let fs = Eio.Stdenv.fs env in + let b = Buffer.create 10 in + Path.with_open_in (fs / Filename.null) (fun flow -> Eio.Flow.copy flow (Eio.Flow.buffer_sink b)); + traceln "Read %S and got %S" Filename.null (Buffer.contents b); + traceln "Trying with cwd instead fails:"; + Path.with_open_in (cwd / Filename.null) (fun flow -> Eio.Flow.copy flow (Eio.Flow.buffer_sink b));;; ++Read "/dev/null" and got "" ++Trying with cwd instead fails: +Exception: Eio.Io Fs Permission_denied _, + opening +``` + +Symlinking and sandboxing: + +```ocaml +# run ~clear:["hello.txt"; "world.txt"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + Path.save ~create:(`Exclusive 0o600) (cwd / "hello.txt") "Hello World!"; + try_symlink ~link_to:"hello.txt" (cwd / "../world.txt"); + try_symlink ~link_to:"hello.txt" (cwd / "/world.txt"); + try_symlink ~link_to:"hello.txt" (cwd / "world.txt"); + traceln "world.txt -> hello.txt: %s" (Path.load (cwd / "world.txt")); + try_symlink ~link_to:"hello.txt" (cwd / "world.txt"); + try_symlink ~link_to:"/" (cwd / "root"); + try_read_dir (cwd / "root");; ++Eio.Io Fs Permission_denied _, creating symlink -> hello.txt ++Eio.Io Fs Permission_denied _, creating symlink -> hello.txt ++symlink -> "hello.txt" ++world.txt -> hello.txt: Hello World! ++Eio.Io Fs Already_exists _, creating symlink -> hello.txt ++symlink -> "/" ++Eio.Io Fs Permission_denied _, reading directory +- : unit = () +``` + +## Streamling lines + +```ocaml +# run ~clear:["test-data"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + Path.save ~create:(`Exclusive 0o600) (cwd / "test-data") "one\ntwo\nthree"; + Path.with_lines (cwd / "test-data") (fun lines -> + Seq.iter (traceln "Line: %s") lines + );; ++Line: one ++Line: two ++Line: three +- : unit = () +``` + +# Unix interop + +We can get the Unix FD from the flow and use it directly: + +```ocaml +# run @@ fun env -> + let fs = Eio.Stdenv.fs env in + Path.with_open_in (fs / Filename.null) (fun flow -> + match Eio_unix.Resource.fd_opt flow with + | None -> failwith "No Unix file descriptor!" + | Some fd -> + Eio_unix.Fd.use_exn "read" fd @@ fun fd -> + let got = Unix.read fd (Bytes.create 10) 0 10 in + traceln "Read %d bytes from null device" got + );; ++Read 0 bytes from null device +- : unit = () +``` + +We can also remove it from the flow completely and take ownership of it. +In that case, `with_open_in` will no longer close it on exit: + +```ocaml +# run @@ fun env -> + let fs = Eio.Stdenv.fs env in + let fd = Path.with_open_in (fs / Filename.null) (fun flow -> + Option.get (Eio_unix.Fd.remove (Option.get (Eio_unix.Resource.fd_opt flow))) + ) in + let got = Unix.read fd (Bytes.create 10) 0 10 in + traceln "Read %d bytes from null device" got; + Unix.close fd;; ++Read 0 bytes from null device +- : unit = () +``` + +# Use after close + +```ocaml +# run @@ fun env -> + let closed = Switch.run (fun sw -> Path.open_dir ~sw env#cwd) in + try + failwith (Path.read_dir closed |> String.concat ",") + with Invalid_argument _ -> traceln "Got Invalid_argument for closed FD";; ++Got Invalid_argument for closed FD +- : unit = () +``` + +# Rename + +```ocaml +let try_rename t = + try_mkdir (t / "tmp"); + try_rename (t / "tmp") (t / "dir"); + try_write_file (t / "foo") "FOO" ~create:(`Exclusive 0o600); + try_rename (t / "foo") (t / "dir/bar"); + try_read_file (t / "dir/bar"); + Path.with_open_dir (t / "dir") @@ fun dir -> + try_rename (dir / "bar") (t / "foo"); + try_read_file (t / "foo"); + Unix.chdir "dir"; + try_rename (t / "../foo") (t / "foo"); + Unix.chdir ".." +``` + +Confined: + +```ocaml +# run ~clear:["tmp"; "dir"; "foo"] @@ fun env -> try_rename env#cwd;; ++mkdir -> ok ++rename to -> ok ++write -> ok ++rename to -> ok ++read -> "FOO" ++rename to -> ok ++read -> "FOO" ++Eio.Io Fs Permission_denied _, renaming to +- : unit = () +``` + +Unconfined: + +```ocaml +# run @@ fun env -> try_rename env#fs;; ++mkdir -> ok ++rename to -> ok ++Eio.Io Fs Already_exists _, opening ++rename to -> ok ++read -> "FOO" ++rename to -> ok ++read -> "FOO" ++rename to -> ok +- : unit = () +``` + +# Stat + +```ocaml +# run ~clear:["stat_subdir"; "stat_reg"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + Switch.run @@ fun sw -> + try_mkdir (cwd / "stat_subdir"); + assert (Eio.Path.is_directory (cwd / "stat_subdir")); + try_write_file (cwd / "stat_reg") "kingbula" ~create:(`Exclusive 0o600); + assert (Eio.Path.is_file (cwd / "stat_reg")); ++mkdir -> ok ++write -> ok +- : unit = () +``` + +# Fstatat: + +```ocaml +# run ~clear:["stat_subdir2"; "symlink"; "broken-symlink"; "parent-symlink"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + Switch.run @@ fun sw -> + try_mkdir (cwd / "stat_subdir2"); + Path.symlink ~link_to:"stat_subdir2" (cwd / "symlink"); + Path.symlink ~link_to:"missing" (cwd / "broken-symlink"); + try_stat (cwd / "stat_subdir2"); + try_stat (cwd / "symlink"); + try_stat (cwd / "broken-symlink"); + try_stat cwd; + try_stat (cwd / ".."); + try_stat (cwd / "stat_subdir2/.."); + Path.symlink ~link_to:".." (cwd / "parent-symlink"); + try_stat (cwd / "parent-symlink"); + try_stat (cwd / "missing1" / "missing2"); ++mkdir -> ok ++ -> directory ++ -> symbolic link / directory ++ -> symbolic link / Fs Not_found _ ++ -> directory ++ -> Fs Permission_denied _ ++ -> directory ++ -> symbolic link / Fs Permission_denied _ ++ -> Fs Not_found _ +- : unit = () +``` + +# read_link + +```ocaml +# run ~clear:["file"; "symlink"] @@ fun env -> + let fs = Eio.Stdenv.fs env in + let cwd = Eio.Stdenv.cwd env in + Switch.run @@ fun sw -> + Path.symlink ~link_to:"file" (cwd / "symlink"); + try_read_link (cwd / "symlink"); + try_read_link (fs / "symlink"); + try_write_file (cwd / "file") "data" ~create:(`Exclusive 0o600); + try_read_link (cwd / "file"); + try_read_link (cwd / "../unknown"); ++read_link -> "file" ++read_link -> "file" ++write -> ok ++Eio.Io _, reading target of symlink ++Eio.Io Fs Permission_denied _, reading target of symlink +- : unit = () +``` + +# pread/pwrite + +Check reading and writing vectors at arbitrary offsets: + +```ocaml +# run ~clear:["test.txt"] @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + let path = cwd / "test.txt" in + Path.with_open_out path ~create:(`Exclusive 0o600) @@ fun file -> + Eio.Flow.copy_string "+-!" file; + Eio.File.pwrite_all file ~file_offset:(Int63.of_int 2) Cstruct.[of_string "abc"; of_string "123"]; + let buf1 = Cstruct.create 3 in + let buf2 = Cstruct.create 4 in + Eio.File.pread_exact file ~file_offset:(Int63.of_int 1) [buf1; buf2]; + traceln" %S/%S" (Cstruct.to_string buf1) (Cstruct.to_string buf2);; ++ "-ab"/"c123" +- : unit = () +``` + +Reading at the end of a file: + +```ocaml +# run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + let path = cwd / "test.txt" in + Path.with_open_out path ~create:(`Or_truncate 0o600) @@ fun file -> + Eio.Flow.copy_string "abc" file; + let buf = Cstruct.create 10 in + let got = Eio.File.pread file [buf] ~file_offset:(Int63.of_int 0) in + traceln "Read %S" (Cstruct.to_string buf ~len:got); + try + ignore (Eio.File.pread file [buf] ~file_offset:(Int63.of_int 3) : int); + assert false + with End_of_file -> + traceln "End-of-file";; ++Read "abc" ++End-of-file +- : unit = () +``` + +# Cancelling while readable + +Ensure reads can be cancelled promptly, even if there is no need to wait: + +```ocaml +# run @@ fun env -> + Eio.Path.with_open_out (env#fs / "/dev/zero") ~create:`Never @@ fun null -> + Fiber.both + (fun () -> + let buf = Cstruct.create 4 in + for _ = 1 to 10 do Eio.Flow.read_exact null buf done; + assert false) + (fun () -> failwith "Simulated error");; +Exception: Failure "Simulated error". +``` + +# Native paths + +```ocaml +# run ~clear:["native-sub"] @@ fun env -> + let cwd = Sys.getcwd () ^ "/" in + let test x = + let native = Eio.Path.native x in + let result = + native |> Option.map @@ fun native -> + if String.starts_with ~prefix:cwd native then + "./" ^ String.sub native (String.length cwd) (String.length native - String.length cwd) + else native + in + traceln "%a -> %a" Eio.Path.pp x Fmt.(Dump.option string) result + in + test env#fs; + test (env#fs / "/"); + test (env#fs / "/etc/hosts"); + test (env#fs / "."); + test (env#fs / "foo/bar"); + test env#cwd; + test (env#cwd / ".."); + let sub = env#cwd / "native-sub" in + Eio.Path.mkdir sub ~perm:0o700; + Eio.Path.with_open_dir sub @@ fun sub -> + test sub; + test (sub / "foo.txt"); + test (sub / "."); + test (sub / ".."); + test (sub / "/etc/passwd"); ++ -> Some . ++ -> Some / ++ -> Some /etc/hosts ++ -> Some . ++ -> Some ./foo/bar ++ -> Some . ++ -> Some ./.. ++ -> Some ./native-sub/ ++ -> Some ./native-sub/foo.txt ++ -> Some ./native-sub/. ++ -> Some ./native-sub/.. ++ -> Some /etc/passwd +- : unit = () +``` + +# Seek, truncate and sync + +```ocaml +# run @@ fun env -> + Eio.Path.with_open_out (env#cwd / "seek-test") ~create:(`If_missing 0o700) @@ fun file -> + Eio.File.truncate file (Int63.of_int 10); + assert ((Eio.File.stat file).size = (Int63.of_int 10)); + let pos = Eio.File.seek file (Int63.of_int 3) `Set in + traceln "seek from start: %a" Int63.pp pos; + let pos = Eio.File.seek file (Int63.of_int 2) `Cur in + traceln "relative seek: %a" Int63.pp pos; + let pos = Eio.File.seek file (Int63.of_int (-1)) `End in + traceln "seek from end: %a" Int63.pp pos; + Eio.File.sync file; (* (no way to check if this actually worked, but ensure it runs) *) ++seek from start: 3 ++relative seek: 5 ++seek from end: 9 +- : unit = () +``` + +# Extending paths + +```ocaml +# run @@ fun env -> + let base = fst env#cwd in + List.iter (fun (a, b) -> traceln "%S / %S = %S" a b (snd ((base, a) / b))) [ + "foo", "bar"; + "foo/", "bar"; + "foo", "/bar"; + "foo", ""; + "foo/", ""; + "", ""; + "", "bar"; + "/", ""; + ] ++"foo" / "bar" = "foo/bar" ++"foo/" / "bar" = "foo/bar" ++"foo" / "/bar" = "/bar" ++"foo" / "" = "foo/" ++"foo/" / "" = "foo/" ++"" / "" = "" ++"" / "bar" = "bar" ++"/" / "" = "/" +- : unit = () +``` diff --git a/tests/lazy.md b/tests/lazy.md index 93f23ea65..30b52037f 100644 --- a/tests/lazy.md +++ b/tests/lazy.md @@ -1,131 +1,131 @@ -# Setting up the environment - -```ocaml -# #require "eio.mock";; -``` -```ocaml -open Eio.Std - -let test label v = - traceln "%s: forcing..." label; - match Eio.Lazy.force v with - | v -> - Fiber.check (); - traceln "%s: %d" label v - | exception ex -> - traceln "%s: %a" label Fmt.exn ex; - Fiber.check () -``` - -# Tests - -Two fibers request the value. It's only computed once: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let v = Eio.Lazy.from_fun ~cancel:`Restart (fun () -> - traceln "calculating..."; - Fiber.yield (); - traceln "complete"; - 42 - ) in - Fiber.both - (fun () -> test "a" v) - (fun () -> test "b" v) - ;; -+a: forcing... -+calculating... -+b: forcing... -+complete -+a: 42 -+b: 42 -- : unit = () -``` - -The calculation fails. It's still only performed once: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let v = Eio.Lazy.from_fun ~cancel:`Restart (fun () -> - traceln "calculating..."; - Fiber.yield (); - failwith "failed"; - ) in - Fiber.both - (fun () -> test "a" v) - (fun () -> test "b" v) - ;; -+a: forcing... -+calculating... -+b: forcing... -+a: Failure("failed") -+b: Failure("failed") -- : unit = () -``` - -## Cancellation - -The first fiber cancels. What happens depends on the cancel mode: - -```ocaml -let test_cancel cancel = - Eio_mock.Backend.run @@ fun () -> - let v = Eio.Lazy.from_fun ~cancel (fun () -> - traceln "calculating..."; - Fiber.yield (); - traceln "complete"; - 42 - ) in - Fiber.both - (fun () -> - let x = - Fiber.first - (fun () -> test "a" v; assert false) - (fun () -> 5) - in - traceln "a: %d" x - ) - (fun () -> test "b" v) - ;; -``` - -In record mode, the second fiber sees the cancelled exception: - -```ocaml -# test_cancel `Record;; -+a: forcing... -+calculating... -+b: forcing... -+a: Cancelled: Eio__core__Fiber.Not_first -+b: Cancelled: Eio__core__Fiber.Not_first -+a: 5 -- : unit = () -``` - -In protect mode, the first calculation succeeds: - -```ocaml -# test_cancel `Protect;; -+a: forcing... -+calculating... -+b: forcing... -+complete -+b: 42 -+a: 5 -- : unit = () -``` - -In restart mode, the second fiber restarts the calculation: - -```ocaml -# test_cancel `Restart;; -+a: forcing... -+calculating... -+b: forcing... -+a: Cancelled: Eio__core__Fiber.Not_first -+calculating... -+a: 5 -+complete -+b: 42 -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio.mock";; +``` +```ocaml +open Eio.Std + +let test label v = + traceln "%s: forcing..." label; + match Eio.Lazy.force v with + | v -> + Fiber.check (); + traceln "%s: %d" label v + | exception ex -> + traceln "%s: %a" label Fmt.exn ex; + Fiber.check () +``` + +# Tests + +Two fibers request the value. It's only computed once: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let v = Eio.Lazy.from_fun ~cancel:`Restart (fun () -> + traceln "calculating..."; + Fiber.yield (); + traceln "complete"; + 42 + ) in + Fiber.both + (fun () -> test "a" v) + (fun () -> test "b" v) + ;; ++a: forcing... ++calculating... ++b: forcing... ++complete ++a: 42 ++b: 42 +- : unit = () +``` + +The calculation fails. It's still only performed once: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let v = Eio.Lazy.from_fun ~cancel:`Restart (fun () -> + traceln "calculating..."; + Fiber.yield (); + failwith "failed"; + ) in + Fiber.both + (fun () -> test "a" v) + (fun () -> test "b" v) + ;; ++a: forcing... ++calculating... ++b: forcing... ++a: Failure("failed") ++b: Failure("failed") +- : unit = () +``` + +## Cancellation + +The first fiber cancels. What happens depends on the cancel mode: + +```ocaml +let test_cancel cancel = + Eio_mock.Backend.run @@ fun () -> + let v = Eio.Lazy.from_fun ~cancel (fun () -> + traceln "calculating..."; + Fiber.yield (); + traceln "complete"; + 42 + ) in + Fiber.both + (fun () -> + let x = + Fiber.first + (fun () -> test "a" v; assert false) + (fun () -> 5) + in + traceln "a: %d" x + ) + (fun () -> test "b" v) + ;; +``` + +In record mode, the second fiber sees the cancelled exception: + +```ocaml +# test_cancel `Record;; ++a: forcing... ++calculating... ++b: forcing... ++a: Cancelled: Eio__core__Fiber.Not_first ++b: Cancelled: Eio__core__Fiber.Not_first ++a: 5 +- : unit = () +``` + +In protect mode, the first calculation succeeds: + +```ocaml +# test_cancel `Protect;; ++a: forcing... ++calculating... ++b: forcing... ++complete ++b: 42 ++a: 5 +- : unit = () +``` + +In restart mode, the second fiber restarts the calculation: + +```ocaml +# test_cancel `Restart;; ++a: forcing... ++calculating... ++b: forcing... ++a: Cancelled: Eio__core__Fiber.Not_first ++calculating... ++a: 5 ++complete ++b: 42 +- : unit = () +``` diff --git a/tests/lf_queue.md b/tests/lf_queue.md index 9ef280b93..acc5d24f3 100644 --- a/tests/lf_queue.md +++ b/tests/lf_queue.md @@ -1,100 +1,100 @@ -# A lock-free queue for schedulers - -```ocaml -# #require "eio.utils";; -``` - -```ocaml -module Q = Eio_utils.Lf_queue;; -``` - -## A basic run - -```ocaml -# let q : int Q.t = Q.create ();; -val q : int Q.t = -# Q.push q 1;; -- : unit = () -# Q.push q 2;; -- : unit = () -# Q.pop q;; -- : int option = Some 1 -# Q.pop q;; -- : int option = Some 2 -# Q.pop q;; -- : int option = None -# Q.pop q;; -- : int option = None -# Q.push q 3;; -- : unit = () -# Q.pop q;; -- : int option = Some 3 -``` - -## Closing the queue - -```ocaml -# let q : int Q.t = Q.create ();; -val q : int Q.t = -# Q.push q 1;; -- : unit = () -# Q.close q;; -- : unit = () -# Q.push q 2;; -Exception: Eio_utils__Lf_queue.Closed. -# Q.push_head q 3;; -- : unit = () -# Q.pop q;; -- : int option = Some 3 -# Q.pop q;; -- : int option = Some 1 -# Q.pop q;; -Exception: Eio_utils__Lf_queue.Closed. -# Q.push_head q 4;; -Exception: Eio_utils__Lf_queue.Closed. -``` - -## Closing an empty queue - -```ocaml -# let q = Q.create () in Q.close q; Q.push q 1;; -Exception: Eio_utils__Lf_queue.Closed. -``` - -## Empty? - -```ocaml -# let q : int Q.t = Q.create ();; -val q : int Q.t = -# Q.is_empty q;; -- : bool = true -# Q.push q 1; Q.is_empty q;; -- : bool = false -# Q.pop q;; -- : int option = Some 1 -# Q.is_empty q;; -- : bool = true -# Q.close q; Q.is_empty q;; -Exception: Eio_utils__Lf_queue.Closed. -``` - -## Pushing to the head - -```ocaml -# let q : int Q.t = Q.create ();; -val q : int Q.t = -# Q.push_head q 3; Q.push q 4; Q.push_head q 2; Q.push q 5; Q.push_head q 1;; -- : unit = () -# Q.pop q;; -- : int option = Some 1 -# Q.pop q;; -- : int option = Some 2 -# Q.pop q;; -- : int option = Some 3 -# Q.pop q;; -- : int option = Some 4 -# Q.pop q;; -- : int option = Some 5 -# Q.pop q;; -- : int option = None -``` +# A lock-free queue for schedulers + +```ocaml +# #require "eio.utils";; +``` + +```ocaml +module Q = Eio_utils.Lf_queue;; +``` + +## A basic run + +```ocaml +# let q : int Q.t = Q.create ();; +val q : int Q.t = +# Q.push q 1;; +- : unit = () +# Q.push q 2;; +- : unit = () +# Q.pop q;; +- : int option = Some 1 +# Q.pop q;; +- : int option = Some 2 +# Q.pop q;; +- : int option = None +# Q.pop q;; +- : int option = None +# Q.push q 3;; +- : unit = () +# Q.pop q;; +- : int option = Some 3 +``` + +## Closing the queue + +```ocaml +# let q : int Q.t = Q.create ();; +val q : int Q.t = +# Q.push q 1;; +- : unit = () +# Q.close q;; +- : unit = () +# Q.push q 2;; +Exception: Eio_utils__Lf_queue.Closed. +# Q.push_head q 3;; +- : unit = () +# Q.pop q;; +- : int option = Some 3 +# Q.pop q;; +- : int option = Some 1 +# Q.pop q;; +Exception: Eio_utils__Lf_queue.Closed. +# Q.push_head q 4;; +Exception: Eio_utils__Lf_queue.Closed. +``` + +## Closing an empty queue + +```ocaml +# let q = Q.create () in Q.close q; Q.push q 1;; +Exception: Eio_utils__Lf_queue.Closed. +``` + +## Empty? + +```ocaml +# let q : int Q.t = Q.create ();; +val q : int Q.t = +# Q.is_empty q;; +- : bool = true +# Q.push q 1; Q.is_empty q;; +- : bool = false +# Q.pop q;; +- : int option = Some 1 +# Q.is_empty q;; +- : bool = true +# Q.close q; Q.is_empty q;; +Exception: Eio_utils__Lf_queue.Closed. +``` + +## Pushing to the head + +```ocaml +# let q : int Q.t = Q.create ();; +val q : int Q.t = +# Q.push_head q 3; Q.push q 4; Q.push_head q 2; Q.push q 5; Q.push_head q 1;; +- : unit = () +# Q.pop q;; +- : int option = Some 1 +# Q.pop q;; +- : int option = Some 2 +# Q.pop q;; +- : int option = Some 3 +# Q.pop q;; +- : int option = Some 4 +# Q.pop q;; +- : int option = Some 5 +# Q.pop q;; +- : int option = None +``` diff --git a/tests/mocks.md b/tests/mocks.md index 4b0a7ffcd..b899e72f4 100644 --- a/tests/mocks.md +++ b/tests/mocks.md @@ -1,109 +1,109 @@ -## Setup - -```ocaml -# #require "eio.mock";; -``` - -```ocaml -open Eio.Std -let stdin = Eio_mock.Flow.make "stdin" -let stdout = Eio_mock.Flow.make "stdout" -``` - -## Flows - -```ocaml -# Eio_mock.Backend.run @@ fun _ -> - Eio_mock.Flow.on_read stdin [ - `Return "chunk1"; - `Return "chunk2"; - `Raise End_of_file - ]; - Eio.Flow.copy stdin stdout; - Eio.Flow.close stdin; - Eio.Flow.shutdown stdout `Send;; -+stdin: read "chunk1" -+stdout: wrote "chunk1" -+stdin: read "chunk2" -+stdout: wrote "chunk2" -+stdin: closed -+stdout: shutdown send -- : unit = () -``` - -## Networks - -A simple test server: - -```ocaml -let echo_server ~net addr = - Switch.run @@ fun sw -> - let socket = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in - Eio.Net.accept_fork socket ~sw (fun flow _addr -> Eio.Flow.copy flow flow) - ~on_error:(traceln "Error handling connection: %a" Fmt.exn);; -``` - -The server handles a connection: - -```ocaml -# Eio_mock.Backend.run @@ fun _ -> - let net = Eio_mock.Net.make "mocknet" in - let listening_socket = Eio_mock.Net.listening_socket "tcp/80" in - Eio_mock.Net.on_listen net [`Return listening_socket]; - let connection = Eio_mock.Flow.make "connection" in - let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 37568) in - Eio_mock.Net.on_accept listening_socket [`Return (connection, addr)]; - Eio_mock.Flow.on_read connection [`Return "foo"; `Return "bar"]; - echo_server ~net (`Tcp (Eio.Net.Ipaddr.V4.loopback, 80));; -+mocknet: listen on tcp:127.0.0.1:80 -+tcp/80: accepted connection from tcp:127.0.0.1:37568 -+connection: read "foo" -+connection: wrote "foo" -+connection: read "bar" -+connection: wrote "bar" -+connection: closed -+tcp/80: closed -- : unit = () -``` - -## Backend - -`Eio_mock.Backend` supports forking, tracing, suspending and cancellation: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let s = Eio.Stream.create 1 in - try - Fiber.both - (fun () -> - for x = 1 to 3 do - traceln "Sending %d" x; - Eio.Stream.add s x - done; - raise Exit - ) - (fun () -> - while true do - traceln "Got %d" (Eio.Stream.take s) - done - ) - with Exit -> - traceln "Finished!";; -+Sending 1 -+Sending 2 -+Got 1 -+Got 2 -+Sending 3 -+Got 3 -+Finished! -- : unit = () -``` - -Because it doesn't support multiple threads or domains, it can detect deadlocks: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let p, _r = Promise.create () in - Promise.await p;; -Exception: Eio_mock__Backend.Deadlock_detected. -``` +## Setup + +```ocaml +# #require "eio.mock";; +``` + +```ocaml +open Eio.Std +let stdin = Eio_mock.Flow.make "stdin" +let stdout = Eio_mock.Flow.make "stdout" +``` + +## Flows + +```ocaml +# Eio_mock.Backend.run @@ fun _ -> + Eio_mock.Flow.on_read stdin [ + `Return "chunk1"; + `Return "chunk2"; + `Raise End_of_file + ]; + Eio.Flow.copy stdin stdout; + Eio.Flow.close stdin; + Eio.Flow.shutdown stdout `Send;; ++stdin: read "chunk1" ++stdout: wrote "chunk1" ++stdin: read "chunk2" ++stdout: wrote "chunk2" ++stdin: closed ++stdout: shutdown send +- : unit = () +``` + +## Networks + +A simple test server: + +```ocaml +let echo_server ~net addr = + Switch.run @@ fun sw -> + let socket = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in + Eio.Net.accept_fork socket ~sw (fun flow _addr -> Eio.Flow.copy flow flow) + ~on_error:(traceln "Error handling connection: %a" Fmt.exn);; +``` + +The server handles a connection: + +```ocaml +# Eio_mock.Backend.run @@ fun _ -> + let net = Eio_mock.Net.make "mocknet" in + let listening_socket = Eio_mock.Net.listening_socket "tcp/80" in + Eio_mock.Net.on_listen net [`Return listening_socket]; + let connection = Eio_mock.Flow.make "connection" in + let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 37568) in + Eio_mock.Net.on_accept listening_socket [`Return (connection, addr)]; + Eio_mock.Flow.on_read connection [`Return "foo"; `Return "bar"]; + echo_server ~net (`Tcp (Eio.Net.Ipaddr.V4.loopback, 80));; ++mocknet: listen on tcp:127.0.0.1:80 ++tcp/80: accepted connection from tcp:127.0.0.1:37568 ++connection: read "foo" ++connection: wrote "foo" ++connection: read "bar" ++connection: wrote "bar" ++connection: closed ++tcp/80: closed +- : unit = () +``` + +## Backend + +`Eio_mock.Backend` supports forking, tracing, suspending and cancellation: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let s = Eio.Stream.create 1 in + try + Fiber.both + (fun () -> + for x = 1 to 3 do + traceln "Sending %d" x; + Eio.Stream.add s x + done; + raise Exit + ) + (fun () -> + while true do + traceln "Got %d" (Eio.Stream.take s) + done + ) + with Exit -> + traceln "Finished!";; ++Sending 1 ++Sending 2 ++Got 1 ++Got 2 ++Sending 3 ++Got 3 ++Finished! +- : unit = () +``` + +Because it doesn't support multiple threads or domains, it can detect deadlocks: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let p, _r = Promise.create () in + Promise.await p;; +Exception: Eio_mock__Backend.Deadlock_detected. +``` diff --git a/tests/mutex.md b/tests/mutex.md index 47021db5e..0618fe449 100644 --- a/tests/mutex.md +++ b/tests/mutex.md @@ -1,256 +1,256 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -``` - -```ocaml -open Eio.Std - -module M = Eio.Mutex - -let run fn = - Eio_main.run @@ fun _ -> - fn () - -let lock t = - traceln "Locking"; - M.lock t; - traceln "Locked" - -let unlock t = - traceln "Unlocking"; - M.unlock t; - traceln "Unlocked" -``` - -# Test cases - -Simple case - -```ocaml -# run @@ fun () -> - let t = M.create () in - lock t; - unlock t; - lock t; - unlock t;; -+Locking -+Locked -+Unlocking -+Unlocked -+Locking -+Locked -+Unlocking -+Unlocked -- : unit = () -``` - -Concurrent access to the mutex - - -```ocaml -# run @@ fun () -> - let t = M.create () in - let fn () = - lock t; - Eio.Fiber.yield (); - unlock t - in - List.init 4 (fun _ -> fn) - |> Fiber.all;; -+Locking -+Locked -+Locking -+Locking -+Locking -+Unlocking -+Unlocked -+Locked -+Unlocking -+Unlocked -+Locked -+Unlocking -+Unlocked -+Locked -+Unlocking -+Unlocked -- : unit = () -``` - -Double unlock raises an exception - -```ocaml -# run @@ fun () -> - let t = M.create () in - M.lock t; - M.unlock t; - begin - try M.unlock t - with Sys_error msg -> traceln "Caught: %s" msg - end; - traceln "Trying to use lock after error..."; - M.lock t;; -+Caught: Eio.Mutex.unlock: already unlocked! -+Trying to use lock after error... -Exception: -Eio__Eio_mutex.Poisoned (Sys_error "Eio.Mutex.unlock: already unlocked!"). -``` - -## Read-write access - -Successful use; only one critical section is active at once: - -```ocaml -# run @@ fun () -> - let t = M.create () in - let fn () = - traceln "Entered critical section"; - Fiber.yield (); - traceln "Leaving critical section" - in - Fiber.both - (fun () -> M.use_rw ~protect:true t fn) - (fun () -> M.use_rw ~protect:true t fn);; -+Entered critical section -+Leaving critical section -+Entered critical section -+Leaving critical section -- : unit = () -``` - -A failed critical section will poison the mutex: - -```ocaml -# run @@ fun () -> - let t = M.create () in - try - M.use_rw ~protect:true t (fun () -> failwith "Simulated error"); - with Failure _ -> - traceln "Trying to use the failed lock again fails:"; - M.lock t;; -+Trying to use the failed lock again fails: -Exception: Eio__Eio_mutex.Poisoned (Failure "Simulated error"). -``` - -## Protection - -We can prevent cancellation during a critical section: - -```ocaml -# run @@ fun () -> - let t = M.create () in - Fiber.both - (fun () -> - M.use_rw ~protect:true t (fun () -> Fiber.yield (); traceln "Restored invariant"); - Fiber.check (); - traceln "Error: not cancelled!"; - ) - (fun () -> traceln "Cancelling..."; failwith "Simulated error");; -+Cancelling... -+Restored invariant -Exception: Failure "Simulated error". -``` - -Or allow interruption and disable the mutex: - -```ocaml -# run @@ fun () -> - let t = M.create () in - try - Fiber.both - (fun () -> - M.use_rw ~protect:false t (fun () -> Fiber.yield (); traceln "Restored invariant") - ) - (fun () -> traceln "Cancelling..."; failwith "Simulated error"); - with ex -> - traceln "Trying to reuse the failed mutex..."; - M.use_ro t (fun () -> assert false);; -+Cancelling... -+Trying to reuse the failed mutex... -Exception: -Eio__Eio_mutex.Poisoned - (Eio__core__Exn.Cancelled (Failure "Simulated error")). -``` - -Protection doesn't prevent cancellation while we're still waiting for the lock, though: - -```ocaml -# run @@ fun () -> - let t = M.create () in - M.lock t; - try - Fiber.both - (fun () -> M.use_rw ~protect:true t (fun () -> assert false)) - (fun () -> traceln "Cancelling..."; failwith "Simulated error") - with Failure _ -> - M.unlock t; - M.use_ro t (fun () -> traceln "Can reuse the mutex");; -+Cancelling... -+Can reuse the mutex -- : unit = () -``` - -Poisoning wakes any wakers: - -```ocaml -# run @@ fun () -> - let t = M.create () in - Fiber.both - (fun () -> - try - M.use_rw ~protect:false t (fun () -> - Fiber.yield (); - traceln "Poisoning mutex"; - failwith "Simulated error" - ) - with Failure _ -> () - ) - (fun () -> traceln "Waiting for lock..."; M.use_ro t (fun () -> assert false));; -+Waiting for lock... -+Poisoning mutex -Exception: Eio__Eio_mutex.Poisoned (Failure "Simulated error"). -``` - - -## Read-only access - -If the resource isn't being mutated, we can just unlock on error: - -```ocaml -# run @@ fun () -> - let t = M.create () in - try - M.use_ro t (fun () -> failwith "Simulated error"); - with Failure msg -> - traceln "Caught: %s" msg; - traceln "Trying to use the lock again is OK:"; - M.lock t;; -+Caught: Simulated error -+Trying to use the lock again is OK: -- : unit = () -``` - -## Try_lock - -```ocaml -# run @@ fun () -> - let t = M.create () in - let fn () = - match M.try_lock t with - | true -> - traceln "Entered critical section"; - Fiber.yield (); - traceln "Leaving critical section"; - M.unlock t - | false -> - traceln "Failed to get lock" - in - Fiber.both fn fn; - M.use_ro t (fun () -> traceln "Lock still works");; -+Entered critical section -+Failed to get lock -+Leaving critical section -+Lock still works -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +``` + +```ocaml +open Eio.Std + +module M = Eio.Mutex + +let run fn = + Eio_main.run @@ fun _ -> + fn () + +let lock t = + traceln "Locking"; + M.lock t; + traceln "Locked" + +let unlock t = + traceln "Unlocking"; + M.unlock t; + traceln "Unlocked" +``` + +# Test cases + +Simple case + +```ocaml +# run @@ fun () -> + let t = M.create () in + lock t; + unlock t; + lock t; + unlock t;; ++Locking ++Locked ++Unlocking ++Unlocked ++Locking ++Locked ++Unlocking ++Unlocked +- : unit = () +``` + +Concurrent access to the mutex + + +```ocaml +# run @@ fun () -> + let t = M.create () in + let fn () = + lock t; + Eio.Fiber.yield (); + unlock t + in + List.init 4 (fun _ -> fn) + |> Fiber.all;; ++Locking ++Locked ++Locking ++Locking ++Locking ++Unlocking ++Unlocked ++Locked ++Unlocking ++Unlocked ++Locked ++Unlocking ++Unlocked ++Locked ++Unlocking ++Unlocked +- : unit = () +``` + +Double unlock raises an exception + +```ocaml +# run @@ fun () -> + let t = M.create () in + M.lock t; + M.unlock t; + begin + try M.unlock t + with Sys_error msg -> traceln "Caught: %s" msg + end; + traceln "Trying to use lock after error..."; + M.lock t;; ++Caught: Eio.Mutex.unlock: already unlocked! ++Trying to use lock after error... +Exception: +Eio__Eio_mutex.Poisoned (Sys_error "Eio.Mutex.unlock: already unlocked!"). +``` + +## Read-write access + +Successful use; only one critical section is active at once: + +```ocaml +# run @@ fun () -> + let t = M.create () in + let fn () = + traceln "Entered critical section"; + Fiber.yield (); + traceln "Leaving critical section" + in + Fiber.both + (fun () -> M.use_rw ~protect:true t fn) + (fun () -> M.use_rw ~protect:true t fn);; ++Entered critical section ++Leaving critical section ++Entered critical section ++Leaving critical section +- : unit = () +``` + +A failed critical section will poison the mutex: + +```ocaml +# run @@ fun () -> + let t = M.create () in + try + M.use_rw ~protect:true t (fun () -> failwith "Simulated error"); + with Failure _ -> + traceln "Trying to use the failed lock again fails:"; + M.lock t;; ++Trying to use the failed lock again fails: +Exception: Eio__Eio_mutex.Poisoned (Failure "Simulated error"). +``` + +## Protection + +We can prevent cancellation during a critical section: + +```ocaml +# run @@ fun () -> + let t = M.create () in + Fiber.both + (fun () -> + M.use_rw ~protect:true t (fun () -> Fiber.yield (); traceln "Restored invariant"); + Fiber.check (); + traceln "Error: not cancelled!"; + ) + (fun () -> traceln "Cancelling..."; failwith "Simulated error");; ++Cancelling... ++Restored invariant +Exception: Failure "Simulated error". +``` + +Or allow interruption and disable the mutex: + +```ocaml +# run @@ fun () -> + let t = M.create () in + try + Fiber.both + (fun () -> + M.use_rw ~protect:false t (fun () -> Fiber.yield (); traceln "Restored invariant") + ) + (fun () -> traceln "Cancelling..."; failwith "Simulated error"); + with ex -> + traceln "Trying to reuse the failed mutex..."; + M.use_ro t (fun () -> assert false);; ++Cancelling... ++Trying to reuse the failed mutex... +Exception: +Eio__Eio_mutex.Poisoned + (Eio__core__Exn.Cancelled (Failure "Simulated error")). +``` + +Protection doesn't prevent cancellation while we're still waiting for the lock, though: + +```ocaml +# run @@ fun () -> + let t = M.create () in + M.lock t; + try + Fiber.both + (fun () -> M.use_rw ~protect:true t (fun () -> assert false)) + (fun () -> traceln "Cancelling..."; failwith "Simulated error") + with Failure _ -> + M.unlock t; + M.use_ro t (fun () -> traceln "Can reuse the mutex");; ++Cancelling... ++Can reuse the mutex +- : unit = () +``` + +Poisoning wakes any wakers: + +```ocaml +# run @@ fun () -> + let t = M.create () in + Fiber.both + (fun () -> + try + M.use_rw ~protect:false t (fun () -> + Fiber.yield (); + traceln "Poisoning mutex"; + failwith "Simulated error" + ) + with Failure _ -> () + ) + (fun () -> traceln "Waiting for lock..."; M.use_ro t (fun () -> assert false));; ++Waiting for lock... ++Poisoning mutex +Exception: Eio__Eio_mutex.Poisoned (Failure "Simulated error"). +``` + + +## Read-only access + +If the resource isn't being mutated, we can just unlock on error: + +```ocaml +# run @@ fun () -> + let t = M.create () in + try + M.use_ro t (fun () -> failwith "Simulated error"); + with Failure msg -> + traceln "Caught: %s" msg; + traceln "Trying to use the lock again is OK:"; + M.lock t;; ++Caught: Simulated error ++Trying to use the lock again is OK: +- : unit = () +``` + +## Try_lock + +```ocaml +# run @@ fun () -> + let t = M.create () in + let fn () = + match M.try_lock t with + | true -> + traceln "Entered critical section"; + Fiber.yield (); + traceln "Leaving critical section"; + M.unlock t + | false -> + traceln "Failed to get lock" + in + Fiber.both fn fn; + M.use_ro t (fun () -> traceln "Lock still works");; ++Entered critical section ++Failed to get lock ++Leaving critical section ++Lock still works +- : unit = () +``` diff --git a/tests/network.md b/tests/network.md index c22472925..98df3ac43 100644 --- a/tests/network.md +++ b/tests/network.md @@ -1,999 +1,999 @@ -## Setting up the environment - -```ocaml -# #require "eio_main";; -# #require "eio.mock";; -``` - -```ocaml -open Eio.Std - -let run (fn : net:_ Eio.Net.t -> Switch.t -> unit) = - Eio_main.run @@ fun env -> - let net = Eio.Stdenv.net env in - Switch.run (fn ~net) - -let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8081) -let addr6 = `Tcp (Eio.Net.Ipaddr.V6.loopback, 8081) - -let read_all flow = - let b = Buffer.create 100 in - Eio.Flow.copy flow (Eio.Flow.buffer_sink b); - Buffer.contents b - -exception Graceful_shutdown - -let () = Eio.Exn.Backend.show := false -``` - -## Test cases - -A simple client: - -```ocaml -let run_client ~sw ~net ~addr = - traceln "Connecting to server..."; - let flow = Eio.Net.connect ~sw net addr in - Eio.Flow.copy_string "Hello from client" flow; - Eio.Flow.shutdown flow `Send; - let msg = read_all flow in - traceln "Client received: %S" msg -``` - -A simple server: - -```ocaml -let run_server ~sw socket = - while true do - Eio.Net.accept_fork socket ~sw (fun flow _addr -> - traceln "Server accepted connection from client"; - Fun.protect (fun () -> - let msg = read_all flow in - traceln "Server received: %S" msg - ) ~finally:(fun () -> Eio.Flow.copy_string "Bye" flow) - ) - ~on_error:(function - | Graceful_shutdown -> () - | ex -> traceln "Error handling connection: %s" (Printexc.to_string ex) - ); - done - -let test_address addr ~net sw = - let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in - Fiber.both - (fun () -> run_server ~sw server) - (fun () -> - run_client ~sw ~net ~addr; - traceln "Client finished - cancelling server"; - raise Graceful_shutdown - ) -``` - -Handling one connection, then cancelling the server: - -```ocaml -# run (test_address addr);; -+Connecting to server... -+Server accepted connection from client -+Server received: "Hello from client" -+Client received: "Bye" -+Client finished - cancelling server -Exception: Graceful_shutdown. -``` - -Handling one connection on a Unix domain socket: - -```ocaml -# run (test_address (`Unix "eio-test.sock"));; -+Connecting to server... -+Server accepted connection from client -+Server received: "Hello from client" -+Client received: "Bye" -+Client finished - cancelling server -Exception: Graceful_shutdown. -``` - -Handling one connection on an abstract Unix domain socket (this only works on Linux): - - -```ocaml -# run (test_address (`Unix "\x00/tmp/eio-test.sock"));; -+Connecting to server... -+Server accepted connection from client -+Server received: "Hello from client" -+Client received: "Bye" -+Client finished - cancelling server -Exception: Graceful_shutdown. -``` - -Handling one connection using IPv6: - -```ocaml -# run (test_address addr6);; -+Connecting to server... -+Server accepted connection from client -+Server received: "Hello from client" -+Client received: "Bye" -+Client finished - cancelling server -Exception: Graceful_shutdown. -``` - -Cancelling the read: - -```ocaml -# run @@ fun ~net sw -> - let shutdown, set_shutdown = Promise.create () in - let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in - Fiber.both - (fun () -> - Eio.Net.accept_fork server ~sw (fun flow _addr -> - try - Fiber.both - (fun () -> raise (Promise.await shutdown)) - (fun () -> - let msg = read_all flow in - traceln "Server received: %S" msg - ) - with Graceful_shutdown -> - Eio.Flow.copy_string "Request cancelled" flow - ) ~on_error:raise - ) - (fun () -> - traceln "Connecting to server..."; - let flow = Eio.Net.connect ~sw net addr in - traceln "Connection opened - cancelling server's read"; - Fiber.yield (); - Promise.resolve set_shutdown Graceful_shutdown; - let msg = read_all flow in - traceln "Client received: %S" msg - );; -+Connecting to server... -+Connection opened - cancelling server's read -+Client received: "Request cancelled" -- : unit = () -``` - -Calling accept when the switch is already off: - -```ocaml -# run @@ fun ~net sw -> - let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in - Switch.fail sw (Failure "Simulated error"); - Eio.Net.accept_fork server ~sw (fun _flow _addr -> assert false) - ~on_error:raise;; -Exception: Failure "Simulated error". -``` - -Working with UDP and endpoints: - -```ocaml -let run_dgram addr ~net sw = - let e1 = `Udp (addr, 8081) in - let e2 = `Udp (addr, 8082) in - let listening_socket = Eio.Net.datagram_socket ~sw net e2 in - Fiber.both - (fun () -> - let buf = Cstruct.create 20 in - traceln "Waiting to receive data on %a" Eio.Net.Sockaddr.pp e2; - let addr, recv = Eio.Net.recv listening_socket buf in - traceln "Received message from %a: %s" - Eio.Net.Sockaddr.pp addr - (Cstruct.(to_string (sub buf 0 recv))) - ) - (fun () -> - let e = Eio.Net.datagram_socket ~sw net e1 in - traceln "Sending data from %a to %a" Eio.Net.Sockaddr.pp e1 Eio.Net.Sockaddr.pp e2; - Eio.Net.send e ~dst:e2 [Cstruct.of_string "UDP Message"]) -``` - -Handling one UDP packet using IPv4: - -```ocaml -# run (run_dgram Eio.Net.Ipaddr.V4.loopback);; -+Waiting to receive data on udp:127.0.0.1:8082 -+Sending data from udp:127.0.0.1:8081 to udp:127.0.0.1:8082 -+Received message from udp:127.0.0.1:8081: UDP Message -- : unit = () -``` - -Handling one UDP packet using IPv6: - -```ocaml -# run (run_dgram Eio.Net.Ipaddr.V6.loopback);; -+Waiting to receive data on udp:[::1]:8082 -+Sending data from udp:[::1]:8081 to udp:[::1]:8082 -+Received message from udp:[::1]:8081: UDP Message -- : unit = () -``` - -Now test host-assigned addresses. -`run_dgram2` is like `run_dgram` above, but doesn't print the sender address -since it will be different in each run: - -```ocaml -let run_dgram2 ~e1 addr ~net sw = - let server_addr = `Udp (addr, 8082) in - let listening_socket = Eio.Net.datagram_socket ~sw net server_addr in - Fiber.both - (fun () -> - let buf = Cstruct.create 20 in - traceln "Waiting to receive data on %a" Eio.Net.Sockaddr.pp server_addr; - let addr, recv = Eio.Net.recv listening_socket buf in - traceln "Received message %s" (Cstruct.(to_string (sub buf 0 recv))) - ) - (fun () -> - let e = Eio.Net.datagram_socket ~sw net e1 in - traceln "Sending data to %a" Eio.Net.Sockaddr.pp server_addr; - Eio.Net.send e ~dst:server_addr [Cstruct.of_string "UDP Message"]);; -``` - -Handling one UDP packet using IPv4: - -```ocaml -# let addr = Eio.Net.Ipaddr.V4.loopback in - run @@ run_dgram2 addr ~e1:`UdpV4;; -+Waiting to receive data on udp:127.0.0.1:8082 -+Sending data to udp:127.0.0.1:8082 -+Received message UDP Message -- : unit = () -``` - -Handling one UDP packet using IPv6: - -```ocaml -# let addr = Eio.Net.Ipaddr.V6.loopback in - run @@ run_dgram2 addr ~e1:`UdpV6;; -+Waiting to receive data on udp:[::1]:8082 -+Sending data to udp:[::1]:8082 -+Received message UDP Message -- : unit = () -``` - -It's not an error to close the socket before the handler returns: - -```ocaml -# run @@ fun ~net sw -> - let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8083) in - let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in - Fiber.both - (fun () -> - Eio.Net.accept_fork server ~sw ~on_error:raise @@ fun flow _addr -> - traceln "Server got connection"; - Eio.Flow.copy_string "Hi" flow; - Eio.Flow.close flow - ) - (fun () -> - traceln "Connecting to server..."; - let flow = Eio.Net.connect ~sw net addr in - let msg = Eio.Buf_read.(parse_exn take_all) flow ~max_size:100 in - traceln "Client got %S" msg; - );; -+Connecting to server... -+Server got connection -+Client got "Hi" -- : unit = () -``` - -## Unix interop - -Extracting file descriptors from Eio objects: - -```ocaml -# run @@ fun ~net sw -> - let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in - traceln "Listening socket has Unix FD: %b" (Eio_unix.Resource.fd_opt server <> None); - let have_client, have_server = - Fiber.pair - (fun () -> - let flow = Eio.Net.connect ~sw net addr in - (Eio_unix.Resource.fd_opt flow <> None) - ) - (fun () -> - let flow, _addr = Eio.Net.accept ~sw server in - (Eio_unix.Resource.fd_opt flow <> None) - ) - in - traceln "Client-side socket has Unix FD: %b" have_client; - traceln "Server-side socket has Unix FD: %b" have_server;; -+Listening socket has Unix FD: true -+Client-side socket has Unix FD: true -+Server-side socket has Unix FD: true -- : unit = () -``` - -Check we can convert Eio IP addresses to Unix: - -```ocaml -# Eio.Net.Ipaddr.V4.loopback |> Eio_unix.Net.Ipaddr.to_unix |> Unix.string_of_inet_addr;; -- : string = "127.0.0.1" -# Eio.Net.Ipaddr.V4.any |> Eio_unix.Net.Ipaddr.to_unix |> Unix.string_of_inet_addr;; -- : string = "0.0.0.0" -# Eio.Net.Ipaddr.V6.loopback |> Eio_unix.Net.Ipaddr.to_unix |> Unix.string_of_inet_addr;; -- : string = "::1" -# Eio.Net.Ipaddr.V6.any |> Eio_unix.Net.Ipaddr.to_unix |> Unix.string_of_inet_addr;; -- : string = "::" -``` - -Check we can convert Unix IP addresses to Eio: - -```ocaml -# Eio_main.run @@ fun _ -> - let show x = traceln "%a" Eio.Net.Ipaddr.pp (Eio_unix.Net.Ipaddr.of_unix (Unix.inet_addr_of_string x)) in - show "127.0.0.1"; - show "0.0.0.0"; - show "1234:5678:9abc:def0:fedc:ba98:7654:3210"; - show "::1"; - show "::"; - show "ab::"; - show "::ffff:192.168.1.3"; - show "1:0:0:2:0:0:0:3"; - show "4:1:0:0:2:0:0:3";; -+127.0.0.1 -+0.0.0.0 -+1234:5678:9abc:def0:fedc:ba98:7654:3210 -+::1 -+:: -+ab:: -+::ffff:192.168.1.3 -+1:0:0:2::3 -+4:1::2:0:0:3 -- : unit = () -``` - -Printing addresses with ports: - -```ocaml -# let show host port = - let host = Eio_unix.Net.Ipaddr.of_unix (Unix.inet_addr_of_string host) in - traceln "%a" Eio.Net.Sockaddr.pp (`Tcp (host, port)) - in - Eio_main.run @@ fun env -> - show "127.0.0.1" 8080; - show "::1" 8080;; -+tcp:127.0.0.1:8080 -+tcp:[::1]:8080 -- : unit = () -``` - -Wrapping a Unix FD as an Eio stream socket: - -```ocaml -# Eio_main.run @@ fun _ -> - Switch.run @@ fun sw -> - let r, w = Unix.pipe () in - let source = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true r :> _ Eio.Flow.source) in - let sink = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true w :> _ Eio.Flow.sink) in - Fiber.both - (fun () -> Eio.Flow.copy_string "Hello\n!" sink) - (fun () -> - let b = Eio.Buf_read.of_flow source ~max_size:1000 in - traceln "Got: %S" (Eio.Buf_read.line b) - );; -+Got: "Hello" -- : unit = () -``` - -Wrapping a Unix FD as a listening Eio socket: - -```ocaml -# run @@ fun ~net sw -> - let l = Unix.(socket PF_INET SOCK_STREAM 0) in - Unix.bind l (Unix.ADDR_INET (Unix.inet_addr_loopback, 8082)); - Unix.listen l 40; - let l = Eio_unix.Net.import_socket_listening ~sw ~close_unix:true l in - Fiber.both - (fun () -> run_server ~sw l) - (fun () -> - run_client ~sw ~net ~addr:(`Tcp (Eio.Net.Ipaddr.V4.loopback, 8082)); - traceln "Client finished - cancelling server"; - raise Graceful_shutdown - );; -+Connecting to server... -+Server accepted connection from client -+Server received: "Hello from client" -+Client received: "Bye" -+Client finished - cancelling server -Exception: Graceful_shutdown. -``` - -Wrapping a Unix FD as an datagram Eio socket: - -```ocaml -# Eio_main.run @@ fun _ -> - Switch.run @@ fun sw -> - let a, b = Unix.(socketpair PF_UNIX SOCK_DGRAM 0) in - let a = Eio_unix.Net.import_socket_datagram ~sw ~close_unix:true a in - let b = Eio_unix.Net.import_socket_datagram ~sw ~close_unix:true b in - Fiber.both - (fun () -> Eio.Net.send a Cstruct.[of_string "12"; of_string "34"]) - (fun () -> - let buf = Cstruct.create 10 in - let addr, len = Eio.Net.recv b buf in - traceln "Got: %S" (Cstruct.to_string buf ~len) - );; -+Got: "1234" -- : unit = () -``` - -## Accept_fork error handling - -On success, we close the connection immediately: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let socket = Eio_mock.Net.listening_socket "tcp/80" in - let flow = Eio_mock.Flow.make "connection" in - let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 1234) in - Eio_mock.Net.on_accept socket [`Return (flow, addr)]; - Switch.run @@ fun sw -> - Eio.Net.accept_fork ~sw ~on_error:raise socket - (fun _flow _addr -> ()); - traceln "Mock connection should have been closed by now";; -+tcp/80: accepted connection from tcp:127.0.0.1:1234 -+connection: closed -+Mock connection should have been closed by now -- : unit = () -``` -If the forked fiber fails, we close immediately: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let socket = Eio_mock.Net.listening_socket "tcp/80" in - let flow = Eio_mock.Flow.make "connection" in - let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 1234) in - Eio_mock.Net.on_accept socket [`Return (flow, addr)]; - Switch.run @@ fun sw -> - Eio.Net.accept_fork ~sw ~on_error:raise socket - (fun _flow _addr -> failwith "Simulated error"); - traceln "Mock connection should have been closed by now";; -+tcp/80: accepted connection from tcp:127.0.0.1:1234 -+connection: closed -+Mock connection should have been closed by now -Exception: Failure "Simulated error". -``` -If the fork itself fails, we still close the connection: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let socket = Eio_mock.Net.listening_socket "tcp/80" in - let flow = Eio_mock.Flow.make "connection" in - let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 1234) in - Eio_mock.Net.on_accept socket [`Return (flow, addr)]; - Switch.run @@ fun sw -> - Switch.fail sw (Failure "Simulated error"); - Eio.Net.accept_fork ~sw ~on_error:raise socket - (fun _flow _addr -> assert false); - traceln "Mock connection should have been closed by now";; -+tcp/80: accepted connection from tcp:127.0.0.1:1234 -+connection: closed -+Mock connection should have been closed by now -Exception: Failure "Simulated error". -``` - -`accept_fork` doesn't send cancellations to `on_error`: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let socket = Eio_mock.Net.listening_socket "tcp/80" in - let flow = Eio_mock.Flow.make "connection" in - let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 1234) in - Eio_mock.Net.on_accept socket [`Return (flow, addr)]; - Switch.run @@ fun sw -> - Eio.Net.accept_fork ~sw ~on_error:(traceln "BUG: %a" Fmt.exn) socket - (fun _flow _addr -> Fiber.await_cancel ()); - Switch.fail sw (Failure "Simulated error");; -+tcp/80: accepted connection from tcp:127.0.0.1:1234 -+connection: closed -Exception: Failure "Simulated error". -``` - -## Socketpair - -```ocaml -# Eio_main.run @@ fun _ -> - Switch.run @@ fun sw -> - let a, b = Eio_unix.Net.socketpair_stream ~sw () in - ignore (Eio_unix.Net.fd a : Eio_unix.Fd.t); - ignore (Eio_unix.Net.fd b : Eio_unix.Fd.t); - Eio.Flow.copy_string "foo" a; - Eio.Flow.close a; - let msg = Eio.Buf_read.of_flow b ~max_size:10 |> Eio.Buf_read.take_all in - traceln "Got: %S" msg;; -+Got: "foo" -- : unit = () -``` -## Errors - -ECONNRESET: - -```ocaml -# Eio_main.run @@ fun _ -> - Switch.run @@ fun sw -> - let a, b = Eio_unix.Net.socketpair_stream ~sw () in - Eio.Flow.copy_string "foo" a; - Eio.Flow.close b; (* Close without reading *) - try - Eio.Flow.read_exact a (Cstruct.create 1); - assert false - with - | Eio.Io (Eio.Net.E Connection_reset _, _) - | End_of_file -> traceln "Connection failed (good)";; -+Connection failed (good) -- : unit = () -``` - -EPIPE: - -```ocaml -# Eio_main.run @@ fun _ -> - Switch.run @@ fun sw -> - let a, b = Eio_unix.Net.socketpair_stream ~sw () in - Eio.Flow.close b; - try - Eio.Flow.copy_string "foo" a; - assert false - with Eio.Io (Eio.Net.E Connection_reset _, _) -> traceln "Connection failed (good)";; -+Connection failed (good) -- : unit = () -``` - -Connection refused: - -```ocaml -# Eio_main.run @@ fun env -> - Switch.run @@ fun sw -> - Eio.Net.connect ~sw env#net (`Unix "idontexist.sock");; -Exception: Eio.Io Fs Not_found _, - connecting to unix:idontexist.sock -``` - -## Shutdown - -```ocaml -# Eio_main.run @@ fun _ -> - Switch.run @@ fun sw -> - let a, b = Eio_unix.Net.socketpair_stream ~sw () in - Fiber.both - (fun () -> - match Eio.Flow.read_exact a (Cstruct.create 1) with - | () -> failwith "Should have ended!" - | exception End_of_file -> () - ) - (fun () -> Eio.Flow.shutdown a `Receive);; -- : unit = () -``` - -## Getaddrinfo - -```ocaml -# Eio_main.run @@ fun env -> - Eio.Net.getaddrinfo_stream env#net "127.0.0.1";; -- : Eio.Net.Sockaddr.stream list = [`Tcp ("\127\000\000\001", 0)] -``` - -```ocaml -# Eio_main.run @@ fun env -> - Eio.Net.getaddrinfo_stream env#net "127.0.0.1" ~service:"80";; -- : Eio.Net.Sockaddr.stream list = [`Tcp ("\127\000\000\001", 80)] -``` - -```ocaml -# Eio_main.run @@ fun env -> - Eio.Net.getaddrinfo_datagram env#net "127.0.0.1";; -- : Eio.Net.Sockaddr.datagram list = [`Udp ("\127\000\000\001", 0)] -``` - -```ocaml -# Eio_main.run @@ fun env -> - Eio.Net.getaddrinfo_datagram env#net "127.0.0.1" ~service:"80";; -- : Eio.Net.Sockaddr.datagram list = [`Udp ("\127\000\000\001", 80)] -``` - - -```ocaml -# Eio_main.run @@ fun env -> - Eio.Net.getaddrinfo ~service:"http" env#net "127.0.0.1";; -- : Eio.Net.Sockaddr.t list = -[`Tcp ("\127\000\000\001", 80); `Udp ("\127\000\000\001", 80)] -``` - - -```ocaml -# Eio_main.run @@ fun env -> - Eio.Net.getaddrinfo ~service:"ftp" env#net "127.0.0.1";; -- : Eio.Net.Sockaddr.t list = -[`Tcp ("\127\000\000\001", 21); `Udp ("\127\000\000\001", 21)] -``` - - -```ocaml -# Eio_main.run @@ fun env -> - Eio.Net.getaddrinfo ~service:"https" env#net "google.com";; -- : Eio.Net.Sockaddr.t list = -[`Tcp ("�:��", 443); `Udp ("�:��", 443); - `Tcp ("*\000\020P@\t\b \000\000\000\000\000\000 \014", 443); - `Udp ("*\000\020P@\t\b \000\000\000\000\000\000 \014", 443)] -``` - -## getnameinfo - -```ocaml -# Eio_main.run @@ fun env -> - let sockaddr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 80) in - Eio.Net.getnameinfo env#net sockaddr;; -- : string * string = ("localhost", "http") -``` - -## with_tcp_connet - -```ocaml -let net = Eio_mock.Net.make "mock-net" -let addr1 = `Tcp (Eio.Net.Ipaddr.V4.loopback, 80) -let addr2 = `Tcp (Eio.Net.Ipaddr.of_raw "\001\002\003\004", 8080) -let connection_failure = Eio.Net.err (Connection_failure (Refused Eio_mock.Simulated_failure)) -``` - -No usable addresses: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Net.on_getaddrinfo net [`Return [`Unix "/foo"]]; - Eio.Net.with_tcp_connect ~host:"www.example.com" ~service:"http" net (fun _ -> assert false);; -+mock-net: getaddrinfo ~service:http www.example.com -Exception: -Eio.Io Net Connection_failure No_matching_addresses, - connecting to "www.example.com":http -``` - -First address works: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; - let mock_flow = Eio_mock.Flow.make "flow" in - Eio_mock.Net.on_connect net [`Return mock_flow]; - Eio.Net.with_tcp_connect ~host:"www.example.com" ~service:"http" net (fun conn -> - let req = "GET / HTTP/1.1\r\nHost:www.example.com:80\r\n\r\n" in - Eio.Flow.copy_string req conn - );; -+mock-net: getaddrinfo ~service:http www.example.com -+mock-net: connect to tcp:127.0.0.1:80 -+flow: wrote "GET / HTTP/1.1\r\n" -+ "Host:www.example.com:80\r\n" -+ "\r\n" -+flow: closed -- : unit = () -``` - -Second address works: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; - let mock_flow = Eio_mock.Flow.make "flow" in - Eio_mock.Net.on_connect net [`Raise connection_failure; - `Return mock_flow]; - Eio.Net.with_tcp_connect ~host:"www.example.com" ~service:"http" net (fun conn -> - let req = "GET / HTTP/1.1\r\nHost:www.example.com:80\r\n\r\n" in - Eio.Flow.copy_string req conn - );; -+mock-net: getaddrinfo ~service:http www.example.com -+mock-net: connect to tcp:127.0.0.1:80 -+mock-net: connect to tcp:1.2.3.4:8080 -+flow: wrote "GET / HTTP/1.1\r\n" -+ "Host:www.example.com:80\r\n" -+ "\r\n" -+flow: closed -- : unit = () -``` - -Both addresses fail: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; - Eio_mock.Net.on_connect net [`Raise connection_failure; `Raise connection_failure]; - Eio.Net.with_tcp_connect ~host:"www.example.com" ~service:"http" net (fun _ -> assert false);; -+mock-net: getaddrinfo ~service:http www.example.com -+mock-net: connect to tcp:127.0.0.1:80 -+mock-net: connect to tcp:1.2.3.4:8080 -Exception: -Eio.Io Net Connection_failure Refused _, - connecting to tcp:1.2.3.4:8080, - connecting to "www.example.com":http -``` - -First attempt times out: - -```ocaml -# Eio_mock.Backend.run_full @@ fun env -> - let clock = env#mono_clock in - let timeout = Eio.Time.Timeout.seconds clock 10. in - Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; - let mock_flow = Eio_mock.Flow.make "flow" in - Eio_mock.Net.on_connect net [`Run Fiber.await_cancel; `Return mock_flow]; - Eio.Net.with_tcp_connect ~timeout ~host:"www.example.com" ~service:"http" net (fun conn -> - let req = "GET / HTTP/1.1\r\nHost:www.example.com:80\r\n\r\n" in - Eio.Flow.copy_string req conn - ) -+mock-net: getaddrinfo ~service:http www.example.com -+mock-net: connect to tcp:127.0.0.1:80 -+mock time is now 10 -+mock-net: connect to tcp:1.2.3.4:8080 -+flow: wrote "GET / HTTP/1.1\r\n" -+ "Host:www.example.com:80\r\n" -+ "\r\n" -+flow: closed -- : unit = () -``` - -Both attempts time out: - -```ocaml -# Eio_mock.Backend.run_full @@ fun env -> - let clock = env#mono_clock in - let timeout = Eio.Time.Timeout.seconds clock 10. in - Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; - Eio_mock.Net.on_connect net [`Run Fiber.await_cancel; `Run Fiber.await_cancel]; - Eio.Net.with_tcp_connect ~timeout ~host:"www.example.com" ~service:"http" net (fun _ -> - assert false - ) -+mock-net: getaddrinfo ~service:http www.example.com -+mock-net: connect to tcp:127.0.0.1:80 -+mock time is now 10 -+mock-net: connect to tcp:1.2.3.4:8080 -+mock time is now 20 -Exception: -Eio.Io Net Connection_failure Timeout, - connecting to "www.example.com":http -``` - -## read/write on SOCK_DGRAM - -```ocaml -# Eio_main.run @@ fun _ -> - Switch.run @@ fun sw -> - let a, b = Eio_unix.Net.socketpair_datagram ~sw ~domain:Unix.PF_UNIX () in - ignore (Eio_unix.Net.fd a : Eio_unix.Fd.t); - ignore (Eio_unix.Net.fd b : Eio_unix.Fd.t); - let l = [ "foo"; "bar"; "foobar"; "cellar door"; "" ] in - let buf = Cstruct.create 32 in - let write bufs = Eio.Net.send a (List.map Cstruct.of_string bufs) in - let read () = - let _addr, n = Eio.Net.recv b buf in - traceln "Got: %d bytes: %S" n Cstruct.(to_string (sub buf 0 n)) - in - List.iter (fun sbuf -> write [sbuf]) l; - List.iter (fun _ -> read ()) l; - write ["abaca"; "bb"]; - read (); - Eio.Flow.close a; - Eio.Flow.close b;; -+Got: 3 bytes: "foo" -+Got: 3 bytes: "bar" -+Got: 6 bytes: "foobar" -+Got: 11 bytes: "cellar door" -+Got: 0 bytes: "" -+Got: 7 bytes: "abacabb" -- : unit = () -``` - - -## run_server - -A simple connection handler for testing: -```ocaml -let handle_connection flow _addr = - let msg = read_all flow in - assert (msg = "Hi"); - Fiber.yield (); - Eio.Flow.copy_string "Bye" flow -``` - -A mock listening socket that allows acceping `n_clients` clients, each of which writes "Hi", -and then allows `n_domains` further attempts, none of which ever completes: - -```ocaml -let mock_listener ~n_clients ~n_domains = - let make_flow i () = - if n_domains > 1 then Fiber.yield () (* Load balance *) - else Fiber.check (); - let flow = Eio_mock.Flow.make ("flow" ^ string_of_int i) in - Eio_mock.Flow.on_read flow [`Return "Hi"; `Raise End_of_file]; - flow, `Tcp (Eio.Net.Ipaddr.V4.loopback, 30000 + i) - in - let listening_socket = Eio_mock.Net.listening_socket "tcp/80" in - Eio_mock.Net.on_accept listening_socket ( - List.init n_clients (fun i -> `Run (make_flow i)) @ - List.init n_domains (fun _ -> `Run Fiber.await_cancel) - ); - listening_socket -``` - -Start handling the connections, then begin a graceful shutdown, -allowing the connections to finish and then exiting: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let listening_socket = mock_listener ~n_clients:3 ~n_domains:1 in - let stop, set_stop = Promise.create () in - Fiber.both - (fun () -> - Eio.Net.run_server listening_socket handle_connection - ~max_connections:10 - ~on_error:raise - ~stop - ) - (fun () -> - traceln "Begin graceful shutdown"; - Promise.resolve set_stop () - );; -+tcp/80: accepted connection from tcp:127.0.0.1:30000 -+flow0: read "Hi" -+tcp/80: accepted connection from tcp:127.0.0.1:30001 -+flow1: read "Hi" -+tcp/80: accepted connection from tcp:127.0.0.1:30002 -+flow2: read "Hi" -+Begin graceful shutdown -+flow0: wrote "Bye" -+flow0: closed -+flow1: wrote "Bye" -+flow1: closed -+flow2: wrote "Bye" -+flow2: closed -- : unit = () -``` - -Non-graceful shutdown, closing all connections still in progress: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let listening_socket = mock_listener ~n_clients:3 ~n_domains:1 in - Fiber.both - (fun () -> - Eio.Net.run_server listening_socket handle_connection - ~max_connections:10 - ~on_error:raise - ) - (fun () -> failwith "Simulated error");; -+tcp/80: accepted connection from tcp:127.0.0.1:30000 -+flow0: read "Hi" -+tcp/80: accepted connection from tcp:127.0.0.1:30001 -+flow1: read "Hi" -+tcp/80: accepted connection from tcp:127.0.0.1:30002 -+flow2: read "Hi" -+flow0: closed -+flow1: closed -+flow2: closed -Exception: Failure "Simulated error". -``` - -Handling the connections with 3 domains, with a graceful shutdown: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Domain_manager.run @@ fun fake_domain_mgr -> - let n_domains = 3 in - let listening_socket = mock_listener ~n_clients:10 ~n_domains in - let stop, set_stop = Promise.create () in - Fiber.both - (fun () -> - Eio.Net.run_server listening_socket handle_connection - ~additional_domains:(fake_domain_mgr, n_domains - 1) - ~max_connections:10 - ~on_error:raise - ~stop - ) - (fun () -> - Fiber.yield (); - Promise.resolve set_stop (); - Fiber.yield (); (* Allow fibers to receive shutdown request *) - traceln "Requested graceful shutdown" - );; -+[1] tcp/80: accepted connection from tcp:127.0.0.1:30000 -+[1] flow0: read "Hi" -+[2] tcp/80: accepted connection from tcp:127.0.0.1:30001 -+[2] flow1: read "Hi" -+[0] tcp/80: accepted connection from tcp:127.0.0.1:30002 -+[0] flow2: read "Hi" -+[1] flow0: wrote "Bye" -+[1] flow0: closed -+[1] tcp/80: accepted connection from tcp:127.0.0.1:30003 -+[1] flow3: read "Hi" -+[2] flow1: wrote "Bye" -+[2] flow1: closed -+[2] tcp/80: accepted connection from tcp:127.0.0.1:30004 -+[2] flow4: read "Hi" -+[0] flow2: wrote "Bye" -+[0] flow2: closed -+[0] tcp/80: accepted connection from tcp:127.0.0.1:30005 -+[0] flow5: read "Hi" -+[0] Requested graceful shutdown -+[1] flow3: wrote "Bye" -+[1] flow3: closed -+[2] flow4: wrote "Bye" -+[2] flow4: closed -+[0] flow5: wrote "Bye" -+[0] flow5: closed -- : unit = () -``` - -Handling the connections with 3 domains, aborting immediately: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Domain_manager.run @@ fun fake_domain_mgr -> - let n_domains = 3 in - let listening_socket = mock_listener ~n_clients:10 ~n_domains in - Fiber.both - (fun () -> - Eio.Net.run_server listening_socket handle_connection - ~additional_domains:(fake_domain_mgr, n_domains - 1) - ~max_connections:10 - ~on_error:raise - ) - (fun () -> Fiber.yield (); failwith "Simulated error");; -+[1] tcp/80: accepted connection from tcp:127.0.0.1:30000 -+[1] flow0: read "Hi" -+[2] tcp/80: accepted connection from tcp:127.0.0.1:30001 -+[2] flow1: read "Hi" -+[0] tcp/80: accepted connection from tcp:127.0.0.1:30002 -+[0] flow2: read "Hi" -+[1] flow0: closed -+[2] flow1: closed -+[0] flow2: closed -Exception: Failure "Simulated error". -``` - -Limiting to 2 concurrent connections: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let listening_socket = mock_listener ~n_clients:10 ~n_domains:1 in - let stop, set_stop = Promise.create () in - Fiber.both - (fun () -> - Eio.Net.run_server listening_socket handle_connection - ~max_connections:2 - ~on_error:raise - ~stop - ) - (fun () -> - for _ = 1 to 2 do Fiber.yield () done; - traceln "Begin graceful shutdown"; - Promise.resolve set_stop () - );; -+tcp/80: accepted connection from tcp:127.0.0.1:30000 -+flow0: read "Hi" -+tcp/80: accepted connection from tcp:127.0.0.1:30001 -+flow1: read "Hi" -+flow0: wrote "Bye" -+flow0: closed -+flow1: wrote "Bye" -+flow1: closed -+tcp/80: accepted connection from tcp:127.0.0.1:30002 -+flow2: read "Hi" -+tcp/80: accepted connection from tcp:127.0.0.1:30003 -+flow3: read "Hi" -+Begin graceful shutdown -+flow2: wrote "Bye" -+flow2: closed -+flow3: wrote "Bye" -+flow3: closed -- : unit = () -``` - -We keep the polymorphism when using a Unix network: - -```ocaml -let _check_types ~(net:Eio_unix.Net.t) = - Switch.run @@ fun sw -> - let addr = `Unix "/socket" in - let server : [`Generic | `Unix] Eio.Net.listening_socket_ty r = - Eio.Net.listen ~sw net addr ~backlog:5 - in - Eio.Net.accept_fork ~sw ~on_error:raise server - (fun (_flow : [`Generic | `Unix] Eio.Net.stream_socket_ty r) _addr -> assert false); - let _client : [`Generic | `Unix] Eio.Net.stream_socket_ty r = Eio.Net.connect ~sw net addr in - ();; -``` +## Setting up the environment + +```ocaml +# #require "eio_main";; +# #require "eio.mock";; +``` + +```ocaml +open Eio.Std + +let run (fn : net:_ Eio.Net.t -> Switch.t -> unit) = + Eio_main.run @@ fun env -> + let net = Eio.Stdenv.net env in + Switch.run (fn ~net) + +let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8081) +let addr6 = `Tcp (Eio.Net.Ipaddr.V6.loopback, 8081) + +let read_all flow = + let b = Buffer.create 100 in + Eio.Flow.copy flow (Eio.Flow.buffer_sink b); + Buffer.contents b + +exception Graceful_shutdown + +let () = Eio.Exn.Backend.show := false +``` + +## Test cases + +A simple client: + +```ocaml +let run_client ~sw ~net ~addr = + traceln "Connecting to server..."; + let flow = Eio.Net.connect ~sw net addr in + Eio.Flow.copy_string "Hello from client" flow; + Eio.Flow.shutdown flow `Send; + let msg = read_all flow in + traceln "Client received: %S" msg +``` + +A simple server: + +```ocaml +let run_server ~sw socket = + while true do + Eio.Net.accept_fork socket ~sw (fun flow _addr -> + traceln "Server accepted connection from client"; + Fun.protect (fun () -> + let msg = read_all flow in + traceln "Server received: %S" msg + ) ~finally:(fun () -> Eio.Flow.copy_string "Bye" flow) + ) + ~on_error:(function + | Graceful_shutdown -> () + | ex -> traceln "Error handling connection: %s" (Printexc.to_string ex) + ); + done + +let test_address addr ~net sw = + let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in + Fiber.both + (fun () -> run_server ~sw server) + (fun () -> + run_client ~sw ~net ~addr; + traceln "Client finished - cancelling server"; + raise Graceful_shutdown + ) +``` + +Handling one connection, then cancelling the server: + +```ocaml +# run (test_address addr);; ++Connecting to server... ++Server accepted connection from client ++Server received: "Hello from client" ++Client received: "Bye" ++Client finished - cancelling server +Exception: Graceful_shutdown. +``` + +Handling one connection on a Unix domain socket: + +```ocaml +# run (test_address (`Unix "eio-test.sock"));; ++Connecting to server... ++Server accepted connection from client ++Server received: "Hello from client" ++Client received: "Bye" ++Client finished - cancelling server +Exception: Graceful_shutdown. +``` + +Handling one connection on an abstract Unix domain socket (this only works on Linux): + + +```ocaml +# run (test_address (`Unix "\x00/tmp/eio-test.sock"));; ++Connecting to server... ++Server accepted connection from client ++Server received: "Hello from client" ++Client received: "Bye" ++Client finished - cancelling server +Exception: Graceful_shutdown. +``` + +Handling one connection using IPv6: + +```ocaml +# run (test_address addr6);; ++Connecting to server... ++Server accepted connection from client ++Server received: "Hello from client" ++Client received: "Bye" ++Client finished - cancelling server +Exception: Graceful_shutdown. +``` + +Cancelling the read: + +```ocaml +# run @@ fun ~net sw -> + let shutdown, set_shutdown = Promise.create () in + let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in + Fiber.both + (fun () -> + Eio.Net.accept_fork server ~sw (fun flow _addr -> + try + Fiber.both + (fun () -> raise (Promise.await shutdown)) + (fun () -> + let msg = read_all flow in + traceln "Server received: %S" msg + ) + with Graceful_shutdown -> + Eio.Flow.copy_string "Request cancelled" flow + ) ~on_error:raise + ) + (fun () -> + traceln "Connecting to server..."; + let flow = Eio.Net.connect ~sw net addr in + traceln "Connection opened - cancelling server's read"; + Fiber.yield (); + Promise.resolve set_shutdown Graceful_shutdown; + let msg = read_all flow in + traceln "Client received: %S" msg + );; ++Connecting to server... ++Connection opened - cancelling server's read ++Client received: "Request cancelled" +- : unit = () +``` + +Calling accept when the switch is already off: + +```ocaml +# run @@ fun ~net sw -> + let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in + Switch.fail sw (Failure "Simulated error"); + Eio.Net.accept_fork server ~sw (fun _flow _addr -> assert false) + ~on_error:raise;; +Exception: Failure "Simulated error". +``` + +Working with UDP and endpoints: + +```ocaml +let run_dgram addr ~net sw = + let e1 = `Udp (addr, 8081) in + let e2 = `Udp (addr, 8082) in + let listening_socket = Eio.Net.datagram_socket ~sw net e2 in + Fiber.both + (fun () -> + let buf = Cstruct.create 20 in + traceln "Waiting to receive data on %a" Eio.Net.Sockaddr.pp e2; + let addr, recv = Eio.Net.recv listening_socket buf in + traceln "Received message from %a: %s" + Eio.Net.Sockaddr.pp addr + (Cstruct.(to_string (sub buf 0 recv))) + ) + (fun () -> + let e = Eio.Net.datagram_socket ~sw net e1 in + traceln "Sending data from %a to %a" Eio.Net.Sockaddr.pp e1 Eio.Net.Sockaddr.pp e2; + Eio.Net.send e ~dst:e2 [Cstruct.of_string "UDP Message"]) +``` + +Handling one UDP packet using IPv4: + +```ocaml +# run (run_dgram Eio.Net.Ipaddr.V4.loopback);; ++Waiting to receive data on udp:127.0.0.1:8082 ++Sending data from udp:127.0.0.1:8081 to udp:127.0.0.1:8082 ++Received message from udp:127.0.0.1:8081: UDP Message +- : unit = () +``` + +Handling one UDP packet using IPv6: + +```ocaml +# run (run_dgram Eio.Net.Ipaddr.V6.loopback);; ++Waiting to receive data on udp:[::1]:8082 ++Sending data from udp:[::1]:8081 to udp:[::1]:8082 ++Received message from udp:[::1]:8081: UDP Message +- : unit = () +``` + +Now test host-assigned addresses. +`run_dgram2` is like `run_dgram` above, but doesn't print the sender address +since it will be different in each run: + +```ocaml +let run_dgram2 ~e1 addr ~net sw = + let server_addr = `Udp (addr, 8082) in + let listening_socket = Eio.Net.datagram_socket ~sw net server_addr in + Fiber.both + (fun () -> + let buf = Cstruct.create 20 in + traceln "Waiting to receive data on %a" Eio.Net.Sockaddr.pp server_addr; + let addr, recv = Eio.Net.recv listening_socket buf in + traceln "Received message %s" (Cstruct.(to_string (sub buf 0 recv))) + ) + (fun () -> + let e = Eio.Net.datagram_socket ~sw net e1 in + traceln "Sending data to %a" Eio.Net.Sockaddr.pp server_addr; + Eio.Net.send e ~dst:server_addr [Cstruct.of_string "UDP Message"]);; +``` + +Handling one UDP packet using IPv4: + +```ocaml +# let addr = Eio.Net.Ipaddr.V4.loopback in + run @@ run_dgram2 addr ~e1:`UdpV4;; ++Waiting to receive data on udp:127.0.0.1:8082 ++Sending data to udp:127.0.0.1:8082 ++Received message UDP Message +- : unit = () +``` + +Handling one UDP packet using IPv6: + +```ocaml +# let addr = Eio.Net.Ipaddr.V6.loopback in + run @@ run_dgram2 addr ~e1:`UdpV6;; ++Waiting to receive data on udp:[::1]:8082 ++Sending data to udp:[::1]:8082 ++Received message UDP Message +- : unit = () +``` + +It's not an error to close the socket before the handler returns: + +```ocaml +# run @@ fun ~net sw -> + let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8083) in + let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in + Fiber.both + (fun () -> + Eio.Net.accept_fork server ~sw ~on_error:raise @@ fun flow _addr -> + traceln "Server got connection"; + Eio.Flow.copy_string "Hi" flow; + Eio.Flow.close flow + ) + (fun () -> + traceln "Connecting to server..."; + let flow = Eio.Net.connect ~sw net addr in + let msg = Eio.Buf_read.(parse_exn take_all) flow ~max_size:100 in + traceln "Client got %S" msg; + );; ++Connecting to server... ++Server got connection ++Client got "Hi" +- : unit = () +``` + +## Unix interop + +Extracting file descriptors from Eio objects: + +```ocaml +# run @@ fun ~net sw -> + let server = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:5 addr in + traceln "Listening socket has Unix FD: %b" (Eio_unix.Resource.fd_opt server <> None); + let have_client, have_server = + Fiber.pair + (fun () -> + let flow = Eio.Net.connect ~sw net addr in + (Eio_unix.Resource.fd_opt flow <> None) + ) + (fun () -> + let flow, _addr = Eio.Net.accept ~sw server in + (Eio_unix.Resource.fd_opt flow <> None) + ) + in + traceln "Client-side socket has Unix FD: %b" have_client; + traceln "Server-side socket has Unix FD: %b" have_server;; ++Listening socket has Unix FD: true ++Client-side socket has Unix FD: true ++Server-side socket has Unix FD: true +- : unit = () +``` + +Check we can convert Eio IP addresses to Unix: + +```ocaml +# Eio.Net.Ipaddr.V4.loopback |> Eio_unix.Net.Ipaddr.to_unix |> Unix.string_of_inet_addr;; +- : string = "127.0.0.1" +# Eio.Net.Ipaddr.V4.any |> Eio_unix.Net.Ipaddr.to_unix |> Unix.string_of_inet_addr;; +- : string = "0.0.0.0" +# Eio.Net.Ipaddr.V6.loopback |> Eio_unix.Net.Ipaddr.to_unix |> Unix.string_of_inet_addr;; +- : string = "::1" +# Eio.Net.Ipaddr.V6.any |> Eio_unix.Net.Ipaddr.to_unix |> Unix.string_of_inet_addr;; +- : string = "::" +``` + +Check we can convert Unix IP addresses to Eio: + +```ocaml +# Eio_main.run @@ fun _ -> + let show x = traceln "%a" Eio.Net.Ipaddr.pp (Eio_unix.Net.Ipaddr.of_unix (Unix.inet_addr_of_string x)) in + show "127.0.0.1"; + show "0.0.0.0"; + show "1234:5678:9abc:def0:fedc:ba98:7654:3210"; + show "::1"; + show "::"; + show "ab::"; + show "::ffff:192.168.1.3"; + show "1:0:0:2:0:0:0:3"; + show "4:1:0:0:2:0:0:3";; ++127.0.0.1 ++0.0.0.0 ++1234:5678:9abc:def0:fedc:ba98:7654:3210 ++::1 ++:: ++ab:: ++::ffff:192.168.1.3 ++1:0:0:2::3 ++4:1::2:0:0:3 +- : unit = () +``` + +Printing addresses with ports: + +```ocaml +# let show host port = + let host = Eio_unix.Net.Ipaddr.of_unix (Unix.inet_addr_of_string host) in + traceln "%a" Eio.Net.Sockaddr.pp (`Tcp (host, port)) + in + Eio_main.run @@ fun env -> + show "127.0.0.1" 8080; + show "::1" 8080;; ++tcp:127.0.0.1:8080 ++tcp:[::1]:8080 +- : unit = () +``` + +Wrapping a Unix FD as an Eio stream socket: + +```ocaml +# Eio_main.run @@ fun _ -> + Switch.run @@ fun sw -> + let r, w = Unix.pipe () in + let source = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true r :> _ Eio.Flow.source) in + let sink = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true w :> _ Eio.Flow.sink) in + Fiber.both + (fun () -> Eio.Flow.copy_string "Hello\n!" sink) + (fun () -> + let b = Eio.Buf_read.of_flow source ~max_size:1000 in + traceln "Got: %S" (Eio.Buf_read.line b) + );; ++Got: "Hello" +- : unit = () +``` + +Wrapping a Unix FD as a listening Eio socket: + +```ocaml +# run @@ fun ~net sw -> + let l = Unix.(socket PF_INET SOCK_STREAM 0) in + Unix.bind l (Unix.ADDR_INET (Unix.inet_addr_loopback, 8082)); + Unix.listen l 40; + let l = Eio_unix.Net.import_socket_listening ~sw ~close_unix:true l in + Fiber.both + (fun () -> run_server ~sw l) + (fun () -> + run_client ~sw ~net ~addr:(`Tcp (Eio.Net.Ipaddr.V4.loopback, 8082)); + traceln "Client finished - cancelling server"; + raise Graceful_shutdown + );; ++Connecting to server... ++Server accepted connection from client ++Server received: "Hello from client" ++Client received: "Bye" ++Client finished - cancelling server +Exception: Graceful_shutdown. +``` + +Wrapping a Unix FD as an datagram Eio socket: + +```ocaml +# Eio_main.run @@ fun _ -> + Switch.run @@ fun sw -> + let a, b = Unix.(socketpair PF_UNIX SOCK_DGRAM 0) in + let a = Eio_unix.Net.import_socket_datagram ~sw ~close_unix:true a in + let b = Eio_unix.Net.import_socket_datagram ~sw ~close_unix:true b in + Fiber.both + (fun () -> Eio.Net.send a Cstruct.[of_string "12"; of_string "34"]) + (fun () -> + let buf = Cstruct.create 10 in + let addr, len = Eio.Net.recv b buf in + traceln "Got: %S" (Cstruct.to_string buf ~len) + );; ++Got: "1234" +- : unit = () +``` + +## Accept_fork error handling + +On success, we close the connection immediately: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let socket = Eio_mock.Net.listening_socket "tcp/80" in + let flow = Eio_mock.Flow.make "connection" in + let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 1234) in + Eio_mock.Net.on_accept socket [`Return (flow, addr)]; + Switch.run @@ fun sw -> + Eio.Net.accept_fork ~sw ~on_error:raise socket + (fun _flow _addr -> ()); + traceln "Mock connection should have been closed by now";; ++tcp/80: accepted connection from tcp:127.0.0.1:1234 ++connection: closed ++Mock connection should have been closed by now +- : unit = () +``` +If the forked fiber fails, we close immediately: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let socket = Eio_mock.Net.listening_socket "tcp/80" in + let flow = Eio_mock.Flow.make "connection" in + let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 1234) in + Eio_mock.Net.on_accept socket [`Return (flow, addr)]; + Switch.run @@ fun sw -> + Eio.Net.accept_fork ~sw ~on_error:raise socket + (fun _flow _addr -> failwith "Simulated error"); + traceln "Mock connection should have been closed by now";; ++tcp/80: accepted connection from tcp:127.0.0.1:1234 ++connection: closed ++Mock connection should have been closed by now +Exception: Failure "Simulated error". +``` +If the fork itself fails, we still close the connection: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let socket = Eio_mock.Net.listening_socket "tcp/80" in + let flow = Eio_mock.Flow.make "connection" in + let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 1234) in + Eio_mock.Net.on_accept socket [`Return (flow, addr)]; + Switch.run @@ fun sw -> + Switch.fail sw (Failure "Simulated error"); + Eio.Net.accept_fork ~sw ~on_error:raise socket + (fun _flow _addr -> assert false); + traceln "Mock connection should have been closed by now";; ++tcp/80: accepted connection from tcp:127.0.0.1:1234 ++connection: closed ++Mock connection should have been closed by now +Exception: Failure "Simulated error". +``` + +`accept_fork` doesn't send cancellations to `on_error`: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let socket = Eio_mock.Net.listening_socket "tcp/80" in + let flow = Eio_mock.Flow.make "connection" in + let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 1234) in + Eio_mock.Net.on_accept socket [`Return (flow, addr)]; + Switch.run @@ fun sw -> + Eio.Net.accept_fork ~sw ~on_error:(traceln "BUG: %a" Fmt.exn) socket + (fun _flow _addr -> Fiber.await_cancel ()); + Switch.fail sw (Failure "Simulated error");; ++tcp/80: accepted connection from tcp:127.0.0.1:1234 ++connection: closed +Exception: Failure "Simulated error". +``` + +## Socketpair + +```ocaml +# Eio_main.run @@ fun _ -> + Switch.run @@ fun sw -> + let a, b = Eio_unix.Net.socketpair_stream ~sw () in + ignore (Eio_unix.Net.fd a : Eio_unix.Fd.t); + ignore (Eio_unix.Net.fd b : Eio_unix.Fd.t); + Eio.Flow.copy_string "foo" a; + Eio.Flow.close a; + let msg = Eio.Buf_read.of_flow b ~max_size:10 |> Eio.Buf_read.take_all in + traceln "Got: %S" msg;; ++Got: "foo" +- : unit = () +``` +## Errors + +ECONNRESET: + +```ocaml +# Eio_main.run @@ fun _ -> + Switch.run @@ fun sw -> + let a, b = Eio_unix.Net.socketpair_stream ~sw () in + Eio.Flow.copy_string "foo" a; + Eio.Flow.close b; (* Close without reading *) + try + Eio.Flow.read_exact a (Cstruct.create 1); + assert false + with + | Eio.Io (Eio.Net.E Connection_reset _, _) + | End_of_file -> traceln "Connection failed (good)";; ++Connection failed (good) +- : unit = () +``` + +EPIPE: + +```ocaml +# Eio_main.run @@ fun _ -> + Switch.run @@ fun sw -> + let a, b = Eio_unix.Net.socketpair_stream ~sw () in + Eio.Flow.close b; + try + Eio.Flow.copy_string "foo" a; + assert false + with Eio.Io (Eio.Net.E Connection_reset _, _) -> traceln "Connection failed (good)";; ++Connection failed (good) +- : unit = () +``` + +Connection refused: + +```ocaml +# Eio_main.run @@ fun env -> + Switch.run @@ fun sw -> + Eio.Net.connect ~sw env#net (`Unix "idontexist.sock");; +Exception: Eio.Io Fs Not_found _, + connecting to unix:idontexist.sock +``` + +## Shutdown + +```ocaml +# Eio_main.run @@ fun _ -> + Switch.run @@ fun sw -> + let a, b = Eio_unix.Net.socketpair_stream ~sw () in + Fiber.both + (fun () -> + match Eio.Flow.read_exact a (Cstruct.create 1) with + | () -> failwith "Should have ended!" + | exception End_of_file -> () + ) + (fun () -> Eio.Flow.shutdown a `Receive);; +- : unit = () +``` + +## Getaddrinfo + +```ocaml +# Eio_main.run @@ fun env -> + Eio.Net.getaddrinfo_stream env#net "127.0.0.1";; +- : Eio.Net.Sockaddr.stream list = [`Tcp ("\127\000\000\001", 0)] +``` + +```ocaml +# Eio_main.run @@ fun env -> + Eio.Net.getaddrinfo_stream env#net "127.0.0.1" ~service:"80";; +- : Eio.Net.Sockaddr.stream list = [`Tcp ("\127\000\000\001", 80)] +``` + +```ocaml +# Eio_main.run @@ fun env -> + Eio.Net.getaddrinfo_datagram env#net "127.0.0.1";; +- : Eio.Net.Sockaddr.datagram list = [`Udp ("\127\000\000\001", 0)] +``` + +```ocaml +# Eio_main.run @@ fun env -> + Eio.Net.getaddrinfo_datagram env#net "127.0.0.1" ~service:"80";; +- : Eio.Net.Sockaddr.datagram list = [`Udp ("\127\000\000\001", 80)] +``` + + +```ocaml +# Eio_main.run @@ fun env -> + Eio.Net.getaddrinfo ~service:"http" env#net "127.0.0.1";; +- : Eio.Net.Sockaddr.t list = +[`Tcp ("\127\000\000\001", 80); `Udp ("\127\000\000\001", 80)] +``` + + +```ocaml +# Eio_main.run @@ fun env -> + Eio.Net.getaddrinfo ~service:"ftp" env#net "127.0.0.1";; +- : Eio.Net.Sockaddr.t list = +[`Tcp ("\127\000\000\001", 21); `Udp ("\127\000\000\001", 21)] +``` + + +```ocaml +# Eio_main.run @@ fun env -> + Eio.Net.getaddrinfo ~service:"https" env#net "google.com";; +- : Eio.Net.Sockaddr.t list = +[`Tcp ("�:��", 443); `Udp ("�:��", 443); + `Tcp ("*\000\020P@\t\b \000\000\000\000\000\000 \014", 443); + `Udp ("*\000\020P@\t\b \000\000\000\000\000\000 \014", 443)] +``` + +## getnameinfo + +```ocaml +# Eio_main.run @@ fun env -> + let sockaddr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 80) in + Eio.Net.getnameinfo env#net sockaddr;; +- : string * string = ("localhost", "http") +``` + +## with_tcp_connet + +```ocaml +let net = Eio_mock.Net.make "mock-net" +let addr1 = `Tcp (Eio.Net.Ipaddr.V4.loopback, 80) +let addr2 = `Tcp (Eio.Net.Ipaddr.of_raw "\001\002\003\004", 8080) +let connection_failure = Eio.Net.err (Connection_failure (Refused Eio_mock.Simulated_failure)) +``` + +No usable addresses: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Net.on_getaddrinfo net [`Return [`Unix "/foo"]]; + Eio.Net.with_tcp_connect ~host:"www.example.com" ~service:"http" net (fun _ -> assert false);; ++mock-net: getaddrinfo ~service:http www.example.com +Exception: +Eio.Io Net Connection_failure No_matching_addresses, + connecting to "www.example.com":http +``` + +First address works: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; + let mock_flow = Eio_mock.Flow.make "flow" in + Eio_mock.Net.on_connect net [`Return mock_flow]; + Eio.Net.with_tcp_connect ~host:"www.example.com" ~service:"http" net (fun conn -> + let req = "GET / HTTP/1.1\r\nHost:www.example.com:80\r\n\r\n" in + Eio.Flow.copy_string req conn + );; ++mock-net: getaddrinfo ~service:http www.example.com ++mock-net: connect to tcp:127.0.0.1:80 ++flow: wrote "GET / HTTP/1.1\r\n" ++ "Host:www.example.com:80\r\n" ++ "\r\n" ++flow: closed +- : unit = () +``` + +Second address works: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; + let mock_flow = Eio_mock.Flow.make "flow" in + Eio_mock.Net.on_connect net [`Raise connection_failure; + `Return mock_flow]; + Eio.Net.with_tcp_connect ~host:"www.example.com" ~service:"http" net (fun conn -> + let req = "GET / HTTP/1.1\r\nHost:www.example.com:80\r\n\r\n" in + Eio.Flow.copy_string req conn + );; ++mock-net: getaddrinfo ~service:http www.example.com ++mock-net: connect to tcp:127.0.0.1:80 ++mock-net: connect to tcp:1.2.3.4:8080 ++flow: wrote "GET / HTTP/1.1\r\n" ++ "Host:www.example.com:80\r\n" ++ "\r\n" ++flow: closed +- : unit = () +``` + +Both addresses fail: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; + Eio_mock.Net.on_connect net [`Raise connection_failure; `Raise connection_failure]; + Eio.Net.with_tcp_connect ~host:"www.example.com" ~service:"http" net (fun _ -> assert false);; ++mock-net: getaddrinfo ~service:http www.example.com ++mock-net: connect to tcp:127.0.0.1:80 ++mock-net: connect to tcp:1.2.3.4:8080 +Exception: +Eio.Io Net Connection_failure Refused _, + connecting to tcp:1.2.3.4:8080, + connecting to "www.example.com":http +``` + +First attempt times out: + +```ocaml +# Eio_mock.Backend.run_full @@ fun env -> + let clock = env#mono_clock in + let timeout = Eio.Time.Timeout.seconds clock 10. in + Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; + let mock_flow = Eio_mock.Flow.make "flow" in + Eio_mock.Net.on_connect net [`Run Fiber.await_cancel; `Return mock_flow]; + Eio.Net.with_tcp_connect ~timeout ~host:"www.example.com" ~service:"http" net (fun conn -> + let req = "GET / HTTP/1.1\r\nHost:www.example.com:80\r\n\r\n" in + Eio.Flow.copy_string req conn + ) ++mock-net: getaddrinfo ~service:http www.example.com ++mock-net: connect to tcp:127.0.0.1:80 ++mock time is now 10 ++mock-net: connect to tcp:1.2.3.4:8080 ++flow: wrote "GET / HTTP/1.1\r\n" ++ "Host:www.example.com:80\r\n" ++ "\r\n" ++flow: closed +- : unit = () +``` + +Both attempts time out: + +```ocaml +# Eio_mock.Backend.run_full @@ fun env -> + let clock = env#mono_clock in + let timeout = Eio.Time.Timeout.seconds clock 10. in + Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]]; + Eio_mock.Net.on_connect net [`Run Fiber.await_cancel; `Run Fiber.await_cancel]; + Eio.Net.with_tcp_connect ~timeout ~host:"www.example.com" ~service:"http" net (fun _ -> + assert false + ) ++mock-net: getaddrinfo ~service:http www.example.com ++mock-net: connect to tcp:127.0.0.1:80 ++mock time is now 10 ++mock-net: connect to tcp:1.2.3.4:8080 ++mock time is now 20 +Exception: +Eio.Io Net Connection_failure Timeout, + connecting to "www.example.com":http +``` + +## read/write on SOCK_DGRAM + +```ocaml +# Eio_main.run @@ fun _ -> + Switch.run @@ fun sw -> + let a, b = Eio_unix.Net.socketpair_datagram ~sw ~domain:Unix.PF_UNIX () in + ignore (Eio_unix.Net.fd a : Eio_unix.Fd.t); + ignore (Eio_unix.Net.fd b : Eio_unix.Fd.t); + let l = [ "foo"; "bar"; "foobar"; "cellar door"; "" ] in + let buf = Cstruct.create 32 in + let write bufs = Eio.Net.send a (List.map Cstruct.of_string bufs) in + let read () = + let _addr, n = Eio.Net.recv b buf in + traceln "Got: %d bytes: %S" n Cstruct.(to_string (sub buf 0 n)) + in + List.iter (fun sbuf -> write [sbuf]) l; + List.iter (fun _ -> read ()) l; + write ["abaca"; "bb"]; + read (); + Eio.Flow.close a; + Eio.Flow.close b;; ++Got: 3 bytes: "foo" ++Got: 3 bytes: "bar" ++Got: 6 bytes: "foobar" ++Got: 11 bytes: "cellar door" ++Got: 0 bytes: "" ++Got: 7 bytes: "abacabb" +- : unit = () +``` + + +## run_server + +A simple connection handler for testing: +```ocaml +let handle_connection flow _addr = + let msg = read_all flow in + assert (msg = "Hi"); + Fiber.yield (); + Eio.Flow.copy_string "Bye" flow +``` + +A mock listening socket that allows acceping `n_clients` clients, each of which writes "Hi", +and then allows `n_domains` further attempts, none of which ever completes: + +```ocaml +let mock_listener ~n_clients ~n_domains = + let make_flow i () = + if n_domains > 1 then Fiber.yield () (* Load balance *) + else Fiber.check (); + let flow = Eio_mock.Flow.make ("flow" ^ string_of_int i) in + Eio_mock.Flow.on_read flow [`Return "Hi"; `Raise End_of_file]; + flow, `Tcp (Eio.Net.Ipaddr.V4.loopback, 30000 + i) + in + let listening_socket = Eio_mock.Net.listening_socket "tcp/80" in + Eio_mock.Net.on_accept listening_socket ( + List.init n_clients (fun i -> `Run (make_flow i)) @ + List.init n_domains (fun _ -> `Run Fiber.await_cancel) + ); + listening_socket +``` + +Start handling the connections, then begin a graceful shutdown, +allowing the connections to finish and then exiting: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let listening_socket = mock_listener ~n_clients:3 ~n_domains:1 in + let stop, set_stop = Promise.create () in + Fiber.both + (fun () -> + Eio.Net.run_server listening_socket handle_connection + ~max_connections:10 + ~on_error:raise + ~stop + ) + (fun () -> + traceln "Begin graceful shutdown"; + Promise.resolve set_stop () + );; ++tcp/80: accepted connection from tcp:127.0.0.1:30000 ++flow0: read "Hi" ++tcp/80: accepted connection from tcp:127.0.0.1:30001 ++flow1: read "Hi" ++tcp/80: accepted connection from tcp:127.0.0.1:30002 ++flow2: read "Hi" ++Begin graceful shutdown ++flow0: wrote "Bye" ++flow0: closed ++flow1: wrote "Bye" ++flow1: closed ++flow2: wrote "Bye" ++flow2: closed +- : unit = () +``` + +Non-graceful shutdown, closing all connections still in progress: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let listening_socket = mock_listener ~n_clients:3 ~n_domains:1 in + Fiber.both + (fun () -> + Eio.Net.run_server listening_socket handle_connection + ~max_connections:10 + ~on_error:raise + ) + (fun () -> failwith "Simulated error");; ++tcp/80: accepted connection from tcp:127.0.0.1:30000 ++flow0: read "Hi" ++tcp/80: accepted connection from tcp:127.0.0.1:30001 ++flow1: read "Hi" ++tcp/80: accepted connection from tcp:127.0.0.1:30002 ++flow2: read "Hi" ++flow0: closed ++flow1: closed ++flow2: closed +Exception: Failure "Simulated error". +``` + +Handling the connections with 3 domains, with a graceful shutdown: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Domain_manager.run @@ fun fake_domain_mgr -> + let n_domains = 3 in + let listening_socket = mock_listener ~n_clients:10 ~n_domains in + let stop, set_stop = Promise.create () in + Fiber.both + (fun () -> + Eio.Net.run_server listening_socket handle_connection + ~additional_domains:(fake_domain_mgr, n_domains - 1) + ~max_connections:10 + ~on_error:raise + ~stop + ) + (fun () -> + Fiber.yield (); + Promise.resolve set_stop (); + Fiber.yield (); (* Allow fibers to receive shutdown request *) + traceln "Requested graceful shutdown" + );; ++[1] tcp/80: accepted connection from tcp:127.0.0.1:30000 ++[1] flow0: read "Hi" ++[2] tcp/80: accepted connection from tcp:127.0.0.1:30001 ++[2] flow1: read "Hi" ++[0] tcp/80: accepted connection from tcp:127.0.0.1:30002 ++[0] flow2: read "Hi" ++[1] flow0: wrote "Bye" ++[1] flow0: closed ++[1] tcp/80: accepted connection from tcp:127.0.0.1:30003 ++[1] flow3: read "Hi" ++[2] flow1: wrote "Bye" ++[2] flow1: closed ++[2] tcp/80: accepted connection from tcp:127.0.0.1:30004 ++[2] flow4: read "Hi" ++[0] flow2: wrote "Bye" ++[0] flow2: closed ++[0] tcp/80: accepted connection from tcp:127.0.0.1:30005 ++[0] flow5: read "Hi" ++[0] Requested graceful shutdown ++[1] flow3: wrote "Bye" ++[1] flow3: closed ++[2] flow4: wrote "Bye" ++[2] flow4: closed ++[0] flow5: wrote "Bye" ++[0] flow5: closed +- : unit = () +``` + +Handling the connections with 3 domains, aborting immediately: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Domain_manager.run @@ fun fake_domain_mgr -> + let n_domains = 3 in + let listening_socket = mock_listener ~n_clients:10 ~n_domains in + Fiber.both + (fun () -> + Eio.Net.run_server listening_socket handle_connection + ~additional_domains:(fake_domain_mgr, n_domains - 1) + ~max_connections:10 + ~on_error:raise + ) + (fun () -> Fiber.yield (); failwith "Simulated error");; ++[1] tcp/80: accepted connection from tcp:127.0.0.1:30000 ++[1] flow0: read "Hi" ++[2] tcp/80: accepted connection from tcp:127.0.0.1:30001 ++[2] flow1: read "Hi" ++[0] tcp/80: accepted connection from tcp:127.0.0.1:30002 ++[0] flow2: read "Hi" ++[1] flow0: closed ++[2] flow1: closed ++[0] flow2: closed +Exception: Failure "Simulated error". +``` + +Limiting to 2 concurrent connections: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let listening_socket = mock_listener ~n_clients:10 ~n_domains:1 in + let stop, set_stop = Promise.create () in + Fiber.both + (fun () -> + Eio.Net.run_server listening_socket handle_connection + ~max_connections:2 + ~on_error:raise + ~stop + ) + (fun () -> + for _ = 1 to 2 do Fiber.yield () done; + traceln "Begin graceful shutdown"; + Promise.resolve set_stop () + );; ++tcp/80: accepted connection from tcp:127.0.0.1:30000 ++flow0: read "Hi" ++tcp/80: accepted connection from tcp:127.0.0.1:30001 ++flow1: read "Hi" ++flow0: wrote "Bye" ++flow0: closed ++flow1: wrote "Bye" ++flow1: closed ++tcp/80: accepted connection from tcp:127.0.0.1:30002 ++flow2: read "Hi" ++tcp/80: accepted connection from tcp:127.0.0.1:30003 ++flow3: read "Hi" ++Begin graceful shutdown ++flow2: wrote "Bye" ++flow2: closed ++flow3: wrote "Bye" ++flow3: closed +- : unit = () +``` + +We keep the polymorphism when using a Unix network: + +```ocaml +let _check_types ~(net:Eio_unix.Net.t) = + Switch.run @@ fun sw -> + let addr = `Unix "/socket" in + let server : [`Generic | `Unix] Eio.Net.listening_socket_ty r = + Eio.Net.listen ~sw net addr ~backlog:5 + in + Eio.Net.accept_fork ~sw ~on_error:raise server + (fun (_flow : [`Generic | `Unix] Eio.Net.stream_socket_ty r) _addr -> assert false); + let _client : [`Generic | `Unix] Eio.Net.stream_socket_ty r = Eio.Net.connect ~sw net addr in + ();; +``` diff --git a/tests/nounix/dune b/tests/nounix/dune index 12d81c312..774a17e6f 100644 --- a/tests/nounix/dune +++ b/tests/nounix/dune @@ -1,5 +1,5 @@ -(test - (name nounix) - (package eio) - (forbidden_libraries unix) - (libraries eio)) +(test + (name nounix) + (package eio) + (forbidden_libraries unix) + (libraries eio)) diff --git a/tests/nounix/nounix.ml b/tests/nounix/nounix.ml index f0af7e6cf..cc8c77c41 100644 --- a/tests/nounix/nounix.ml +++ b/tests/nounix/nounix.ml @@ -1,5 +1,5 @@ -(* This module checks that Eio doesn't pull in a dependency on Unix. - See the [dune] file. *) - -let () = - assert (Eio.Buf_read.(parse_string_exn take_all) "hi" = "hi") +(* This module checks that Eio doesn't pull in a dependency on Unix. + See the [dune] file. *) + +let () = + assert (Eio.Buf_read.(parse_string_exn take_all) "hi" = "hi") diff --git a/tests/pool.md b/tests/pool.md index c19c361c8..28a173881 100644 --- a/tests/pool.md +++ b/tests/pool.md @@ -1,234 +1,234 @@ -# Setting up the environment - -```ocaml -# #require "eio.mock";; -``` - -```ocaml -open Eio.Std - -module P = Eio.Pool - -let dispose x = traceln "disposing %d" x - -let create ?validate ?dispose n items = - let items = Array.of_list items in - let i = ref 0 in - P.create ?validate ?dispose n (fun () -> - traceln "Creating item %d" !i; - let p = items.(!i) in - incr i; - Promise.await_exn p - ) -``` - -# Test cases - -Simple case: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let t = create 1 [Promise.create_resolved (Ok 0)] in - P.use t (fun x -> traceln "Using item %d" x); - P.use t (fun x -> traceln "Using item %d" x); -+Creating item 0 -+Using item 0 -+Using item 0 -- : unit = () -``` - -Two uses with a capacity of 1; the second must wait: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let p, r = Promise.create () in - let t = create 1 [p] in - Fiber.all [ - (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield (); traceln "A done")); - (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield (); traceln "B done")); - (fun () -> Promise.resolve r (Ok 0)); - ]; -+Creating item 0 -+A: using item 0 -+A done -+B: using item 0 -+B done -- : unit = () -``` - -Two uses with a capacity of 2; they run in parallel: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let p0, r0 = Promise.create () in - let p1, r1 = Promise.create () in - let t = create 2 [p0; p1] in - Fiber.all [ - (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield (); traceln "A done")); - (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield (); traceln "B done")); - (fun () -> Promise.resolve r0 (Ok 0); Promise.resolve r1 (Ok 1)); - ]; -+Creating item 0 -+A: using item 0 -+Creating item 1 -+B: using item 1 -+A done -+B done -- : unit = () -``` - -Capacity of 1; two uses that cannot block and two normal uses; first 2 are parallel, next 2 are sequential. -Note that the pool always suspends the calling fiber when creating a new slot, -even if the fiber ends up providing the new slot to itself, -which is why the items get assigned out of order in this test. - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let p0, r0 = Promise.create () in - let p1, r1 = Promise.create () in - let t = create 1 [p0; p1] ~dispose in - Fiber.all [ - (fun () -> P.use t ~never_block:true (fun x -> traceln "A: using item %d" x; Fiber.yield (); traceln "A done")); - (fun () -> P.use t ~never_block:true (fun x -> traceln "B: using item %d" x; Fiber.yield (); traceln "B done")); - (fun () -> P.use t (fun x -> traceln "C: using item %d" x; Fiber.yield (); traceln "C done")); - (fun () -> P.use t (fun x -> traceln "D: using item %d" x; Fiber.yield (); traceln "D done")); - (fun () -> Promise.resolve r0 (Ok 0); Promise.resolve r1 (Ok 1)); - ]; -+Creating item 0 -+Creating item 1 -+A: using item 1 -+B: using item 0 -+A done -+B done -+disposing 0 -+C: using item 1 -+C done -+D: using item 1 -+D done -- : unit = () -``` - -## Cancellation - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let p, r = Promise.create () in - let t = create 1 [p] in - Fiber.all [ - (fun () -> P.use t (fun _ -> assert false)); (* Waits for the creation to finish *) - (fun () -> P.use t (fun _ -> assert false)); (* Waits for the item to be returned *) - (fun () -> failwith "Simulated error"); - ]; -+Creating item 0 -Exception: Failure "Simulated error". -``` - -## Error handling - -On error, the resource is still returned to the pool: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let t = create 1 [Promise.create_resolved (Ok 0)] in - begin - try P.use t (fun x -> traceln "Using item %d" x; failwith "Simulated error") - with Failure msg -> traceln "Failed: %s" msg - end; - P.use t (fun x -> traceln "Using item %d" x); -+Creating item 0 -+Using item 0 -+Failed: Simulated error -+Using item 0 -- : unit = () -``` - -Two fibers are trying to use a resource and one is being created. -When the creation function fails, the first fiber reports the error, -and also wakes the second fiber, which tries again: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let p, r = Promise.create () in - let t = create 1 [p; Promise.create_resolved (Ok 1)] in - Switch.run @@ fun sw -> - let a = Fiber.fork_promise ~sw (fun () -> P.use t (fun i -> traceln "A: using item %d" i)) in - Fiber.both - (fun () -> P.use t (fun i -> traceln "B: using item %d" i)) - (fun () -> Promise.resolve_error r (Failure "Simulated creation failure")); - Promise.await_exn a -+Creating item 0 -+Creating item 1 -+B: using item 1 -Exception: Failure "Simulated creation failure". -``` - -## Validation - -The second time a resource is used, we check it is still valid: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let validate x = - let ok = (x land 1) = 0 in - traceln "validate %d => %b" x ok; - ok - in - let t = create ~validate ~dispose 2 [ - Promise.create_resolved (Ok 0); - Promise.create_resolved (Ok 1); - Promise.create_resolved (Ok 2); - ] in - Fiber.all [ - (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield ())); - (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield ())); - (fun () -> P.use t (fun x -> traceln "C: using item %d" x; Fiber.yield ())); - (fun () -> P.use t (fun x -> traceln "D: using item %d" x; Fiber.yield ())); - ] -+Creating item 0 -+A: using item 0 -+Creating item 1 -+B: using item 1 -+validate 0 => true -+C: using item 0 -+validate 1 => false -+disposing 1 -+Creating item 2 -+D: using item 2 -- : unit = () -``` - -Dispose fails. We report the error, but still recreate the resource next time: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - let validate x = - let ok = (x land 1) = 1 in - traceln "validate %d => %b" x ok; - ok - in - let dispose x = Fmt.failwith "Simulated error disposing %d" x in - let t = create ~validate ~dispose 1 [ - Promise.create_resolved (Ok 0); - Promise.create_resolved (Ok 1); - Promise.create_resolved (Ok 2); - ] in - begin - try - Fiber.both - (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield ())) - (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield ())) - with Failure msg -> traceln "Failed: %s" msg - end; - Fiber.both - (fun () -> P.use t (fun x -> traceln "C: using item %d" x; Fiber.yield ())) - (fun () -> P.use t (fun x -> traceln "D: using item %d" x; Fiber.yield ())) -+Creating item 0 -+A: using item 0 -+validate 0 => false -+Failed: Simulated error disposing 0 -+Creating item 1 -+C: using item 1 -+validate 1 => true -+D: using item 1 -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio.mock";; +``` + +```ocaml +open Eio.Std + +module P = Eio.Pool + +let dispose x = traceln "disposing %d" x + +let create ?validate ?dispose n items = + let items = Array.of_list items in + let i = ref 0 in + P.create ?validate ?dispose n (fun () -> + traceln "Creating item %d" !i; + let p = items.(!i) in + incr i; + Promise.await_exn p + ) +``` + +# Test cases + +Simple case: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let t = create 1 [Promise.create_resolved (Ok 0)] in + P.use t (fun x -> traceln "Using item %d" x); + P.use t (fun x -> traceln "Using item %d" x); ++Creating item 0 ++Using item 0 ++Using item 0 +- : unit = () +``` + +Two uses with a capacity of 1; the second must wait: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let p, r = Promise.create () in + let t = create 1 [p] in + Fiber.all [ + (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield (); traceln "A done")); + (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield (); traceln "B done")); + (fun () -> Promise.resolve r (Ok 0)); + ]; ++Creating item 0 ++A: using item 0 ++A done ++B: using item 0 ++B done +- : unit = () +``` + +Two uses with a capacity of 2; they run in parallel: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let p0, r0 = Promise.create () in + let p1, r1 = Promise.create () in + let t = create 2 [p0; p1] in + Fiber.all [ + (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield (); traceln "A done")); + (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield (); traceln "B done")); + (fun () -> Promise.resolve r0 (Ok 0); Promise.resolve r1 (Ok 1)); + ]; ++Creating item 0 ++A: using item 0 ++Creating item 1 ++B: using item 1 ++A done ++B done +- : unit = () +``` + +Capacity of 1; two uses that cannot block and two normal uses; first 2 are parallel, next 2 are sequential. +Note that the pool always suspends the calling fiber when creating a new slot, +even if the fiber ends up providing the new slot to itself, +which is why the items get assigned out of order in this test. + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let p0, r0 = Promise.create () in + let p1, r1 = Promise.create () in + let t = create 1 [p0; p1] ~dispose in + Fiber.all [ + (fun () -> P.use t ~never_block:true (fun x -> traceln "A: using item %d" x; Fiber.yield (); traceln "A done")); + (fun () -> P.use t ~never_block:true (fun x -> traceln "B: using item %d" x; Fiber.yield (); traceln "B done")); + (fun () -> P.use t (fun x -> traceln "C: using item %d" x; Fiber.yield (); traceln "C done")); + (fun () -> P.use t (fun x -> traceln "D: using item %d" x; Fiber.yield (); traceln "D done")); + (fun () -> Promise.resolve r0 (Ok 0); Promise.resolve r1 (Ok 1)); + ]; ++Creating item 0 ++Creating item 1 ++A: using item 1 ++B: using item 0 ++A done ++B done ++disposing 0 ++C: using item 1 ++C done ++D: using item 1 ++D done +- : unit = () +``` + +## Cancellation + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let p, r = Promise.create () in + let t = create 1 [p] in + Fiber.all [ + (fun () -> P.use t (fun _ -> assert false)); (* Waits for the creation to finish *) + (fun () -> P.use t (fun _ -> assert false)); (* Waits for the item to be returned *) + (fun () -> failwith "Simulated error"); + ]; ++Creating item 0 +Exception: Failure "Simulated error". +``` + +## Error handling + +On error, the resource is still returned to the pool: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let t = create 1 [Promise.create_resolved (Ok 0)] in + begin + try P.use t (fun x -> traceln "Using item %d" x; failwith "Simulated error") + with Failure msg -> traceln "Failed: %s" msg + end; + P.use t (fun x -> traceln "Using item %d" x); ++Creating item 0 ++Using item 0 ++Failed: Simulated error ++Using item 0 +- : unit = () +``` + +Two fibers are trying to use a resource and one is being created. +When the creation function fails, the first fiber reports the error, +and also wakes the second fiber, which tries again: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let p, r = Promise.create () in + let t = create 1 [p; Promise.create_resolved (Ok 1)] in + Switch.run @@ fun sw -> + let a = Fiber.fork_promise ~sw (fun () -> P.use t (fun i -> traceln "A: using item %d" i)) in + Fiber.both + (fun () -> P.use t (fun i -> traceln "B: using item %d" i)) + (fun () -> Promise.resolve_error r (Failure "Simulated creation failure")); + Promise.await_exn a ++Creating item 0 ++Creating item 1 ++B: using item 1 +Exception: Failure "Simulated creation failure". +``` + +## Validation + +The second time a resource is used, we check it is still valid: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let validate x = + let ok = (x land 1) = 0 in + traceln "validate %d => %b" x ok; + ok + in + let t = create ~validate ~dispose 2 [ + Promise.create_resolved (Ok 0); + Promise.create_resolved (Ok 1); + Promise.create_resolved (Ok 2); + ] in + Fiber.all [ + (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield ())); + (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield ())); + (fun () -> P.use t (fun x -> traceln "C: using item %d" x; Fiber.yield ())); + (fun () -> P.use t (fun x -> traceln "D: using item %d" x; Fiber.yield ())); + ] ++Creating item 0 ++A: using item 0 ++Creating item 1 ++B: using item 1 ++validate 0 => true ++C: using item 0 ++validate 1 => false ++disposing 1 ++Creating item 2 ++D: using item 2 +- : unit = () +``` + +Dispose fails. We report the error, but still recreate the resource next time: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + let validate x = + let ok = (x land 1) = 1 in + traceln "validate %d => %b" x ok; + ok + in + let dispose x = Fmt.failwith "Simulated error disposing %d" x in + let t = create ~validate ~dispose 1 [ + Promise.create_resolved (Ok 0); + Promise.create_resolved (Ok 1); + Promise.create_resolved (Ok 2); + ] in + begin + try + Fiber.both + (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield ())) + (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield ())) + with Failure msg -> traceln "Failed: %s" msg + end; + Fiber.both + (fun () -> P.use t (fun x -> traceln "C: using item %d" x; Fiber.yield ())) + (fun () -> P.use t (fun x -> traceln "D: using item %d" x; Fiber.yield ())) ++Creating item 0 ++A: using item 0 ++validate 0 => false ++Failed: Simulated error disposing 0 ++Creating item 1 ++C: using item 1 ++validate 1 => true ++D: using item 1 +- : unit = () +``` diff --git a/tests/process.md b/tests/process.md index 165c461e0..4d71ff5f2 100644 --- a/tests/process.md +++ b/tests/process.md @@ -1,209 +1,209 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -``` - -Creating some useful helper functions - -```ocaml -open Eio.Std - -module Flow = Eio.Flow -module Process = Eio.Process - -let () = Eio.Exn.Backend.show := false - -let ( / ) = Eio.Path.( / ) - -let run ?clear:(paths = []) fn = - Eio_main.run @@ fun env -> - let cwd = Eio.Stdenv.cwd env in - List.iter (fun p -> Eio.Path.rmtree ~missing_ok:true (cwd / p)) paths; - fn env#process_mgr env - -let status_to_string = Fmt.to_to_string Eio.Process.pp_status -``` - -Running a program as a subprocess: - -```ocaml -# run @@ fun mgr _env -> - Switch.run @@ fun sw -> - let t = Process.spawn ~sw mgr [ "echo"; "hello world" ] in - Process.await t;; -hello world -- : Process.exit_status = `Exited 0 -``` - -Stopping a subprocess works and checking the status waits and reports correctly: - -```ocaml -# run @@ fun mgr _env -> - Switch.run @@ fun sw -> - let t = Process.spawn ~sw mgr [ "sleep"; "10" ] in - Process.signal t Sys.sigkill; - Process.await t |> status_to_string -- : string = "Exited (signal SIGKILL)" -``` - -A switch will stop a process when it is released: - -```ocaml -# run @@ fun mgr env -> - let proc = Switch.run (fun sw -> Process.spawn ~sw mgr [ "sleep"; "10" ]) in - Process.await proc |> status_to_string -- : string = "Exited (signal SIGKILL)" -``` - -Passing in flows allows you to redirect the child process' stdout: - -```ocaml -# run ~clear:["process-test.txt"] @@ fun mgr env -> - let fs = Eio.Stdenv.fs env in - let path = fs / "process-test.txt" in - Eio.Path.(with_open_out ~create:(`Exclusive 0o600) path) @@ fun stdout -> - Process.run mgr ~stdout [ "echo"; "Hello" ]; - Eio.Path.(load path);; -- : string = "Hello\n" -``` - -Piping data to and from the child: - -```ocaml -# run @@ fun mgr env -> - let stdin = Eio.Flow.string_source "one\ntwo\nthree\n" in - Process.parse_out mgr Eio.Buf_read.line ~stdin ["wc"; "-l"] |> String.trim;; -- : string = "3" -``` - -Spawning subprocesses in new domains works normally: - -```ocaml -# run @@ fun mgr env -> - Eio.Domain_manager.run env#domain_mgr @@ fun () -> - Process.run mgr [ "echo"; "Hello from another domain" ];; -Hello from another domain -- : unit = () -``` - -Calling `await_exit` multiple times on the same spawn just returns the status: - -```ocaml -# run @@ fun mgr env -> - Switch.run @@ fun sw -> - let t = Process.spawn ~sw mgr [ "echo"; "hello world" ] in - (Process.await t, Process.await t, Process.await t);; -hello world -- : Process.exit_status * Process.exit_status * Process.exit_status = -(`Exited 0, `Exited 0, `Exited 0) -``` - -Using a sink that is not backed by a file descriptor: - -```ocaml -# run @@ fun mgr env -> - let buf = Buffer.create 16 in - Eio.Process.run mgr ~stdout:(Flow.buffer_sink buf) [ "echo"; "Hello, world" ]; - Buffer.contents buf -- : string = "Hello, world\n" -``` - -Changing directory (unconfined): - -```ocaml -# run @@ fun mgr env -> - let root = env#fs / "/" in - Process.run mgr ~cwd:root [ "env"; "pwd" ];; -/ -- : unit = () -``` - -Changing directory (confined): - -```ocaml -# run ~clear:["proc-sub-dir"] @@ fun mgr env -> - let cwd = Eio.Stdenv.cwd env in - let subdir = cwd / "proc-sub-dir" in - Eio.Path.mkdir subdir ~perm:0o700; - Eio.Path.with_open_dir subdir @@ fun subdir -> - Eio.Path.save (subdir / "test-cwd") "test-data" ~create:(`Exclusive 0o600); - Process.run mgr ~cwd:subdir [ "cat"; "test-cwd" ];; -test-data -- : unit = () -``` - -Trying to access a path outside of the cwd: - -```ocaml -# run @@ fun mgr env -> - Process.run mgr ~cwd:(env#cwd / "..") [ "cat"; "test-cwd" ];; -Exception: Eio.Io Fs Permission_denied _ -``` - -If a command fails, we get shown the arguments (quoted if necessary): - -```ocaml -# run @@ fun mgr env -> - Process.run mgr ["bash"; "-c"; "exit 3"; ""; "foo"; "\"bar\""];; -Exception: -Eio.Io Process Child_error Exited (code 3), - running command: bash -c "exit 3" "" foo "\"bar\"" -``` - -Exit code success can be determined by is_success (Process.run): - -```ocaml -# run @@ fun mgr env -> - Process.run ~is_success:(Int.equal 3) mgr ["bash"; "-c"; "exit 3"];; -- : unit = () - -# run @@ fun mgr env -> - Process.run ~is_success:(Int.equal 3) mgr ["bash"; "-c"; "exit 0"];; -Exception: -Eio.Io Process Child_error Exited (code 0), - running command: bash -c "exit 0" -``` - -Exit code success can be determined by is_success (Process.parse_out): - -```ocaml -# run @@ fun mgr env -> - Process.parse_out ~is_success:(Int.equal 5) mgr Eio.Buf_read.line ["sh"; "-c"; "echo 123; exit 5"];; -- : string = "123" -``` - -The default environment: - -```ocaml -# run @@ fun mgr env -> - Unix.putenv "DISPLAY" ":1"; - Process.parse_out mgr Eio.Buf_read.line ["sh"; "-c"; "echo $DISPLAY"];; -- : string = ":1" -``` - -A custom environment: - -```ocaml -# run @@ fun mgr env -> - let env = [| "DISPLAY=:2" |] in - Process.parse_out mgr Eio.Buf_read.line ["sh"; "-c"; "echo $DISPLAY"] ~env;; -- : string = ":2" -``` - -Eio's child reaping code doesn't interfere with OCaml's process spawning: - -```ocaml -let rec waitpid_with_retry flags pid = - try Unix.waitpid flags pid - with Unix.Unix_error(Unix.EINTR, _, _) -> waitpid_with_retry flags pid -``` - -```ocaml -# Eio_main.run @@ fun env -> - let p = Unix.(create_process "/usr/bin/env" [|"env"; "echo"; "hi"|] stdin stdout stderr) in - Eio.Time.Mono.sleep env#mono_clock 0.01; - waitpid_with_retry [] p |> snd;; -hi -- : Unix.process_status = Unix.WEXITED 0 -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +``` + +Creating some useful helper functions + +```ocaml +open Eio.Std + +module Flow = Eio.Flow +module Process = Eio.Process + +let () = Eio.Exn.Backend.show := false + +let ( / ) = Eio.Path.( / ) + +let run ?clear:(paths = []) fn = + Eio_main.run @@ fun env -> + let cwd = Eio.Stdenv.cwd env in + List.iter (fun p -> Eio.Path.rmtree ~missing_ok:true (cwd / p)) paths; + fn env#process_mgr env + +let status_to_string = Fmt.to_to_string Eio.Process.pp_status +``` + +Running a program as a subprocess: + +```ocaml +# run @@ fun mgr _env -> + Switch.run @@ fun sw -> + let t = Process.spawn ~sw mgr [ "echo"; "hello world" ] in + Process.await t;; +hello world +- : Process.exit_status = `Exited 0 +``` + +Stopping a subprocess works and checking the status waits and reports correctly: + +```ocaml +# run @@ fun mgr _env -> + Switch.run @@ fun sw -> + let t = Process.spawn ~sw mgr [ "sleep"; "10" ] in + Process.signal t Sys.sigkill; + Process.await t |> status_to_string +- : string = "Exited (signal SIGKILL)" +``` + +A switch will stop a process when it is released: + +```ocaml +# run @@ fun mgr env -> + let proc = Switch.run (fun sw -> Process.spawn ~sw mgr [ "sleep"; "10" ]) in + Process.await proc |> status_to_string +- : string = "Exited (signal SIGKILL)" +``` + +Passing in flows allows you to redirect the child process' stdout: + +```ocaml +# run ~clear:["process-test.txt"] @@ fun mgr env -> + let fs = Eio.Stdenv.fs env in + let path = fs / "process-test.txt" in + Eio.Path.(with_open_out ~create:(`Exclusive 0o600) path) @@ fun stdout -> + Process.run mgr ~stdout [ "echo"; "Hello" ]; + Eio.Path.(load path);; +- : string = "Hello\n" +``` + +Piping data to and from the child: + +```ocaml +# run @@ fun mgr env -> + let stdin = Eio.Flow.string_source "one\ntwo\nthree\n" in + Process.parse_out mgr Eio.Buf_read.line ~stdin ["wc"; "-l"] |> String.trim;; +- : string = "3" +``` + +Spawning subprocesses in new domains works normally: + +```ocaml +# run @@ fun mgr env -> + Eio.Domain_manager.run env#domain_mgr @@ fun () -> + Process.run mgr [ "echo"; "Hello from another domain" ];; +Hello from another domain +- : unit = () +``` + +Calling `await_exit` multiple times on the same spawn just returns the status: + +```ocaml +# run @@ fun mgr env -> + Switch.run @@ fun sw -> + let t = Process.spawn ~sw mgr [ "echo"; "hello world" ] in + (Process.await t, Process.await t, Process.await t);; +hello world +- : Process.exit_status * Process.exit_status * Process.exit_status = +(`Exited 0, `Exited 0, `Exited 0) +``` + +Using a sink that is not backed by a file descriptor: + +```ocaml +# run @@ fun mgr env -> + let buf = Buffer.create 16 in + Eio.Process.run mgr ~stdout:(Flow.buffer_sink buf) [ "echo"; "Hello, world" ]; + Buffer.contents buf +- : string = "Hello, world\n" +``` + +Changing directory (unconfined): + +```ocaml +# run @@ fun mgr env -> + let root = env#fs / "/" in + Process.run mgr ~cwd:root [ "env"; "pwd" ];; +/ +- : unit = () +``` + +Changing directory (confined): + +```ocaml +# run ~clear:["proc-sub-dir"] @@ fun mgr env -> + let cwd = Eio.Stdenv.cwd env in + let subdir = cwd / "proc-sub-dir" in + Eio.Path.mkdir subdir ~perm:0o700; + Eio.Path.with_open_dir subdir @@ fun subdir -> + Eio.Path.save (subdir / "test-cwd") "test-data" ~create:(`Exclusive 0o600); + Process.run mgr ~cwd:subdir [ "cat"; "test-cwd" ];; +test-data +- : unit = () +``` + +Trying to access a path outside of the cwd: + +```ocaml +# run @@ fun mgr env -> + Process.run mgr ~cwd:(env#cwd / "..") [ "cat"; "test-cwd" ];; +Exception: Eio.Io Fs Permission_denied _ +``` + +If a command fails, we get shown the arguments (quoted if necessary): + +```ocaml +# run @@ fun mgr env -> + Process.run mgr ["bash"; "-c"; "exit 3"; ""; "foo"; "\"bar\""];; +Exception: +Eio.Io Process Child_error Exited (code 3), + running command: bash -c "exit 3" "" foo "\"bar\"" +``` + +Exit code success can be determined by is_success (Process.run): + +```ocaml +# run @@ fun mgr env -> + Process.run ~is_success:(Int.equal 3) mgr ["bash"; "-c"; "exit 3"];; +- : unit = () + +# run @@ fun mgr env -> + Process.run ~is_success:(Int.equal 3) mgr ["bash"; "-c"; "exit 0"];; +Exception: +Eio.Io Process Child_error Exited (code 0), + running command: bash -c "exit 0" +``` + +Exit code success can be determined by is_success (Process.parse_out): + +```ocaml +# run @@ fun mgr env -> + Process.parse_out ~is_success:(Int.equal 5) mgr Eio.Buf_read.line ["sh"; "-c"; "echo 123; exit 5"];; +- : string = "123" +``` + +The default environment: + +```ocaml +# run @@ fun mgr env -> + Unix.putenv "DISPLAY" ":1"; + Process.parse_out mgr Eio.Buf_read.line ["sh"; "-c"; "echo $DISPLAY"];; +- : string = ":1" +``` + +A custom environment: + +```ocaml +# run @@ fun mgr env -> + let env = [| "DISPLAY=:2" |] in + Process.parse_out mgr Eio.Buf_read.line ["sh"; "-c"; "echo $DISPLAY"] ~env;; +- : string = ":2" +``` + +Eio's child reaping code doesn't interfere with OCaml's process spawning: + +```ocaml +let rec waitpid_with_retry flags pid = + try Unix.waitpid flags pid + with Unix.Unix_error(Unix.EINTR, _, _) -> waitpid_with_retry flags pid +``` + +```ocaml +# Eio_main.run @@ fun env -> + let p = Unix.(create_process "/usr/bin/env" [|"env"; "echo"; "hi"|] stdin stdout stderr) in + Eio.Time.Mono.sleep env#mono_clock 0.01; + waitpid_with_retry [] p |> snd;; +hi +- : Unix.process_status = Unix.WEXITED 0 +``` diff --git a/tests/random.md b/tests/random.md index dc53d95d7..0888586c0 100644 --- a/tests/random.md +++ b/tests/random.md @@ -1,22 +1,22 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -``` - -```ocaml -open Eio.Std -``` - -# Basic check for randomness - -```ocaml -# Eio_main.run @@ fun env -> - let src = Eio.Stdenv.secure_random env in - let b1 = Cstruct.create 8 in - let b2 = Cstruct.create 8 in - Eio.Flow.read_exact src b1; - Eio.Flow.read_exact src b2; - assert (not (Cstruct.equal b1 b2));; -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +``` + +```ocaml +open Eio.Std +``` + +# Basic check for randomness + +```ocaml +# Eio_main.run @@ fun env -> + let src = Eio.Stdenv.secure_random env in + let b1 = Cstruct.create 8 in + let b2 = Cstruct.create 8 in + Eio.Flow.read_exact src b1; + Eio.Flow.read_exact src b2; + assert (not (Cstruct.equal b1 b2));; +- : unit = () +``` diff --git a/tests/semaphore.md b/tests/semaphore.md index 53066f84e..09690f9f3 100644 --- a/tests/semaphore.md +++ b/tests/semaphore.md @@ -1,96 +1,96 @@ -# Setting up the environment - -```ocaml -# #require "eio.mock";; -``` - -```ocaml -open Eio.Std - -module T = Eio.Semaphore - -let run fn = - Eio_mock.Backend.run @@ fun _ -> - fn () - -let acquire t = - traceln "Acquiring"; - T.acquire t; - traceln "Acquired" - -let release t = - traceln "Releasing"; - T.release t; - traceln "Released" -``` - -# Test cases - -Simple case: - -```ocaml -# run @@ fun () -> - let t = T.make 1 in - acquire t; - release t; - acquire t; - release t;; -+Acquiring -+Acquired -+Releasing -+Released -+Acquiring -+Acquired -+Releasing -+Released -- : unit = () -``` - -Concurrent access to the semaphore: - -```ocaml -# run @@ fun () -> - let t = T.make 2 in - let fn () = - acquire t; - Eio.Fiber.yield (); - release t - in - List.init 4 (fun _ -> fn) - |> Fiber.all;; -+Acquiring -+Acquired -+Acquiring -+Acquired -+Acquiring -+Acquiring -+Releasing -+Released -+Releasing -+Released -+Acquired -+Acquired -+Releasing -+Released -+Releasing -+Released -- : unit = () -``` - -Cancellation: - -```ocaml -# run @@ fun () -> - let t = T.make 0 in - Fiber.first - (fun () -> acquire t) - (fun () -> ()); - release t; - acquire t;; -+Acquiring -+Releasing -+Released -+Acquiring -+Acquired -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio.mock";; +``` + +```ocaml +open Eio.Std + +module T = Eio.Semaphore + +let run fn = + Eio_mock.Backend.run @@ fun _ -> + fn () + +let acquire t = + traceln "Acquiring"; + T.acquire t; + traceln "Acquired" + +let release t = + traceln "Releasing"; + T.release t; + traceln "Released" +``` + +# Test cases + +Simple case: + +```ocaml +# run @@ fun () -> + let t = T.make 1 in + acquire t; + release t; + acquire t; + release t;; ++Acquiring ++Acquired ++Releasing ++Released ++Acquiring ++Acquired ++Releasing ++Released +- : unit = () +``` + +Concurrent access to the semaphore: + +```ocaml +# run @@ fun () -> + let t = T.make 2 in + let fn () = + acquire t; + Eio.Fiber.yield (); + release t + in + List.init 4 (fun _ -> fn) + |> Fiber.all;; ++Acquiring ++Acquired ++Acquiring ++Acquired ++Acquiring ++Acquiring ++Releasing ++Released ++Releasing ++Released ++Acquired ++Acquired ++Releasing ++Released ++Releasing ++Released +- : unit = () +``` + +Cancellation: + +```ocaml +# run @@ fun () -> + let t = T.make 0 in + Fiber.first + (fun () -> acquire t) + (fun () -> ()); + release t; + acquire t;; ++Acquiring ++Releasing ++Released ++Acquiring ++Acquired +- : unit = () +``` diff --git a/tests/signal.md b/tests/signal.md index 0d1b5567d..4ace3972c 100644 --- a/tests/signal.md +++ b/tests/signal.md @@ -1,42 +1,42 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -# open Eio.Std;; -``` - -# Test cases - -Prove we can catch sigint: -```ocaml -# Eio_main.run @@ fun _stdenv -> - let interrupted = Eio.Condition.create () in - let old = Sys.signal Sys.sigint - (Signal_handle (fun num -> if num = Sys.sigint then Eio.Condition.broadcast interrupted)) - in - Fiber.both - (fun () -> - Eio.Condition.await_no_mutex interrupted; - traceln "interrupted!"; - ) - (fun () -> - let ppid = Unix.getpid () in - match Unix.fork () with - | 0 -> - Unix.kill ppid Sys.sigint; - Unix._exit 0 - | child_pid -> - let rec wait () = - match Unix.waitpid [] child_pid with - | pid, status -> - assert (pid = child_pid); - assert (status = (Unix.WEXITED 0)) - | exception Unix.Unix_error (EINTR, _, _) -> wait () - | exception Unix.Unix_error (ECHILD, _, _) -> () (* Hack until we have a cross-platform process API *) - in - wait () - ); - Sys.set_signal Sys.sigint old;; -+interrupted! -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +# open Eio.Std;; +``` + +# Test cases + +Prove we can catch sigint: +```ocaml +# Eio_main.run @@ fun _stdenv -> + let interrupted = Eio.Condition.create () in + let old = Sys.signal Sys.sigint + (Signal_handle (fun num -> if num = Sys.sigint then Eio.Condition.broadcast interrupted)) + in + Fiber.both + (fun () -> + Eio.Condition.await_no_mutex interrupted; + traceln "interrupted!"; + ) + (fun () -> + let ppid = Unix.getpid () in + match Unix.fork () with + | 0 -> + Unix.kill ppid Sys.sigint; + Unix._exit 0 + | child_pid -> + let rec wait () = + match Unix.waitpid [] child_pid with + | pid, status -> + assert (pid = child_pid); + assert (status = (Unix.WEXITED 0)) + | exception Unix.Unix_error (EINTR, _, _) -> wait () + | exception Unix.Unix_error (ECHILD, _, _) -> () (* Hack until we have a cross-platform process API *) + in + wait () + ); + Sys.set_signal Sys.sigint old;; ++interrupted! +- : unit = () +``` diff --git a/tests/stream.md b/tests/stream.md index c5a035e3b..80bd0cbba 100644 --- a/tests/stream.md +++ b/tests/stream.md @@ -1,359 +1,359 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -``` - -```ocaml -open Eio.Std - -module S = Eio.Stream - -exception Cancel - -let run fn = - Eio_main.run @@ fun _ -> - fn () - -let add t v = - traceln "Adding %d to stream" v; - S.add t v; - traceln "Added %d to stream" v - -let take t = - traceln "Reading from stream"; - traceln "Got %d from stream" (S.take t) - -let take_nonblocking t = - traceln "Reading from stream"; - traceln "Got %a from stream" Fmt.(option ~none:(any "None") int) (S.take_nonblocking t) -``` - -# Test cases - -Simple non-blocking case - -```ocaml -# run @@ fun () -> - let t = S.create 2 in - add t 1; - add t 2; - take t; - take t;; -+Adding 1 to stream -+Added 1 to stream -+Adding 2 to stream -+Added 2 to stream -+Reading from stream -+Got 1 from stream -+Reading from stream -+Got 2 from stream -- : unit = () -``` - -Readers have to wait when the stream is empty: - -```ocaml -# run @@ fun () -> - let t = S.create 2 in - add t 1; - Fiber.both - (fun () -> take t; take t) - (fun () -> add t 2);; -+Adding 1 to stream -+Added 1 to stream -+Reading from stream -+Got 1 from stream -+Reading from stream -+Adding 2 to stream -+Added 2 to stream -+Got 2 from stream -- : unit = () -``` - -Writers have to wait when the stream is full: - -```ocaml -# run @@ fun () -> - let t = S.create 3 in - add t 1; - Fiber.both - (fun () -> - add t 2; - add t 3; - add t 4; - ) - (fun () -> - take t; - take t; - take t; - take t - );; -+Adding 1 to stream -+Added 1 to stream -+Adding 2 to stream -+Added 2 to stream -+Adding 3 to stream -+Added 3 to stream -+Adding 4 to stream -+Reading from stream -+Got 1 from stream -+Reading from stream -+Got 2 from stream -+Reading from stream -+Got 3 from stream -+Reading from stream -+Got 4 from stream -+Added 4 to stream -- : unit = () -``` - -A zero-length queue is synchronous: - -```ocaml -# run @@ fun () -> - let t = S.create 0 in - Fiber.both - (fun () -> - add t 1; - add t 2; - ) - (fun () -> - take t; - take t; - );; -+Adding 1 to stream -+Reading from stream -+Got 1 from stream -+Reading from stream -+Added 1 to stream -+Adding 2 to stream -+Added 2 to stream -+Got 2 from stream -- : unit = () -``` - -Cancel reading from a stream: - -```ocaml -# run @@ fun () -> - let t = S.create 1 in - try - Fiber.both - (fun () -> take t) - (fun () -> raise Cancel); - assert false; - with Cancel -> - traceln "Cancelled"; - add t 2; - take t;; -+Reading from stream -+Cancelled -+Adding 2 to stream -+Added 2 to stream -+Reading from stream -+Got 2 from stream -- : unit = () -``` - -Cancel writing to a stream: - -```ocaml -# run @@ fun () -> - let t = S.create 1 in - try - Fiber.both - (fun () -> add t 1; add t 2) - (fun () -> raise Cancel); - assert false; - with Cancel -> - traceln "Cancelled"; - take t; - add t 3; - take t;; -+Adding 1 to stream -+Added 1 to stream -+Adding 2 to stream -+Cancelled -+Reading from stream -+Got 1 from stream -+Adding 3 to stream -+Added 3 to stream -+Reading from stream -+Got 3 from stream -- : unit = () -``` - -Cancel writing to a zero-length stream: - -```ocaml -# run @@ fun () -> - let t = S.create 0 in - try - Fiber.both - (fun () -> add t 1) - (fun () -> raise Cancel); - assert false; - with Cancel -> - traceln "Cancelled"; - Fiber.both - (fun () -> add t 2) - (fun () -> take t);; -+Adding 1 to stream -+Cancelled -+Adding 2 to stream -+Reading from stream -+Got 2 from stream -+Added 2 to stream -- : unit = () -``` - -Trying to use a stream with a cancelled context: - -```ocaml -# run @@ fun () -> - let t = S.create 0 in - Eio.Cancel.sub @@ fun c -> - Eio.Cancel.cancel c Cancel; - begin try add t 1 with ex -> traceln "%a" Fmt.exn ex end; - begin try take t with ex -> traceln "%a" Fmt.exn ex end; - (* Check we released the mutex correctly: *) - Eio.Cancel.protect @@ fun () -> - Fiber.both - (fun () -> add t 1) - (fun () -> take t) - ;; -+Adding 1 to stream -+Cancelled: Cancel -+Reading from stream -+Cancelled: Cancel -+Adding 1 to stream -+Reading from stream -+Got 1 from stream -+Added 1 to stream -- : unit = () -``` - -Readers queue up: - -```ocaml -# run @@ fun () -> - let t = S.create 0 in - Switch.run @@ fun sw -> - Fiber.fork ~sw (fun () -> take t; traceln "a done"); - Fiber.fork ~sw (fun () -> take t; traceln "b done"); - Fiber.fork ~sw (fun () -> take t; traceln "c done"); - add t 1; - add t 2; - add t 3;; -+Reading from stream -+Reading from stream -+Reading from stream -+Adding 1 to stream -+Added 1 to stream -+Adding 2 to stream -+Added 2 to stream -+Adding 3 to stream -+Added 3 to stream -+Got 1 from stream -+a done -+Got 2 from stream -+b done -+Got 3 from stream -+c done -- : unit = () -``` - -Writers queue up: - -```ocaml -# run @@ fun () -> - let t = S.create 0 in - Switch.run @@ fun sw -> - Fiber.fork ~sw (fun () -> add t 1); - Fiber.fork ~sw (fun () -> add t 2); - Fiber.fork ~sw (fun () -> add t 3); - take t; - take t; - take t;; -+Adding 1 to stream -+Adding 2 to stream -+Adding 3 to stream -+Reading from stream -+Got 1 from stream -+Reading from stream -+Got 2 from stream -+Reading from stream -+Got 3 from stream -+Added 1 to stream -+Added 2 to stream -+Added 3 to stream -- : unit = () -``` - -Cancelling writing to a stream: - -```ocaml -# run @@ fun () -> - let t = S.create 1 in - add t 0; - Switch.run @@ fun sw -> - try - Fiber.both - (fun () -> add t 1) - (fun () -> raise Cancel) - with Cancel -> - traceln "Cancelled"; - take t; - add t 2; - take t;; -+Adding 0 to stream -+Added 0 to stream -+Adding 1 to stream -+Cancelled -+Reading from stream -+Got 0 from stream -+Adding 2 to stream -+Added 2 to stream -+Reading from stream -+Got 2 from stream -- : unit = () -``` - -Non-blocking take: - -```ocaml -# run @@ fun () -> - let t = S.create 1 in - take_nonblocking t; - add t 0; - take_nonblocking t;; -+Reading from stream -+Got None from stream -+Adding 0 to stream -+Added 0 to stream -+Reading from stream -+Got 0 from stream -- : unit = () -``` - -Non-blocking take with zero-capacity stream: - -```ocaml -# run @@ fun () -> - let t = S.create 0 in - take_nonblocking t; - Fiber.both - (fun () -> add t 0) - (fun () -> take_nonblocking t); - take_nonblocking t;; -+Reading from stream -+Got None from stream -+Adding 0 to stream -+Reading from stream -+Got 0 from stream -+Added 0 to stream -+Reading from stream -+Got None from stream -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +``` + +```ocaml +open Eio.Std + +module S = Eio.Stream + +exception Cancel + +let run fn = + Eio_main.run @@ fun _ -> + fn () + +let add t v = + traceln "Adding %d to stream" v; + S.add t v; + traceln "Added %d to stream" v + +let take t = + traceln "Reading from stream"; + traceln "Got %d from stream" (S.take t) + +let take_nonblocking t = + traceln "Reading from stream"; + traceln "Got %a from stream" Fmt.(option ~none:(any "None") int) (S.take_nonblocking t) +``` + +# Test cases + +Simple non-blocking case + +```ocaml +# run @@ fun () -> + let t = S.create 2 in + add t 1; + add t 2; + take t; + take t;; ++Adding 1 to stream ++Added 1 to stream ++Adding 2 to stream ++Added 2 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Got 2 from stream +- : unit = () +``` + +Readers have to wait when the stream is empty: + +```ocaml +# run @@ fun () -> + let t = S.create 2 in + add t 1; + Fiber.both + (fun () -> take t; take t) + (fun () -> add t 2);; ++Adding 1 to stream ++Added 1 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Adding 2 to stream ++Added 2 to stream ++Got 2 from stream +- : unit = () +``` + +Writers have to wait when the stream is full: + +```ocaml +# run @@ fun () -> + let t = S.create 3 in + add t 1; + Fiber.both + (fun () -> + add t 2; + add t 3; + add t 4; + ) + (fun () -> + take t; + take t; + take t; + take t + );; ++Adding 1 to stream ++Added 1 to stream ++Adding 2 to stream ++Added 2 to stream ++Adding 3 to stream ++Added 3 to stream ++Adding 4 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Got 2 from stream ++Reading from stream ++Got 3 from stream ++Reading from stream ++Got 4 from stream ++Added 4 to stream +- : unit = () +``` + +A zero-length queue is synchronous: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + Fiber.both + (fun () -> + add t 1; + add t 2; + ) + (fun () -> + take t; + take t; + );; ++Adding 1 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Added 1 to stream ++Adding 2 to stream ++Added 2 to stream ++Got 2 from stream +- : unit = () +``` + +Cancel reading from a stream: + +```ocaml +# run @@ fun () -> + let t = S.create 1 in + try + Fiber.both + (fun () -> take t) + (fun () -> raise Cancel); + assert false; + with Cancel -> + traceln "Cancelled"; + add t 2; + take t;; ++Reading from stream ++Cancelled ++Adding 2 to stream ++Added 2 to stream ++Reading from stream ++Got 2 from stream +- : unit = () +``` + +Cancel writing to a stream: + +```ocaml +# run @@ fun () -> + let t = S.create 1 in + try + Fiber.both + (fun () -> add t 1; add t 2) + (fun () -> raise Cancel); + assert false; + with Cancel -> + traceln "Cancelled"; + take t; + add t 3; + take t;; ++Adding 1 to stream ++Added 1 to stream ++Adding 2 to stream ++Cancelled ++Reading from stream ++Got 1 from stream ++Adding 3 to stream ++Added 3 to stream ++Reading from stream ++Got 3 from stream +- : unit = () +``` + +Cancel writing to a zero-length stream: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + try + Fiber.both + (fun () -> add t 1) + (fun () -> raise Cancel); + assert false; + with Cancel -> + traceln "Cancelled"; + Fiber.both + (fun () -> add t 2) + (fun () -> take t);; ++Adding 1 to stream ++Cancelled ++Adding 2 to stream ++Reading from stream ++Got 2 from stream ++Added 2 to stream +- : unit = () +``` + +Trying to use a stream with a cancelled context: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + Eio.Cancel.sub @@ fun c -> + Eio.Cancel.cancel c Cancel; + begin try add t 1 with ex -> traceln "%a" Fmt.exn ex end; + begin try take t with ex -> traceln "%a" Fmt.exn ex end; + (* Check we released the mutex correctly: *) + Eio.Cancel.protect @@ fun () -> + Fiber.both + (fun () -> add t 1) + (fun () -> take t) + ;; ++Adding 1 to stream ++Cancelled: Cancel ++Reading from stream ++Cancelled: Cancel ++Adding 1 to stream ++Reading from stream ++Got 1 from stream ++Added 1 to stream +- : unit = () +``` + +Readers queue up: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> take t; traceln "a done"); + Fiber.fork ~sw (fun () -> take t; traceln "b done"); + Fiber.fork ~sw (fun () -> take t; traceln "c done"); + add t 1; + add t 2; + add t 3;; ++Reading from stream ++Reading from stream ++Reading from stream ++Adding 1 to stream ++Added 1 to stream ++Adding 2 to stream ++Added 2 to stream ++Adding 3 to stream ++Added 3 to stream ++Got 1 from stream ++a done ++Got 2 from stream ++b done ++Got 3 from stream ++c done +- : unit = () +``` + +Writers queue up: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> add t 1); + Fiber.fork ~sw (fun () -> add t 2); + Fiber.fork ~sw (fun () -> add t 3); + take t; + take t; + take t;; ++Adding 1 to stream ++Adding 2 to stream ++Adding 3 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Got 2 from stream ++Reading from stream ++Got 3 from stream ++Added 1 to stream ++Added 2 to stream ++Added 3 to stream +- : unit = () +``` + +Cancelling writing to a stream: + +```ocaml +# run @@ fun () -> + let t = S.create 1 in + add t 0; + Switch.run @@ fun sw -> + try + Fiber.both + (fun () -> add t 1) + (fun () -> raise Cancel) + with Cancel -> + traceln "Cancelled"; + take t; + add t 2; + take t;; ++Adding 0 to stream ++Added 0 to stream ++Adding 1 to stream ++Cancelled ++Reading from stream ++Got 0 from stream ++Adding 2 to stream ++Added 2 to stream ++Reading from stream ++Got 2 from stream +- : unit = () +``` + +Non-blocking take: + +```ocaml +# run @@ fun () -> + let t = S.create 1 in + take_nonblocking t; + add t 0; + take_nonblocking t;; ++Reading from stream ++Got None from stream ++Adding 0 to stream ++Added 0 to stream ++Reading from stream ++Got 0 from stream +- : unit = () +``` + +Non-blocking take with zero-capacity stream: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + take_nonblocking t; + Fiber.both + (fun () -> add t 0) + (fun () -> take_nonblocking t); + take_nonblocking t;; ++Reading from stream ++Got None from stream ++Adding 0 to stream ++Reading from stream ++Got 0 from stream ++Added 0 to stream ++Reading from stream ++Got None from stream +- : unit = () +``` diff --git a/tests/switch.md b/tests/switch.md index 29a30c3e4..99f348f7d 100644 --- a/tests/switch.md +++ b/tests/switch.md @@ -1,423 +1,423 @@ -# Setting up the environment - -```ocaml -# #require "eio.mock";; -``` - -```ocaml -open Eio.Std - -let run (fn : Switch.t -> _) = - Eio_mock.Backend.run @@ fun () -> - Switch.run fn - -let fork_sub ~sw ~on_error fn = - Fiber.fork ~sw (fun () -> - try Switch.run fn - with - | Eio.Cancel.Cancelled _ -> () - | ex -> on_error ex - ) -``` - -# Test cases - -A very basic example: - -```ocaml -# run (fun _sw -> - traceln "Running" - );; -+Running -- : unit = () -``` - -Turning off a switch still allows you to perform clean-up operations: - -```ocaml -# run (fun sw -> - traceln "Running"; - Switch.fail sw (Failure "Cancel"); - traceln "Clean up" - );; -+Running -+Clean up -Exception: Failure "Cancel". -``` - -`Fiber.both`, both fibers pass: - -```ocaml -# run (fun _sw -> - Fiber.both - (fun () -> for i = 1 to 2 do traceln "i = %d" i; Fiber.yield () done) - (fun () -> for j = 1 to 2 do traceln "j = %d" j; Fiber.yield () done) - );; -+i = 1 -+j = 1 -+i = 2 -+j = 2 -- : unit = () -``` - -`Fiber.both`, only 1st succeeds: - -```ocaml -# run (fun sw -> - Fiber.both - (fun () -> for i = 1 to 5 do traceln "i = %d" i; Fiber.yield () done) - (fun () -> failwith "Failed") - );; -+i = 1 -Exception: Failure "Failed". -``` - -`Fiber.both`, only 2nd succeeds: - -```ocaml -# run (fun sw -> - Fiber.both - (fun () -> Fiber.yield (); failwith "Failed") - (fun () -> for i = 1 to 5 do traceln "i = %d" i; Fiber.yield () done) - );; -+i = 1 -Exception: Failure "Failed". -``` - -`Fiber.both`, first fails immediately and the other doesn't start: - -```ocaml -# run (fun sw -> - Fiber.both (fun () -> failwith "Failed") (fun () -> traceln "Second OK"); - traceln "Not reached" - );; -Exception: Failure "Failed". -``` - -`Fiber.both`, second fails but the other doesn't stop: - -```ocaml -# run (fun sw -> - Fiber.both ignore (fun () -> failwith "Failed"); - traceln "not reached" - );; -Exception: Failure "Failed". -``` - -`Fiber.both`, both fibers fail: - -```ocaml -# run (fun sw -> - Fiber.both - (fun () -> Eio.Cancel.protect Fiber.yield; failwith "Failed 1") - (fun () -> Eio.Cancel.protect Fiber.yield; failwith "Failed 2") - );; -Exception: Multiple exceptions: -- Failure("Failed 1") -- Failure("Failed 2") -``` - -The switch is already turned off when we try to fork. The new fiber doesn't start: - -```ocaml -# run (fun sw -> - Switch.fail sw (Failure "Cancel"); - Fiber.fork ~sw (fun () -> traceln "Not reached"); - traceln "Main continues" - );; -+Main continues -Exception: Failure "Cancel". -``` - -You can't use a switch after leaving its scope: - -```ocaml -# let sw = run Fun.id;; -val sw : Switch.t = -# Switch.check sw;; -Exception: Invalid_argument "Switch finished!". -``` - -Wait for either a promise or a cancellation; cancellation first: -```ocaml -# run (fun sw -> - let p, r = Promise.create () in - Fiber.fork ~sw (fun () -> - Fiber.both - (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved") - (fun () -> failwith "Cancelled") - ); - Fiber.yield (); - Promise.resolve r (); - traceln "Main thread done"; - );; -+Waiting -+Main thread done -Exception: Failure "Cancelled". -``` - -Wait for either a promise or a switch; promise resolves first: - -```ocaml -# run (fun sw -> - let p, r = Promise.create () in - Fiber.fork ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved"); - Promise.resolve r (); - Fiber.yield (); - traceln "Now cancelling..."; - Switch.fail sw (Failure "Cancelled") - );; -+Waiting -+Resolved -+Now cancelling... -Exception: Failure "Cancelled". -``` - -Wait for either a promise or a switch; switch cancelled first. Result version. - -```ocaml -# run (fun sw -> - let p, r = Promise.create () in - Fiber.fork ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved"); - Switch.fail sw (Failure "Cancelled"); - Promise.resolve r () - );; -+Waiting -Exception: Failure "Cancelled". -``` - -Wait for either a promise or a switch; promise resolves first but switch off without yielding: - -```ocaml -# run (fun sw -> - let p, r = Promise.create () in - Fiber.fork ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved"); - Promise.resolve r (); - traceln "Now cancelling..."; - Switch.fail sw (Failure "Cancelled") - );; -+Waiting -+Now cancelling... -+Resolved -Exception: Failure "Cancelled". -``` - -Child switches are cancelled when the parent is cancelled, but `on_error` isn't notified: - -```ocaml -# run (fun sw -> - let p, _ = Promise.create () in - let on_error ex = traceln "child: %s" (Printexc.to_string ex) in - fork_sub ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await p); - fork_sub ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await p); - Switch.fail sw (Failure "Cancel parent") - );; -+Child 1 -+Child 2 -Exception: Failure "Cancel parent". -``` - -A child can fail independently of the parent: - -```ocaml -# run (fun sw -> - let p1, r1 = Promise.create () in - let p2, r2 = Promise.create () in - let on_error ex = traceln "child: %s" (Printexc.to_string ex) in - fork_sub ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await_exn p1); - fork_sub ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await_exn p2); - Promise.resolve_error r1 (Failure "Child error"); - Promise.resolve_ok r2 (); - Fiber.yield (); - traceln "Parent fiber is still running" - );; -+Child 1 -+Child 2 -+child: Failure("Child error") -+Parent fiber is still running -- : unit = () -``` - -A child can be cancelled independently of the parent: - -```ocaml -# run (fun sw -> - let p, _ = Promise.create () in - let on_error ex = traceln "child: %s" (Printexc.to_string ex) in - let child = ref None in - fork_sub ~sw ~on_error (fun sw -> - traceln "Child 1"; - child := Some sw; - Promise.await ~sw p - ); - Switch.fail (Option.get !child) (Failure "Cancel child"); - Fiber.yield (); - traceln "Parent fiber is still running" - );; -+Child 1 -+child: Failure("Cancel child") -+Parent fiber is still running -- : unit = () -``` - -A child error handler raises: - -```ocaml -# run (fun sw -> - let p, r = Promise.create () in - let on_error = raise in - fork_sub ~sw ~on_error (fun sw -> traceln "Child"; Promise.await_exn p); - Promise.resolve_error r (Failure "Child error escapes"); - Fiber.yield (); - traceln "Not reached" - );; -+Child -Exception: Failure "Child error escapes". -``` - -A child error handler deals with the exception: - -```ocaml -# run (fun sw -> - let p, r = Promise.create () in - let on_error = traceln "caught: %a" Fmt.exn in - fork_sub ~sw ~on_error (fun sw -> traceln "Child"; Promise.await_exn p); - Promise.resolve_error r (Failure "Child error is caught"); - Fiber.yield (); - traceln "Still running" - );; -+Child -+caught: Failure("Child error is caught") -+Still running -- : unit = () -``` - -# Release handlers - -```ocaml -let release label = Fiber.yield (); traceln "release %s" label -``` - -Release on success: - -```ocaml -# run (fun sw -> - Switch.on_release sw (fun () -> release "1"); - Switch.on_release sw (fun () -> release "2"); - );; -+release 2 -+release 1 -- : unit = () -``` - -Release on error: - -```ocaml -# run (fun sw -> - Switch.on_release sw (fun () -> release "1"); - Switch.on_release sw (fun () -> release "2"); - failwith "Test error" - );; -+release 2 -+release 1 -Exception: Failure "Test error". -``` - -A release operation itself fails: - -```ocaml -# run (fun sw -> - Switch.on_release sw (fun () -> release "1"; failwith "failure 1"); - Switch.on_release sw (fun () -> release "2"); - Switch.on_release sw (fun () -> release "3"; failwith "failure 3"); - );; -+release 3 -+release 2 -+release 1 -Exception: Multiple exceptions: -- Failure("failure 3") -- Failure("failure 1") -``` - -Attaching a release handler to a finished switch from a cancelled context: - -```ocaml -# run @@ fun sw -> - let sub = Switch.run Fun.id in (* A finished switch *) - Switch.fail sw (Failure "Parent cancelled too!"); - Switch.on_release sub (fun () -> release "1");; -+release 1 -Exception: -Multiple exceptions: -- Failure("Parent cancelled too!") -- Invalid_argument("Switch finished!") -``` - -Attaching resources to a switch from inside release handler fails -(possibly forking with it should be disallowed in future too): - -```ocaml -# run (fun sw -> - Switch.on_release sw (fun () -> - Fiber.fork ~sw (fun () -> - traceln "Starting release 1"; - Fiber.yield (); - traceln "Finished release 1" - ); - ); - Switch.on_release sw (fun () -> - Fiber.fork ~sw (fun () -> - traceln "Starting release 2"; - begin - try - Switch.on_release sw (fun () -> traceln "Immediate release"); - with Invalid_argument msg -> - traceln "on_release refused: %s" msg - end; - Fiber.yield (); - traceln "Finished release 2" - ); - ); - traceln "Main fiber done" - );; -+Main fiber done -+Starting release 2 -+Immediate release -+on_release refused: Switch finished! -+Starting release 1 -+Finished release 2 -+Finished release 1 -- : unit = () -``` - -# Error reporting - -All release hooks run, even if some fail, and all errors are reported: - -```ocaml -# run (fun sw -> - Fiber.fork ~sw (fun () -> try Fiber.await_cancel () with _ -> failwith "cancel1 failed"); - Fiber.fork ~sw (fun () -> try Fiber.await_cancel () with _ -> failwith "cancel2 failed"); - raise Exit - );; -Exception: -Multiple exceptions: -- Stdlib.Exit -- Failure("cancel1 failed") -- Failure("cancel2 failed") -``` - -# Errors during cleanup are reported during cancellation - -```ocaml -# run (fun sw -> - Fiber.fork ~sw (fun () -> - Switch.run @@ fun sw -> - try Fiber.await_cancel () with _ -> failwith "cleanup failed"); - Fiber.fork ~sw (fun () -> failwith "simulated error") - );; -Exception: -Multiple exceptions: -- Failure("simulated error") -- Failure("cleanup failed") -``` +# Setting up the environment + +```ocaml +# #require "eio.mock";; +``` + +```ocaml +open Eio.Std + +let run (fn : Switch.t -> _) = + Eio_mock.Backend.run @@ fun () -> + Switch.run fn + +let fork_sub ~sw ~on_error fn = + Fiber.fork ~sw (fun () -> + try Switch.run fn + with + | Eio.Cancel.Cancelled _ -> () + | ex -> on_error ex + ) +``` + +# Test cases + +A very basic example: + +```ocaml +# run (fun _sw -> + traceln "Running" + );; ++Running +- : unit = () +``` + +Turning off a switch still allows you to perform clean-up operations: + +```ocaml +# run (fun sw -> + traceln "Running"; + Switch.fail sw (Failure "Cancel"); + traceln "Clean up" + );; ++Running ++Clean up +Exception: Failure "Cancel". +``` + +`Fiber.both`, both fibers pass: + +```ocaml +# run (fun _sw -> + Fiber.both + (fun () -> for i = 1 to 2 do traceln "i = %d" i; Fiber.yield () done) + (fun () -> for j = 1 to 2 do traceln "j = %d" j; Fiber.yield () done) + );; ++i = 1 ++j = 1 ++i = 2 ++j = 2 +- : unit = () +``` + +`Fiber.both`, only 1st succeeds: + +```ocaml +# run (fun sw -> + Fiber.both + (fun () -> for i = 1 to 5 do traceln "i = %d" i; Fiber.yield () done) + (fun () -> failwith "Failed") + );; ++i = 1 +Exception: Failure "Failed". +``` + +`Fiber.both`, only 2nd succeeds: + +```ocaml +# run (fun sw -> + Fiber.both + (fun () -> Fiber.yield (); failwith "Failed") + (fun () -> for i = 1 to 5 do traceln "i = %d" i; Fiber.yield () done) + );; ++i = 1 +Exception: Failure "Failed". +``` + +`Fiber.both`, first fails immediately and the other doesn't start: + +```ocaml +# run (fun sw -> + Fiber.both (fun () -> failwith "Failed") (fun () -> traceln "Second OK"); + traceln "Not reached" + );; +Exception: Failure "Failed". +``` + +`Fiber.both`, second fails but the other doesn't stop: + +```ocaml +# run (fun sw -> + Fiber.both ignore (fun () -> failwith "Failed"); + traceln "not reached" + );; +Exception: Failure "Failed". +``` + +`Fiber.both`, both fibers fail: + +```ocaml +# run (fun sw -> + Fiber.both + (fun () -> Eio.Cancel.protect Fiber.yield; failwith "Failed 1") + (fun () -> Eio.Cancel.protect Fiber.yield; failwith "Failed 2") + );; +Exception: Multiple exceptions: +- Failure("Failed 1") +- Failure("Failed 2") +``` + +The switch is already turned off when we try to fork. The new fiber doesn't start: + +```ocaml +# run (fun sw -> + Switch.fail sw (Failure "Cancel"); + Fiber.fork ~sw (fun () -> traceln "Not reached"); + traceln "Main continues" + );; ++Main continues +Exception: Failure "Cancel". +``` + +You can't use a switch after leaving its scope: + +```ocaml +# let sw = run Fun.id;; +val sw : Switch.t = +# Switch.check sw;; +Exception: Invalid_argument "Switch finished!". +``` + +Wait for either a promise or a cancellation; cancellation first: +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + Fiber.fork ~sw (fun () -> + Fiber.both + (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved") + (fun () -> failwith "Cancelled") + ); + Fiber.yield (); + Promise.resolve r (); + traceln "Main thread done"; + );; ++Waiting ++Main thread done +Exception: Failure "Cancelled". +``` + +Wait for either a promise or a switch; promise resolves first: + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + Fiber.fork ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved"); + Promise.resolve r (); + Fiber.yield (); + traceln "Now cancelling..."; + Switch.fail sw (Failure "Cancelled") + );; ++Waiting ++Resolved ++Now cancelling... +Exception: Failure "Cancelled". +``` + +Wait for either a promise or a switch; switch cancelled first. Result version. + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + Fiber.fork ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved"); + Switch.fail sw (Failure "Cancelled"); + Promise.resolve r () + );; ++Waiting +Exception: Failure "Cancelled". +``` + +Wait for either a promise or a switch; promise resolves first but switch off without yielding: + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + Fiber.fork ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved"); + Promise.resolve r (); + traceln "Now cancelling..."; + Switch.fail sw (Failure "Cancelled") + );; ++Waiting ++Now cancelling... ++Resolved +Exception: Failure "Cancelled". +``` + +Child switches are cancelled when the parent is cancelled, but `on_error` isn't notified: + +```ocaml +# run (fun sw -> + let p, _ = Promise.create () in + let on_error ex = traceln "child: %s" (Printexc.to_string ex) in + fork_sub ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await p); + fork_sub ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await p); + Switch.fail sw (Failure "Cancel parent") + );; ++Child 1 ++Child 2 +Exception: Failure "Cancel parent". +``` + +A child can fail independently of the parent: + +```ocaml +# run (fun sw -> + let p1, r1 = Promise.create () in + let p2, r2 = Promise.create () in + let on_error ex = traceln "child: %s" (Printexc.to_string ex) in + fork_sub ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await_exn p1); + fork_sub ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await_exn p2); + Promise.resolve_error r1 (Failure "Child error"); + Promise.resolve_ok r2 (); + Fiber.yield (); + traceln "Parent fiber is still running" + );; ++Child 1 ++Child 2 ++child: Failure("Child error") ++Parent fiber is still running +- : unit = () +``` + +A child can be cancelled independently of the parent: + +```ocaml +# run (fun sw -> + let p, _ = Promise.create () in + let on_error ex = traceln "child: %s" (Printexc.to_string ex) in + let child = ref None in + fork_sub ~sw ~on_error (fun sw -> + traceln "Child 1"; + child := Some sw; + Promise.await ~sw p + ); + Switch.fail (Option.get !child) (Failure "Cancel child"); + Fiber.yield (); + traceln "Parent fiber is still running" + );; ++Child 1 ++child: Failure("Cancel child") ++Parent fiber is still running +- : unit = () +``` + +A child error handler raises: + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + let on_error = raise in + fork_sub ~sw ~on_error (fun sw -> traceln "Child"; Promise.await_exn p); + Promise.resolve_error r (Failure "Child error escapes"); + Fiber.yield (); + traceln "Not reached" + );; ++Child +Exception: Failure "Child error escapes". +``` + +A child error handler deals with the exception: + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + let on_error = traceln "caught: %a" Fmt.exn in + fork_sub ~sw ~on_error (fun sw -> traceln "Child"; Promise.await_exn p); + Promise.resolve_error r (Failure "Child error is caught"); + Fiber.yield (); + traceln "Still running" + );; ++Child ++caught: Failure("Child error is caught") ++Still running +- : unit = () +``` + +# Release handlers + +```ocaml +let release label = Fiber.yield (); traceln "release %s" label +``` + +Release on success: + +```ocaml +# run (fun sw -> + Switch.on_release sw (fun () -> release "1"); + Switch.on_release sw (fun () -> release "2"); + );; ++release 2 ++release 1 +- : unit = () +``` + +Release on error: + +```ocaml +# run (fun sw -> + Switch.on_release sw (fun () -> release "1"); + Switch.on_release sw (fun () -> release "2"); + failwith "Test error" + );; ++release 2 ++release 1 +Exception: Failure "Test error". +``` + +A release operation itself fails: + +```ocaml +# run (fun sw -> + Switch.on_release sw (fun () -> release "1"; failwith "failure 1"); + Switch.on_release sw (fun () -> release "2"); + Switch.on_release sw (fun () -> release "3"; failwith "failure 3"); + );; ++release 3 ++release 2 ++release 1 +Exception: Multiple exceptions: +- Failure("failure 3") +- Failure("failure 1") +``` + +Attaching a release handler to a finished switch from a cancelled context: + +```ocaml +# run @@ fun sw -> + let sub = Switch.run Fun.id in (* A finished switch *) + Switch.fail sw (Failure "Parent cancelled too!"); + Switch.on_release sub (fun () -> release "1");; ++release 1 +Exception: +Multiple exceptions: +- Failure("Parent cancelled too!") +- Invalid_argument("Switch finished!") +``` + +Attaching resources to a switch from inside release handler fails +(possibly forking with it should be disallowed in future too): + +```ocaml +# run (fun sw -> + Switch.on_release sw (fun () -> + Fiber.fork ~sw (fun () -> + traceln "Starting release 1"; + Fiber.yield (); + traceln "Finished release 1" + ); + ); + Switch.on_release sw (fun () -> + Fiber.fork ~sw (fun () -> + traceln "Starting release 2"; + begin + try + Switch.on_release sw (fun () -> traceln "Immediate release"); + with Invalid_argument msg -> + traceln "on_release refused: %s" msg + end; + Fiber.yield (); + traceln "Finished release 2" + ); + ); + traceln "Main fiber done" + );; ++Main fiber done ++Starting release 2 ++Immediate release ++on_release refused: Switch finished! ++Starting release 1 ++Finished release 2 ++Finished release 1 +- : unit = () +``` + +# Error reporting + +All release hooks run, even if some fail, and all errors are reported: + +```ocaml +# run (fun sw -> + Fiber.fork ~sw (fun () -> try Fiber.await_cancel () with _ -> failwith "cancel1 failed"); + Fiber.fork ~sw (fun () -> try Fiber.await_cancel () with _ -> failwith "cancel2 failed"); + raise Exit + );; +Exception: +Multiple exceptions: +- Stdlib.Exit +- Failure("cancel1 failed") +- Failure("cancel2 failed") +``` + +# Errors during cleanup are reported during cancellation + +```ocaml +# run (fun sw -> + Fiber.fork ~sw (fun () -> + Switch.run @@ fun sw -> + try Fiber.await_cancel () with _ -> failwith "cleanup failed"); + Fiber.fork ~sw (fun () -> failwith "simulated error") + );; +Exception: +Multiple exceptions: +- Failure("simulated error") +- Failure("cleanup failed") +``` diff --git a/tests/sync.md b/tests/sync.md index d37b90f71..e9ae332c9 100644 --- a/tests/sync.md +++ b/tests/sync.md @@ -1,146 +1,146 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -``` - -```ocaml -open Eio.Std - -module Trace = Eio.Private.Trace - -let pp_promise pp f x = - match Promise.peek x with - | None -> Fmt.string f "unresolved" - | Some Error (Failure msg) -> Fmt.pf f "broken:%s" msg - | Some Error ex -> Fmt.pf f "broken:%a" Fmt.exn ex - | Some Ok x -> Fmt.pf f "fulfilled:%a" pp x -``` - -# Test cases - -Create a promise, fork a thread waiting for it, then fulfull it: -```ocaml -# let () = - Eio_main.run @@ fun _stdenv -> - Switch.run @@ fun sw -> - let p, r = Promise.create () in - traceln "Initial state: %a" (pp_promise Fmt.string) p; - let thread = Fiber.fork_promise ~sw (fun () -> Promise.await_exn p) in - Promise.resolve_ok r "ok"; - traceln "After being fulfilled: %a" (pp_promise Fmt.string) p; - traceln "Thread before yield: %a" (pp_promise Fmt.string) thread; - Fiber.yield (); - traceln "Thread after yield: %a" (pp_promise Fmt.string) thread; - traceln "Final result: %s" (Promise.await_exn thread);; -+Initial state: unresolved -+After being fulfilled: fulfilled:ok -+Thread before yield: unresolved -+Thread after yield: fulfilled:ok -+Final result: ok -``` - -Create a promise, fork a thread waiting for it, then break it: -```ocaml -# let () = - Eio_main.run @@ fun _stdenv -> - Switch.run @@ fun sw -> - let p, r = Promise.create () in - traceln "Initial state: %a" (pp_promise Fmt.string) p; - let thread = Fiber.fork_promise ~sw (fun () -> Promise.await_exn p) in - Promise.resolve_error r (Failure "test"); - traceln "After being broken: %a" (pp_promise Fmt.string) p; - traceln "Thread before yield: %a" (pp_promise Fmt.string) thread; - Fiber.yield (); - traceln "Thread after yield: %a" (pp_promise Fmt.string) thread; - match Promise.await_exn thread with - | x -> failwith x - | exception (Failure msg) -> traceln "Final result exception: %s" msg;; -+Initial state: unresolved -+After being broken: broken:test -+Thread before yield: unresolved -+Thread after yield: broken:test -+Final result exception: test -``` - -Some simple tests of `fork`: -```ocaml -# let () = - Eio_main.run @@ fun _stdenv -> - let i = ref 0 in - Switch.run (fun sw -> - Fiber.fork ~sw (fun () -> incr i); - ); - traceln "Forked code ran; i is now %d" !i; - let p1, r1 = Promise.create () in - try - Switch.run (fun sw -> - Fiber.fork ~sw (fun () -> Promise.await p1; incr i; raise Exit); - traceln "Forked code waiting; i is still %d" !i; - Promise.resolve r1 () - ); - assert false - with Exit -> - traceln "Forked code ran; i is now %d" !i;; -+Forked code ran; i is now 1 -+Forked code waiting; i is still 1 -+Forked code ran; i is now 2 -``` - -Basic semaphore tests: -```ocaml -# let () = - let module Semaphore = Eio.Semaphore in - Eio_main.run @@ fun _stdenv -> - Switch.run @@ fun sw -> - let running = ref 0 in - let sem = Semaphore.make 2 in - let fork = Fiber.fork_promise ~sw in - let a = fork (fun () -> Trace.log "a"; Semaphore.acquire sem; incr running) in - let b = fork (fun () -> Trace.log "b"; Semaphore.acquire sem; incr running) in - let c = fork (fun () -> Trace.log "c"; Semaphore.acquire sem; incr running) in - let d = fork (fun () -> Trace.log "d"; Semaphore.acquire sem; incr running) in - traceln "Semaphore means that only %d threads are running" !running; - Promise.await_exn a; - Promise.await_exn b; - (* a finishes and c starts *) - decr running; - Semaphore.release sem; - traceln "One finished; now %d is running " !running; - Fiber.yield (); - traceln "Yield allows C to start; now %d are running " !running; - Promise.await_exn c; - (* b finishes and d starts *) - decr running; - Semaphore.release sem; - Promise.await_exn d; - decr running; - Semaphore.release sem; - decr running; - Semaphore.release sem;; -+Semaphore means that only 2 threads are running -+One finished; now 1 is running -+Yield allows C to start; now 2 are running -``` - -Releasing a semaphore when no-one is waiting for it: -```ocaml -# let () = - let module Semaphore = Eio.Semaphore in - Eio_main.run @@ fun _stdenv -> - Switch.run @@ fun sw -> - let sem = Semaphore.make 0 in - Semaphore.release sem; (* Release with free-counter *) - traceln "Initial config: %d" (Semaphore.get_value sem); - Fiber.fork ~sw (fun () -> Trace.log "a"; Semaphore.acquire sem); - Fiber.fork ~sw (fun () -> Trace.log "b"; Semaphore.acquire sem); - traceln "A running: %d" (Semaphore.get_value sem); - Semaphore.release sem; (* Release with a non-empty wait-queue *) - traceln "Now b running: %d" (Semaphore.get_value sem); - Semaphore.release sem; (* Release with an empty wait-queue *) - traceln "Finished: %d" (Semaphore.get_value sem);; -+Initial config: 1 -+A running: 0 -+Now b running: 0 -+Finished: 1 -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +``` + +```ocaml +open Eio.Std + +module Trace = Eio.Private.Trace + +let pp_promise pp f x = + match Promise.peek x with + | None -> Fmt.string f "unresolved" + | Some Error (Failure msg) -> Fmt.pf f "broken:%s" msg + | Some Error ex -> Fmt.pf f "broken:%a" Fmt.exn ex + | Some Ok x -> Fmt.pf f "fulfilled:%a" pp x +``` + +# Test cases + +Create a promise, fork a thread waiting for it, then fulfull it: +```ocaml +# let () = + Eio_main.run @@ fun _stdenv -> + Switch.run @@ fun sw -> + let p, r = Promise.create () in + traceln "Initial state: %a" (pp_promise Fmt.string) p; + let thread = Fiber.fork_promise ~sw (fun () -> Promise.await_exn p) in + Promise.resolve_ok r "ok"; + traceln "After being fulfilled: %a" (pp_promise Fmt.string) p; + traceln "Thread before yield: %a" (pp_promise Fmt.string) thread; + Fiber.yield (); + traceln "Thread after yield: %a" (pp_promise Fmt.string) thread; + traceln "Final result: %s" (Promise.await_exn thread);; ++Initial state: unresolved ++After being fulfilled: fulfilled:ok ++Thread before yield: unresolved ++Thread after yield: fulfilled:ok ++Final result: ok +``` + +Create a promise, fork a thread waiting for it, then break it: +```ocaml +# let () = + Eio_main.run @@ fun _stdenv -> + Switch.run @@ fun sw -> + let p, r = Promise.create () in + traceln "Initial state: %a" (pp_promise Fmt.string) p; + let thread = Fiber.fork_promise ~sw (fun () -> Promise.await_exn p) in + Promise.resolve_error r (Failure "test"); + traceln "After being broken: %a" (pp_promise Fmt.string) p; + traceln "Thread before yield: %a" (pp_promise Fmt.string) thread; + Fiber.yield (); + traceln "Thread after yield: %a" (pp_promise Fmt.string) thread; + match Promise.await_exn thread with + | x -> failwith x + | exception (Failure msg) -> traceln "Final result exception: %s" msg;; ++Initial state: unresolved ++After being broken: broken:test ++Thread before yield: unresolved ++Thread after yield: broken:test ++Final result exception: test +``` + +Some simple tests of `fork`: +```ocaml +# let () = + Eio_main.run @@ fun _stdenv -> + let i = ref 0 in + Switch.run (fun sw -> + Fiber.fork ~sw (fun () -> incr i); + ); + traceln "Forked code ran; i is now %d" !i; + let p1, r1 = Promise.create () in + try + Switch.run (fun sw -> + Fiber.fork ~sw (fun () -> Promise.await p1; incr i; raise Exit); + traceln "Forked code waiting; i is still %d" !i; + Promise.resolve r1 () + ); + assert false + with Exit -> + traceln "Forked code ran; i is now %d" !i;; ++Forked code ran; i is now 1 ++Forked code waiting; i is still 1 ++Forked code ran; i is now 2 +``` + +Basic semaphore tests: +```ocaml +# let () = + let module Semaphore = Eio.Semaphore in + Eio_main.run @@ fun _stdenv -> + Switch.run @@ fun sw -> + let running = ref 0 in + let sem = Semaphore.make 2 in + let fork = Fiber.fork_promise ~sw in + let a = fork (fun () -> Trace.log "a"; Semaphore.acquire sem; incr running) in + let b = fork (fun () -> Trace.log "b"; Semaphore.acquire sem; incr running) in + let c = fork (fun () -> Trace.log "c"; Semaphore.acquire sem; incr running) in + let d = fork (fun () -> Trace.log "d"; Semaphore.acquire sem; incr running) in + traceln "Semaphore means that only %d threads are running" !running; + Promise.await_exn a; + Promise.await_exn b; + (* a finishes and c starts *) + decr running; + Semaphore.release sem; + traceln "One finished; now %d is running " !running; + Fiber.yield (); + traceln "Yield allows C to start; now %d are running " !running; + Promise.await_exn c; + (* b finishes and d starts *) + decr running; + Semaphore.release sem; + Promise.await_exn d; + decr running; + Semaphore.release sem; + decr running; + Semaphore.release sem;; ++Semaphore means that only 2 threads are running ++One finished; now 1 is running ++Yield allows C to start; now 2 are running +``` + +Releasing a semaphore when no-one is waiting for it: +```ocaml +# let () = + let module Semaphore = Eio.Semaphore in + Eio_main.run @@ fun _stdenv -> + Switch.run @@ fun sw -> + let sem = Semaphore.make 0 in + Semaphore.release sem; (* Release with free-counter *) + traceln "Initial config: %d" (Semaphore.get_value sem); + Fiber.fork ~sw (fun () -> Trace.log "a"; Semaphore.acquire sem); + Fiber.fork ~sw (fun () -> Trace.log "b"; Semaphore.acquire sem); + traceln "A running: %d" (Semaphore.get_value sem); + Semaphore.release sem; (* Release with a non-empty wait-queue *) + traceln "Now b running: %d" (Semaphore.get_value sem); + Semaphore.release sem; (* Release with an empty wait-queue *) + traceln "Finished: %d" (Semaphore.get_value sem);; ++Initial config: 1 ++A running: 0 ++Now b running: 0 ++Finished: 1 +``` diff --git a/tests/time.md b/tests/time.md index 63884c647..58fe59ca4 100644 --- a/tests/time.md +++ b/tests/time.md @@ -1,251 +1,251 @@ -# Setting up the environment - -```ocaml -# #require "eio_main";; -# #require "eio.mock";; -``` - -```ocaml -open Eio.Std - -let run (fn : clock:float Eio.Time.clock_ty r -> unit) = - Eio_main.run @@ fun env -> - let clock = Eio.Stdenv.clock env in - fn ~clock -``` - -# Test cases - -Check sleep works: - -```ocaml -# run @@ fun ~clock -> - let t0 = Unix.gettimeofday () in - Eio.Time.sleep clock 0.01; - let t1 = Unix.gettimeofday () in - assert (t1 -. t0 >= 0.01);; -- : unit = () -``` - -Cancelling sleep: - -```ocaml -# run @@ fun ~clock -> - Fiber.both - (fun () -> Eio.Time.sleep clock 1200.; assert false) - (fun () -> failwith "Simulated cancel");; -Exception: Failure "Simulated cancel". -``` - -Switch is already off: - -```ocaml -# run @@ fun ~clock -> - Switch.run @@ fun sw -> - Switch.fail sw (Failure "Simulated failure"); - Eio.Time.sleep clock 1200.0; - assert false;; -Exception: Failure "Simulated failure". -``` - -Scheduling a timer that's already due: - -```ocaml -# run @@ fun ~clock -> - Switch.run @@ fun sw -> - Fiber.both - (fun () -> traceln "First fiber runs"; Eio.Time.sleep clock (-1.0); traceln "Sleep done") - (fun () -> traceln "Second fiber runs");; -+First fiber runs -+Second fiber runs -+Sleep done -- : unit = () -``` - -Check ordering works: - -```ocaml -# run @@ fun ~clock -> - Switch.run @@ fun sw -> - Fiber.both - (fun () -> - Eio.Time.sleep clock 1200.0; - assert false - ) - (fun () -> - Eio.Time.sleep clock 0.1; - traceln "Short timer finished"; - failwith "Simulated cancel" - );; -+Short timer finished -Exception: Failure "Simulated cancel". -``` - -Check Unix debug clock: -```ocaml -# Eio_main.run @@ fun _ -> - Fiber.both - (fun () -> traceln "First thread starts"; Eio_unix.sleep 0.001; traceln "Sleep done") - (fun () -> traceln "Second thread starts");; -+First thread starts -+Second thread starts -+Sleep done -- : unit = () -``` - -Timer and busy loop: -```ocaml -let rec loop () = - Eio.Fiber.yield (); - loop () -``` - -```ocaml -# run @@ fun ~clock -> - Fiber.yield (); - Eio.Time.sleep clock 0.01; - Fiber.first - loop - (fun () -> Eio.Time.sleep clock 0.01);; -- : unit = () -``` - -### Timeouts - -```ocaml -# Eio_main.run @@ fun env -> - let clock = Eio.Stdenv.mono_clock env in - Eio.Time.Timeout.(run_exn none) (fun () -> ()); - let t = Eio.Time.Timeout.seconds clock 0.0001 in - Eio.Time.Timeout.run_exn t (fun () -> Fiber.await_cancel ());; -Exception: Eio__Time.Timeout. -``` - -```ocaml -# Eio_main.run @@ fun env -> - let clock = Eio.Stdenv.mono_clock env in - let show d = - let t = Eio.Time.Timeout.seconds clock d in - traceln "%g -> %a" d Eio.Time.Timeout.pp t - in - show 0.000000001; - show 0.01; - show 0.1; - show 2.; - show 60.; - show 61.5; - show 120.; - show (30. *. 60.); - ;; -+1e-09 -> 1e-09s -+0.01 -> 10ms -+0.1 -> 0.1s -+2 -> 2s -+60 -> 60s -+61.5 -> 62s -+120 -> 2m -+1800 -> 30m -- : unit = () -``` - -### Mock clock - -```ocaml -let mock = Eio_mock.Clock.make () -let sleeper label time () = Eio.Time.sleep_until mock time; traceln "%s (%g) woken" label time -``` - -Advancing the time: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Fiber.all [ - sleeper "A" 5.0; - sleeper "B" 7.0; - sleeper "C" 2.0; - sleeper "D" 0.0; - sleeper "E" 5.0; - (fun () -> - while true do - Fiber.yield (); - Eio_mock.Clock.advance mock - done - ) - ];; -+D (0) woken -+mock time is now 2 -+C (2) woken -+mock time is now 5 -+A (5) woken -+E (5) woken -+mock time is now 7 -+B (7) woken -Exception: Invalid_argument "No further events scheduled on mock clock". -``` - -Setting the time directly: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Clock.set_time mock 0.0; - Fiber.all [ - sleeper "A" 5.0; - sleeper "B" 7.0; - sleeper "C" 2.0; - sleeper "D" 0.0; - sleeper "E" 5.0; - (fun () -> - Fiber.yield (); - Eio_mock.Clock.set_time mock 5.0; - Fiber.yield (); - Eio_mock.Clock.set_time mock 1.0; - Fiber.yield (); - Eio_mock.Clock.set_time mock 10.0; - Fiber.yield (); - Eio_mock.Clock.set_time mock 12.0 - ) - ];; -+mock time is now 0 -+D (0) woken -+mock time is now 5 -+C (2) woken -+A (5) woken -+E (5) woken -+mock time is now 1 -+mock time is now 10 -+B (7) woken -+mock time is now 12 -- : unit = () -``` - -Cancellation: - -```ocaml -# Eio_mock.Backend.run @@ fun () -> - Eio_mock.Clock.set_time mock 0.0; - Fiber.first - (sleeper "A" 5.0) - (fun () -> traceln "Cancel sleeper"); - Eio_mock.Clock.advance mock;; -+mock time is now 0 -+Cancel sleeper -Exception: Invalid_argument "No further events scheduled on mock clock". -``` - -Sleep: - -```ocaml -# try - Eio_mock.Backend.run_full @@ fun env -> - let timeout = Eio.Time.Timeout.seconds env#mono_clock 2. in - Eio.Time.Timeout.sleep timeout; - traceln "Timeout done"; - Eio.Time.Timeout.(sleep none); - assert false - with Eio_mock.Backend.Deadlock_detected -> - traceln "Never finished";; -+mock time is now 2 -+Timeout done -+Never finished -- : unit = () -``` +# Setting up the environment + +```ocaml +# #require "eio_main";; +# #require "eio.mock";; +``` + +```ocaml +open Eio.Std + +let run (fn : clock:float Eio.Time.clock_ty r -> unit) = + Eio_main.run @@ fun env -> + let clock = Eio.Stdenv.clock env in + fn ~clock +``` + +# Test cases + +Check sleep works: + +```ocaml +# run @@ fun ~clock -> + let t0 = Unix.gettimeofday () in + Eio.Time.sleep clock 0.01; + let t1 = Unix.gettimeofday () in + assert (t1 -. t0 >= 0.01);; +- : unit = () +``` + +Cancelling sleep: + +```ocaml +# run @@ fun ~clock -> + Fiber.both + (fun () -> Eio.Time.sleep clock 1200.; assert false) + (fun () -> failwith "Simulated cancel");; +Exception: Failure "Simulated cancel". +``` + +Switch is already off: + +```ocaml +# run @@ fun ~clock -> + Switch.run @@ fun sw -> + Switch.fail sw (Failure "Simulated failure"); + Eio.Time.sleep clock 1200.0; + assert false;; +Exception: Failure "Simulated failure". +``` + +Scheduling a timer that's already due: + +```ocaml +# run @@ fun ~clock -> + Switch.run @@ fun sw -> + Fiber.both + (fun () -> traceln "First fiber runs"; Eio.Time.sleep clock (-1.0); traceln "Sleep done") + (fun () -> traceln "Second fiber runs");; ++First fiber runs ++Second fiber runs ++Sleep done +- : unit = () +``` + +Check ordering works: + +```ocaml +# run @@ fun ~clock -> + Switch.run @@ fun sw -> + Fiber.both + (fun () -> + Eio.Time.sleep clock 1200.0; + assert false + ) + (fun () -> + Eio.Time.sleep clock 0.1; + traceln "Short timer finished"; + failwith "Simulated cancel" + );; ++Short timer finished +Exception: Failure "Simulated cancel". +``` + +Check Unix debug clock: +```ocaml +# Eio_main.run @@ fun _ -> + Fiber.both + (fun () -> traceln "First thread starts"; Eio_unix.sleep 0.001; traceln "Sleep done") + (fun () -> traceln "Second thread starts");; ++First thread starts ++Second thread starts ++Sleep done +- : unit = () +``` + +Timer and busy loop: +```ocaml +let rec loop () = + Eio.Fiber.yield (); + loop () +``` + +```ocaml +# run @@ fun ~clock -> + Fiber.yield (); + Eio.Time.sleep clock 0.01; + Fiber.first + loop + (fun () -> Eio.Time.sleep clock 0.01);; +- : unit = () +``` + +### Timeouts + +```ocaml +# Eio_main.run @@ fun env -> + let clock = Eio.Stdenv.mono_clock env in + Eio.Time.Timeout.(run_exn none) (fun () -> ()); + let t = Eio.Time.Timeout.seconds clock 0.0001 in + Eio.Time.Timeout.run_exn t (fun () -> Fiber.await_cancel ());; +Exception: Eio__Time.Timeout. +``` + +```ocaml +# Eio_main.run @@ fun env -> + let clock = Eio.Stdenv.mono_clock env in + let show d = + let t = Eio.Time.Timeout.seconds clock d in + traceln "%g -> %a" d Eio.Time.Timeout.pp t + in + show 0.000000001; + show 0.01; + show 0.1; + show 2.; + show 60.; + show 61.5; + show 120.; + show (30. *. 60.); + ;; ++1e-09 -> 1e-09s ++0.01 -> 10ms ++0.1 -> 0.1s ++2 -> 2s ++60 -> 60s ++61.5 -> 62s ++120 -> 2m ++1800 -> 30m +- : unit = () +``` + +### Mock clock + +```ocaml +let mock = Eio_mock.Clock.make () +let sleeper label time () = Eio.Time.sleep_until mock time; traceln "%s (%g) woken" label time +``` + +Advancing the time: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Fiber.all [ + sleeper "A" 5.0; + sleeper "B" 7.0; + sleeper "C" 2.0; + sleeper "D" 0.0; + sleeper "E" 5.0; + (fun () -> + while true do + Fiber.yield (); + Eio_mock.Clock.advance mock + done + ) + ];; ++D (0) woken ++mock time is now 2 ++C (2) woken ++mock time is now 5 ++A (5) woken ++E (5) woken ++mock time is now 7 ++B (7) woken +Exception: Invalid_argument "No further events scheduled on mock clock". +``` + +Setting the time directly: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Clock.set_time mock 0.0; + Fiber.all [ + sleeper "A" 5.0; + sleeper "B" 7.0; + sleeper "C" 2.0; + sleeper "D" 0.0; + sleeper "E" 5.0; + (fun () -> + Fiber.yield (); + Eio_mock.Clock.set_time mock 5.0; + Fiber.yield (); + Eio_mock.Clock.set_time mock 1.0; + Fiber.yield (); + Eio_mock.Clock.set_time mock 10.0; + Fiber.yield (); + Eio_mock.Clock.set_time mock 12.0 + ) + ];; ++mock time is now 0 ++D (0) woken ++mock time is now 5 ++C (2) woken ++A (5) woken ++E (5) woken ++mock time is now 1 ++mock time is now 10 ++B (7) woken ++mock time is now 12 +- : unit = () +``` + +Cancellation: + +```ocaml +# Eio_mock.Backend.run @@ fun () -> + Eio_mock.Clock.set_time mock 0.0; + Fiber.first + (sleeper "A" 5.0) + (fun () -> traceln "Cancel sleeper"); + Eio_mock.Clock.advance mock;; ++mock time is now 0 ++Cancel sleeper +Exception: Invalid_argument "No further events scheduled on mock clock". +``` + +Sleep: + +```ocaml +# try + Eio_mock.Backend.run_full @@ fun env -> + let timeout = Eio.Time.Timeout.seconds env#mono_clock 2. in + Eio.Time.Timeout.sleep timeout; + traceln "Timeout done"; + Eio.Time.Timeout.(sleep none); + assert false + with Eio_mock.Backend.Deadlock_detected -> + traceln "Never finished";; ++mock time is now 2 ++Timeout done ++Never finished +- : unit = () +``` diff --git a/tests/trace.md b/tests/trace.md index c14f37e60..0ddcbb2c0 100644 --- a/tests/trace.md +++ b/tests/trace.md @@ -1,14 +1,14 @@ -```ocaml -# #require "eio_main";; -# open Eio.Std;; -# Eio_main.run @@ fun _env -> - traceln "One-line trace"; - traceln "@[A nested list@,Foo@,Bar@]"; - traceln "Trace with position" ~__POS__:("trace.md", 5, 1, 10);; -+One-line trace -+A nested list -+ Foo -+ Bar -+Trace with position [trace.md:5] -- : unit = () -``` +```ocaml +# #require "eio_main";; +# open Eio.Std;; +# Eio_main.run @@ fun _env -> + traceln "One-line trace"; + traceln "@[A nested list@,Foo@,Bar@]"; + traceln "Trace with position" ~__POS__:("trace.md", 5, 1, 10);; ++One-line trace ++A nested list ++ Foo ++ Bar ++Trace with position [trace.md:5] +- : unit = () +```