├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.md ├── async_unix.opam ├── dune-project ├── src ├── async_print.ml ├── async_print.mli ├── async_sys.ml ├── async_sys.mli ├── async_unix.ml ├── backing_out_channel.ml ├── backing_out_channel.mli ├── busy_poller.ml ├── busy_poller.mli ├── busy_poller_intf.ml ├── by_descr.ml ├── by_descr.mli ├── clock.ml ├── clock.mli ├── config.ml ├── config.mli ├── dump_core_on_job_delay.ml ├── dump_core_on_job_delay.mli ├── dump_core_on_job_delay_stubs.c ├── dune ├── epoll_file_descr_watcher.ml ├── epoll_file_descr_watcher.mli ├── fd.ml ├── fd.mli ├── file_descr_watcher_intf.ml ├── import.ml ├── in_thread.ml ├── in_thread.mli ├── interruptor.ml ├── interruptor.mli ├── io_stats.ml ├── io_stats.mli ├── io_uring.ml ├── io_uring.mli ├── io_uring_config.h ├── io_uring_file_descr_watcher.ml ├── io_uring_file_descr_watcher.mli ├── io_uring_raw.ml ├── io_uring_raw.mli ├── io_uring_raw_intf.ml ├── io_uring_raw_null.ml ├── io_uring_raw_null.mli ├── io_uring_raw_singleton.ml ├── io_uring_raw_singleton.mli ├── io_uring_types_intf.ml ├── magic_trace_stubs.c ├── process.ml ├── process.mli ├── raw_fd.ml ├── raw_scheduler.ml ├── raw_signal_manager.ml ├── raw_signal_manager.mli ├── reader.ml ├── reader.mli ├── reader0.ml ├── require_explicit_time_source.ml ├── require_explicit_time_source.mli ├── require_explicit_time_source_intf.ml ├── scheduler.ml ├── scheduler.mli ├── select_file_descr_watcher.ml ├── select_file_descr_watcher.mli ├── shutdown.ml ├── shutdown.mli ├── signal.ml ├── signal.mli ├── signal_manager.ml ├── signal_manager.mli ├── syscall.ml ├── syscall.mli ├── tcp.ml ├── tcp.mli ├── thread_safe.ml ├── thread_safe.mli ├── time_source_tests.ml ├── time_source_tests.mli ├── unix_syscalls.ml ├── unix_syscalls.mli ├── unused.ml ├── writer.ml ├── writer.mli ├── writer0.ml ├── writer0.mli └── writer_intf.ml ├── thread_pool ├── README.md ├── src │ ├── dune │ ├── import.ml │ ├── thread_pool.ml │ └── thread_pool.mli └── test │ ├── dune │ ├── test_thread_pool.ml │ ├── test_thread_pool.mli │ └── thread_pool_test.ml ├── thread_safe_ivar ├── README.md ├── src │ ├── dune │ ├── import.ml │ ├── thread_safe_ivar.ml │ └── thread_safe_ivar.mli └── test │ ├── dune │ ├── spurious_wakeup.ml │ ├── spurious_wakeup.mli │ └── thread_safe_ivar_tests.ml └── thread_safe_pipe ├── README.md ├── src ├── dune ├── import.ml ├── thread_safe_pipe.ml └── thread_safe_pipe.mli └── test ├── dune ├── test_thread_safe_pipe.ml ├── test_thread_safe_pipe.mli └── thread_safe_pipe_test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2008--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Async_unix 2 | ========== 3 | 4 | Async_unix includes Unix-related dependencies for things like system calls and 5 | threads. Using these, it hooks the Async_kernel scheduler up to either `epoll` 6 | or `select`, depending on availability, and manages a thread pool that blocking 7 | system calls run in. 8 | 9 | API documentation for the latest release can be found 10 | [here](https://ocaml.janestreet.com/ocaml-core/latest/doc/async/index.html). 11 | -------------------------------------------------------------------------------- /async_unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/async_unix" 5 | bug-reports: "https://github.com/janestreet/async_unix/issues" 6 | dev-repo: "git+https://github.com/janestreet/async_unix.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/async_unix/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "async_kernel" 15 | "core" 16 | "core_kernel" 17 | "core_unix" 18 | "ppx_jane" 19 | "ppx_optcomp" 20 | "sexplib" 21 | "cstruct" {>= "6.0.0"} 22 | "dune" {>= "3.17.0"} 23 | ] 24 | available: arch != "arm32" & arch != "x86_32" 25 | synopsis: "Monadic concurrency library" 26 | description: " 27 | Part of Jane Street's Core library 28 | The Core suite of libraries is an industrial strength alternative to 29 | OCaml's standard library that was developed by Jane Street, the 30 | largest industrial user of OCaml. 31 | " 32 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /src/async_print.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let stdout () = Lazy.force Writer.stdout 4 | let stderr () = Lazy.force Writer.stderr 5 | let do_printf writer = ksprintf (fun s -> Writer.write (writer ()) s) 6 | let printf fmt = do_printf stdout fmt 7 | let fprintf writer fmt = Printf.ksprintf (fun s -> Writer.write writer s) fmt 8 | let eprintf fmt = do_printf stderr fmt 9 | let print_char c = Writer.write_char (stdout ()) c 10 | let prerr_char c = Writer.write_char (stderr ()) c 11 | let print_string s = Writer.write (stdout ()) s 12 | let prerr_string s = Writer.write (stderr ()) s 13 | let print_newline () = Writer.write_char (stdout ()) '\n' 14 | let prerr_newline () = Writer.write_char (stderr ()) '\n' 15 | 16 | let print_endline s = 17 | print_string s; 18 | print_newline () 19 | ;; 20 | 21 | let prerr_endline s = 22 | prerr_string s; 23 | prerr_newline () 24 | ;; 25 | 26 | let print_int i = print_string (Int.to_string i) 27 | let prerr_int i = prerr_string (Int.to_string i) 28 | let print_float f = print_string (Float.to_string_12 f) 29 | let prerr_float f = prerr_string (Float.to_string_12 f) 30 | 31 | let print_s ?mach sexp = 32 | print_endline 33 | (match mach with 34 | | Some () -> Sexp.to_string_mach sexp 35 | | None -> Sexp.to_string_hum sexp) 36 | ;; 37 | 38 | let eprint_s ?mach sexp = 39 | prerr_endline 40 | (match mach with 41 | | Some () -> Sexp.to_string_mach sexp 42 | | None -> Sexp.to_string_hum sexp) 43 | ;; 44 | -------------------------------------------------------------------------------- /src/async_print.mli: -------------------------------------------------------------------------------- 1 | (** Non-blocking, Async-friendly print functions. *) 2 | 3 | val print_char : char -> unit 4 | val prerr_char : char -> unit 5 | val print_string : string -> unit 6 | val prerr_string : string -> unit 7 | val print_int : int -> unit 8 | val prerr_int : int -> unit 9 | val print_float : float -> unit 10 | val prerr_float : float -> unit 11 | val print_endline : string -> unit 12 | val prerr_endline : string -> unit 13 | val print_newline : unit -> unit 14 | val prerr_newline : unit -> unit 15 | val print_s : ?mach:unit -> Sexplib.Sexp.t -> unit 16 | val printf : ('a, unit, string, unit) format4 -> 'a 17 | val fprintf : Writer.t -> ('a, unit, string, unit) format4 -> 'a 18 | val eprintf : ('a, unit, string, unit) format4 -> 'a 19 | val eprint_s : ?mach:unit -> Sexplib.Sexp.t -> unit 20 | -------------------------------------------------------------------------------- /src/async_sys.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | module Unix = Unix_syscalls 4 | 5 | let argv = (Sys.argv [@warning "-3"]) 6 | let get_argv = Sys.get_argv 7 | let executable_name = Sys_unix.executable_name 8 | let wrap1 f x1 = In_thread.run (fun () -> f x1) 9 | let wrap2 f x1 x2 = In_thread.run (fun () -> f x1 x2) 10 | let chdir = wrap1 Sys_unix.chdir 11 | let command = wrap1 Sys_unix.command 12 | let command_exn = wrap1 Sys_unix.command_exn 13 | let quote = Sys.quote 14 | let concat_quoted = Sys.concat_quoted 15 | let getcwd = wrap1 Sys_unix.getcwd 16 | let home_directory = wrap1 Sys_unix.home_directory 17 | let ls_dir = wrap1 Sys_unix.ls_dir 18 | let ls_dir_detailed = wrap1 Core_unix.ls_dir_detailed 19 | let readdir = wrap1 Sys_unix.readdir 20 | let remove = wrap1 Sys_unix.remove 21 | let rename = wrap2 Sys_unix.rename 22 | 23 | let raise_stat_exn ~follow_symlinks path err = 24 | let syscall_name = if follow_symlinks then "stat" else "lstat" in 25 | raise 26 | (Unix.Unix_error 27 | ( err 28 | , syscall_name 29 | , Core_unix.Private.sexp_to_string_hum [%sexp { filename : string = path }] )) 30 | ;; 31 | 32 | let stat_check_exn f ?(follow_symlinks = true) path = 33 | let stat = 34 | if follow_symlinks 35 | then Unix_syscalls.stat_or_unix_error 36 | else Unix_syscalls.lstat_or_unix_error 37 | in 38 | stat path 39 | >>| function 40 | | Ok stat -> f stat 41 | | Error (ENOENT | ENOTDIR) -> false 42 | | Error err -> raise_stat_exn ~follow_symlinks path err 43 | ;; 44 | 45 | let stat_check f ?(follow_symlinks = true) path = 46 | let stat = 47 | if follow_symlinks 48 | then Unix_syscalls.stat_or_unix_error 49 | else Unix_syscalls.lstat_or_unix_error 50 | in 51 | stat path 52 | >>| function 53 | | Ok stat -> if f stat then `Yes else `No 54 | | Error (ENOENT | ENOTDIR) -> `No 55 | | Error (EACCES | ELOOP) -> `Unknown 56 | | Error err -> raise_stat_exn ~follow_symlinks path err 57 | ;; 58 | 59 | let file_exists = stat_check (fun _ -> true) 60 | let file_exists_exn = stat_check_exn (fun _ -> true) 61 | 62 | let is_directory = 63 | stat_check (fun stat -> [%equal: Unix.File_kind.t] stat.kind `Directory) 64 | ;; 65 | 66 | let is_directory_exn = 67 | stat_check_exn (fun stat -> [%equal: Unix.File_kind.t] stat.kind `Directory) 68 | ;; 69 | 70 | let is_file = stat_check (fun stat -> [%equal: Unix.File_kind.t] stat.kind `File) 71 | let is_file_exn = stat_check_exn (fun stat -> [%equal: Unix.File_kind.t] stat.kind `File) 72 | 73 | let is_symlink = 74 | stat_check 75 | (fun stat -> [%equal: Unix.File_kind.t] stat.kind `Link) 76 | ~follow_symlinks:false 77 | ;; 78 | 79 | let is_symlink_exn = 80 | stat_check_exn 81 | (fun stat -> [%equal: Unix.File_kind.t] stat.kind `Link) 82 | ~follow_symlinks:false 83 | ;; 84 | 85 | let when_file_changes 86 | ?(time_source = Time_source.wall_clock ()) 87 | ?(poll_delay = sec 0.5) 88 | file 89 | = 90 | let last_reported_mtime = ref None in 91 | let reader, writer = Pipe.create () in 92 | let rec loop () = 93 | Monitor.try_with ~run:`Schedule ~rest:`Log ~extract_exn:true (fun () -> 94 | Unix.stat file) 95 | >>> fun stat_result -> 96 | if not (Pipe.is_closed writer) 97 | then ( 98 | (match stat_result with 99 | | Error exn -> 100 | last_reported_mtime := None; 101 | Pipe.write_without_pushback writer (Error exn) 102 | | Ok st -> 103 | let mtime = st.mtime in 104 | let should_report = 105 | match !last_reported_mtime with 106 | | None -> true 107 | | Some last_reported_mtime -> not (Time.equal mtime last_reported_mtime) 108 | in 109 | if should_report 110 | then ( 111 | last_reported_mtime := Some mtime; 112 | Pipe.write_without_pushback writer (Ok mtime))); 113 | Time_source.after time_source (Time_ns.Span.of_span_float_round_nearest poll_delay) 114 | >>> loop) 115 | in 116 | loop (); 117 | reader 118 | ;; 119 | 120 | let when_file_exists ?follow_symlinks ?(poll_delay = sec 0.5) file = 121 | Deferred.create (fun i -> 122 | let rec loop () = 123 | file_exists ?follow_symlinks file 124 | >>> function 125 | | `Yes -> Ivar.fill_exn i () 126 | | `No -> upon (Clock.after poll_delay) loop 127 | | `Unknown -> 128 | raise_s [%message "when_file_exists can not check file" (file : string)] 129 | in 130 | loop ()) 131 | ;; 132 | 133 | (* We redeclare everything from Core.Sys that we're just passing through here so that we 134 | are required to have everything enumerated and can consider whether it needs to be 135 | turned into an async version. *) 136 | include struct 137 | open Core.Sys 138 | 139 | let interactive = interactive 140 | let os_type = os_type 141 | let unix = unix 142 | let win32 = win32 143 | let cygwin = cygwin 144 | 145 | type nonrec backend_type = backend_type = 146 | | Native 147 | | Bytecode 148 | | Other of string 149 | 150 | let backend_type = backend_type 151 | let word_size_in_bits = word_size_in_bits 152 | let int_size_in_bits = int_size_in_bits 153 | let big_endian = big_endian 154 | let max_string_length = max_string_length 155 | let max_array_length = max_array_length 156 | let runtime_variant = runtime_variant 157 | let runtime_parameters = runtime_parameters 158 | let ocaml_version = ocaml_version 159 | let enable_runtime_warnings = enable_runtime_warnings 160 | let runtime_warnings_enabled = runtime_warnings_enabled 161 | let getenv = getenv 162 | let getenv_exn = getenv_exn 163 | 164 | include ( 165 | Base.Sys : 166 | sig 167 | (* It seems like just aliasing primitives doesn't satisfy the compiler, 168 | so this is brought in through [include] instead of a [let]. *) 169 | external opaque_identity : 'a. ('a[@local_opt]) -> ('a[@local_opt]) = "%opaque" 170 | [@@layout_poly] 171 | 172 | external opaque_identity_global : 'a. 'a -> 'a = "%opaque" [@@layout_poly] 173 | end) 174 | end 175 | 176 | include struct 177 | open Sys_unix 178 | 179 | let execution_mode = execution_mode 180 | end 181 | 182 | include ( 183 | Sys_unix : 184 | sig 185 | (* It seems like just aliasing primitives doesn't satisfy the compiler, 186 | so this is brought in through [include] instead of a [let]. *) 187 | external c_int_size : unit -> int = "c_int_size" [@@noalloc] 188 | end) 189 | 190 | let word_size = word_size_in_bits 191 | let int_size = int_size_in_bits 192 | -------------------------------------------------------------------------------- /src/async_sys.mli: -------------------------------------------------------------------------------- 1 | (** This module overrides everything in the [Core.Sys] module that might block. Functions 2 | do the same thing as their counterparts in [Core.Sys], but instead return deferreds. 3 | For a description of their semantics see the documentation for the [Core.Sys] module. *) 4 | 5 | open! Core 6 | open! Import 7 | 8 | val argv : string array 9 | [@@deprecated 10 | "[since 2019-08] Use [Sys.get_argv] instead, which has the correct behavior when \ 11 | [caml_sys_modify_argv] is called."] 12 | 13 | val get_argv : unit -> string array 14 | val executable_name : string 15 | val file_exists : ?follow_symlinks:bool -> string -> [ `Yes | `No | `Unknown ] Deferred.t 16 | val file_exists_exn : ?follow_symlinks:bool -> string -> bool Deferred.t 17 | 18 | (** [when_file_exists ?poll_delay file] returns a deferred that becomes determined when 19 | [file] exists. The default poll delay is 0.5 seconds. It raises an exception if it can 20 | not check whether the file is there, in the same cases [file_exists] returns 21 | [`Unknown]. *) 22 | val when_file_exists 23 | : ?follow_symlinks:bool 24 | -> ?poll_delay:Time.Span.t 25 | -> string 26 | -> unit Deferred.t 27 | 28 | (** [when_file_changes file] polls [file] using [stat] and writes [file]'s mtime to the 29 | pipe every time it changes or there's an error. The first time in the pipe will be 30 | [file]'s current mtime. To stop polling, close the pipe. *) 31 | val when_file_changes 32 | : ?time_source:Time_source.t 33 | -> ?poll_delay:Time.Span.t 34 | -> string 35 | -> (Time.t, exn) Result.t Pipe.Reader.t 36 | 37 | val is_directory : ?follow_symlinks:bool -> string -> [ `Yes | `No | `Unknown ] Deferred.t 38 | val is_directory_exn : ?follow_symlinks:bool -> string -> bool Deferred.t 39 | val is_file : ?follow_symlinks:bool -> string -> [ `Yes | `No | `Unknown ] Deferred.t 40 | val is_file_exn : ?follow_symlinks:bool -> string -> bool Deferred.t 41 | val is_symlink : string -> [ `Yes | `No | `Unknown ] Deferred.t 42 | val is_symlink_exn : string -> bool Deferred.t 43 | val remove : string -> unit Deferred.t 44 | val rename : string -> string -> unit Deferred.t 45 | val getenv : string -> string option 46 | val getenv_exn : string -> string 47 | val command : string -> int Deferred.t 48 | val command_exn : string -> unit Deferred.t 49 | val quote : string -> string 50 | val concat_quoted : string list -> string 51 | val chdir : string -> unit Deferred.t 52 | val getcwd : unit -> string Deferred.t 53 | val readdir : string -> string array Deferred.t 54 | val ls_dir : string -> string list Deferred.t 55 | val ls_dir_detailed : string -> Core_unix.Readdir_detailed.t list Deferred.t 56 | val home_directory : unit -> string Deferred.t 57 | 58 | (** Direct re-exports from [Core.Sys] *) 59 | 60 | val os_type : string 61 | val unix : bool 62 | val win32 : bool 63 | val cygwin : bool 64 | 65 | type backend_type = Core.Sys.backend_type = 66 | | Native 67 | | Bytecode 68 | | Other of string 69 | 70 | val backend_type : backend_type 71 | val word_size_in_bits : int 72 | val int_size_in_bits : int 73 | val max_string_length : int 74 | val max_array_length : int 75 | val runtime_variant : unit -> string 76 | val runtime_parameters : unit -> string 77 | val enable_runtime_warnings : bool -> unit 78 | val runtime_warnings_enabled : unit -> bool 79 | val interactive : bool ref 80 | val word_size : int [@@deprecated "[since 2024-11] Use [word_size_in_bits] instead."] 81 | val int_size : int [@@deprecated "[since 2024-11] Use [word_size_in_bits] instead."] 82 | val big_endian : bool 83 | val ocaml_version : string 84 | val execution_mode : unit -> [ `Bytecode | `Native ] 85 | val c_int_size : unit -> int 86 | 87 | external opaque_identity : 'a. ('a[@local_opt]) -> ('a[@local_opt]) = "%opaque" 88 | [@@layout_poly] 89 | 90 | external opaque_identity_global : 'a. 'a -> 'a = "%opaque" [@@layout_poly] 91 | -------------------------------------------------------------------------------- /src/async_unix.ml: -------------------------------------------------------------------------------- 1 | module Async_config = Config 2 | module Busy_poller = Busy_poller 3 | module Clock = Clock 4 | module Dump_core_on_job_delay = Dump_core_on_job_delay 5 | module Fd = Fd 6 | module In_thread = In_thread 7 | module Io_stats = Io_stats 8 | module Io_uring_raw = Io_uring_raw 9 | module Io_uring_raw_singleton = Io_uring_raw_singleton 10 | module Io_uring = Io_uring 11 | module Print = Async_print 12 | module Process = Process 13 | module Reader = Reader 14 | module Require_explicit_time_source = Require_explicit_time_source 15 | module Scheduler = Scheduler 16 | module Shutdown = Shutdown 17 | module Signal = Signal 18 | module Socket = Unix_syscalls.Socket 19 | module Sys = Async_sys 20 | module Tcp = Tcp 21 | module Thread_safe = Thread_safe 22 | module Writer = Writer 23 | 24 | module Unix = struct 25 | module Fd = Fd 26 | 27 | include Unix_syscalls (** @open *) 28 | end 29 | 30 | let after = Clock.after 31 | let at = Clock.at 32 | let every = Clock.every 33 | let with_timeout = Clock.with_timeout 34 | let schedule = Scheduler.schedule 35 | let schedule' = Scheduler.schedule' 36 | let shutdown = Shutdown.shutdown 37 | let within = Scheduler.within 38 | let within' = Scheduler.within' 39 | 40 | (* We rebind all pervasive and some Core functions that deal with I/O so that one 41 | doesn't unintentionally do blocking stuff in an Async program. *) 42 | 43 | (** Shadow blocking functions in [Core.Printf] to prevent their unintentional use. *) 44 | module Printf = struct 45 | let _shadow = `Probably_should_not_use_blocking_Core_Printf_functions_with_Async 46 | let bprintf = Core.Printf.bprintf 47 | let eprintf = _shadow 48 | let exitf = _shadow 49 | let failwithf = Core.Printf.failwithf 50 | let fprintf _ = _shadow 51 | let ifprintf _ = Core.Printf.ifprintf 52 | let invalid_argf = Core.Printf.invalid_argf 53 | let kbprintf = Core.Printf.kbprintf 54 | let kfprintf _ _ = _shadow 55 | let ksprintf = Core.Printf.ksprintf 56 | let printf = _shadow 57 | let sprintf = Core.Printf.sprintf 58 | end 59 | 60 | include struct 61 | open Core 62 | 63 | module Overwrite_ = struct 64 | let overwrite1 (`This_is_async__Think_about_blocking as x) = x 65 | let overwrite2 `This_is_async__Think_about_blocking = overwrite1 66 | let overwrite3 `This_is_async__Think_about_blocking = overwrite2 67 | let overwrite4 `This_is_async__Think_about_blocking = overwrite3 68 | end 69 | 70 | open Overwrite_ 71 | 72 | let close_in_noerr = overwrite1 73 | let close_in = overwrite1 74 | let close_out_noerr = overwrite1 75 | let close_out = overwrite1 76 | let eprintf = Print.eprintf 77 | let flush_all = overwrite1 78 | let flush = overwrite1 79 | let fprintf = Print.fprintf 80 | let ifprintf = Printf.ifprintf 81 | let in_channel_length = overwrite1 82 | let input_binary_int = overwrite1 83 | let input_byte = overwrite1 84 | let input_char = overwrite1 85 | let input_line = overwrite1 86 | let input_lines ?fix_win_eol:_ = overwrite1 87 | let input = overwrite4 88 | let input_value = overwrite1 89 | let open_in_bin = overwrite1 90 | let open_in_gen = overwrite3 91 | let open_in = overwrite1 92 | let open_out_bin = overwrite1 93 | let open_out_gen = overwrite3 94 | let open_out = overwrite1 95 | let out_channel_length = overwrite1 96 | let output_binary_int = overwrite2 97 | let output_byte = overwrite2 98 | let output_char = overwrite2 99 | let output = overwrite4 100 | let output_string = overwrite2 101 | let output_value = overwrite2 102 | let pos_in = overwrite1 103 | let pos_out = overwrite1 104 | let prerr_char = Print.prerr_char 105 | let prerr_endline = Print.prerr_endline 106 | let prerr_float = Print.prerr_float 107 | let prerr_int = Print.prerr_int 108 | let prerr_newline = Print.prerr_newline 109 | let prerr_string = Print.prerr_string 110 | let print_char = Print.print_char 111 | let print_endline = Print.print_endline 112 | let print_float = Print.print_float 113 | let printf = Print.printf 114 | let print_int = Print.print_int 115 | let print_newline = Print.print_newline 116 | let print_s = Print.print_s 117 | let print_string = Print.print_string 118 | let read_float = overwrite1 119 | let read_int = overwrite1 120 | let read_line = overwrite1 121 | let read_lines = overwrite1 122 | let read_wrap ?binary:_ ~f:_ = overwrite1 123 | let really_input = overwrite4 124 | let seek_in = overwrite2 125 | let seek_out = overwrite1 126 | let set_binary_mode_in = overwrite2 127 | let set_binary_mode_out = overwrite2 128 | let write_lines = overwrite2 129 | let write_wrap ?binary:_ ~f:_ = overwrite1 130 | 131 | let (eprint_s 132 | [@deprecated 133 | "[since 2019-12] If you want to the blocking version, use [Core.eprint_s] (this \ 134 | preserves behavior, but is discouraged). If you want the nonblocking version, use \ 135 | [eprint_s_nonblocking] or [Print.eprint_s]"]) 136 | = 137 | overwrite1 138 | ;; 139 | 140 | let eprint_s_nonblocking = Print.eprint_s 141 | 142 | module LargeFile = struct 143 | let seek_out = overwrite1 144 | let pos_out = overwrite1 145 | let out_channel_length = overwrite1 146 | let seek_in = overwrite1 147 | let pos_in = overwrite1 148 | let in_channel_length = overwrite1 149 | end 150 | 151 | module Sexp : sig 152 | include module type of struct 153 | include Sexp 154 | end 155 | 156 | val save : ?perm:int -> string -> t -> unit 157 | [@@alert blocking "Use [Writer.save_sexp ~hum:false] to avoid blocking."] 158 | 159 | val save_hum : ?perm:int -> string -> t -> unit 160 | [@@alert blocking "Use [Writer.save_sexp ~hum:true] to avoid blocking."] 161 | 162 | val save_mach : ?perm:int -> string -> t -> unit 163 | [@@alert blocking "Use [Writer.save_sexp ~hum:false] to avoid blocking."] 164 | 165 | val save_sexps : ?perm:int -> string -> t list -> unit 166 | [@@alert blocking "Use [Writer.save_sexps ~hum:false] to avoid blocking."] 167 | 168 | val save_sexps_hum : ?perm:int -> string -> t list -> unit 169 | [@@alert blocking "Use [Writer.save_sexps ~hum:true] to avoid blocking."] 170 | 171 | val save_sexps_mach : ?perm:int -> string -> t list -> unit 172 | [@@alert blocking "Use [Writer.save_sexps ~hum:false] to avoid blocking."] 173 | end = 174 | Sexp 175 | end 176 | 177 | let exit = Shutdown.exit 178 | 179 | (**/**) 180 | 181 | module Async_unix_private = struct 182 | module By_descr = By_descr 183 | module Raw_fd = Raw_fd 184 | module Raw_scheduler = Raw_scheduler 185 | module Syscall = Syscall 186 | end 187 | 188 | (** [For_tests] is a too common name, so having [open Async] bring it in scope is too high 189 | potential for confusion. *) 190 | module Async_for_tests = struct 191 | (** Initialize all Async subsystems that allocate fds. This can be used when checking 192 | for fd leaks, to distinguish expected fd "leaks" from unexpected ones. *) 193 | let allocate_all_fds () = 194 | let _ : Scheduler.t = Raw_scheduler.t () in 195 | let _io_uring : _ option = Io_uring.the_one_and_only () in 196 | Async_kernel.Deferred.return () 197 | ;; 198 | end 199 | -------------------------------------------------------------------------------- /src/backing_out_channel.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | type t = 5 | { output : Bigstring.t -> pos:int -> len:int -> unit 6 | ; flush : unit -> unit 7 | ; sexp : unit -> Sexp.t 8 | } 9 | [@@deriving fields ~getters ~iterators:iter] 10 | 11 | let sexp_of_t t = t.sexp () 12 | 13 | let invariant t = 14 | Invariant.invariant t [%sexp_of: t] (fun () -> 15 | let _check f = Invariant.check_field t f in 16 | Fields.iter ~output:ignore ~flush:ignore ~sexp:ignore) 17 | ;; 18 | 19 | let create ~output ~flush ~sexp = { output; flush; sexp } 20 | 21 | let of_out_channel out_channel : t = 22 | let bytes_buf = Bytes.of_string "" |> ref in 23 | create 24 | ~output:(fun buf ~pos ~len -> 25 | if len > Bytes.length !bytes_buf then bytes_buf := Bytes.create (len * 2); 26 | Bigstring.To_bytes.blit ~len ~src:buf ~src_pos:pos ~dst:!bytes_buf ~dst_pos:0; 27 | Out_channel.output out_channel ~buf:!bytes_buf ~pos:0 ~len) 28 | ~flush:(fun () -> Out_channel.flush out_channel) 29 | ~sexp:(fun () -> [%sexp { out_channel : Out_channel.t }]) 30 | ;; 31 | 32 | let output_iovec t (iovec : Bigstring.t Core_unix.IOVec.t) = 33 | t.output iovec.buf ~pos:iovec.pos ~len:iovec.len 34 | ;; 35 | 36 | let flush t = t.flush () 37 | -------------------------------------------------------------------------------- /src/backing_out_channel.mli: -------------------------------------------------------------------------------- 1 | (** [Backing_out_channel] generalizes [Out_channel] to a narrow interface that can be used 2 | to collect strings, etc. *) 3 | 4 | open! Core 5 | open! Import 6 | 7 | type t [@@deriving sexp_of] 8 | 9 | include Invariant.S with type t := t 10 | 11 | val of_out_channel : Out_channel.t -> t 12 | 13 | val create 14 | : output:(bigstring -> pos:int -> len:int -> unit) 15 | -> flush:(unit -> unit) 16 | -> sexp:(unit -> Sexp.t) 17 | -> t 18 | 19 | val output_iovec : t -> Bigstring.t Core_unix.IOVec.t -> unit 20 | val flush : t -> unit 21 | -------------------------------------------------------------------------------- /src/busy_poller.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module type S = Busy_poller_intf.S 4 | 5 | module Empty_poller = struct 6 | type t = unit 7 | 8 | let poll (_t : t) ~deadline:_ = 0 9 | let kind = Type_equal.Id.create ~name:"empty" [%sexp_of: _] 10 | end 11 | 12 | module Extra_poller = struct 13 | type t = deadline:Time_stamp_counter.t -> int 14 | 15 | let poll (t : t) ~deadline = t ~deadline 16 | let kind = Type_equal.Id.create ~name:"extra" [%sexp_of: _] 17 | end 18 | 19 | type packed = T : (module S with type t = 'a) * 'a -> packed 20 | 21 | let[@inline always] poll (T ((module P), poller)) ~deadline = P.poll poller ~deadline 22 | let create impl poller = T (impl, poller) 23 | let create' f = create (module Extra_poller) f 24 | let empty = create (module Empty_poller) () 25 | -------------------------------------------------------------------------------- /src/busy_poller.mli: -------------------------------------------------------------------------------- 1 | include Busy_poller_intf.Busy_poller (** @inline *) 2 | -------------------------------------------------------------------------------- /src/busy_poller_intf.ml: -------------------------------------------------------------------------------- 1 | (** Busy pollers are added to the scheduler via [Scheduler.add_busy_poller]. Before each 2 | Async cycle, the Scheduler will call each busy poller at least once, but possibly 3 | multiple times if there's no Async work to do. 4 | 5 | It is expected that a single call to [poll] does multiple iterations. The busy poll 6 | loop is planned to run until [~deadline]. Pollers should use this parameter to decide 7 | how many iterations to run. In particular, if we know there is Async work to do, 8 | [~deadline] will be in the past and pollers are requested to do a single iteration. *) 9 | 10 | open Core 11 | 12 | module type S = sig 13 | type t 14 | 15 | val poll : t -> deadline:Time_stamp_counter.t -> int 16 | val kind : t Type_equal.Id.t 17 | end 18 | 19 | module type Busy_poller = sig 20 | module type S = S 21 | 22 | type poll_f := deadline:Time_stamp_counter.t -> int 23 | 24 | module Empty_poller : S with type t = unit 25 | module Extra_poller : S with type t = poll_f 26 | 27 | type packed = T : (module S with type t = 'a) * 'a -> packed 28 | 29 | val poll : packed -> deadline:Time_stamp_counter.t -> int 30 | val create : (module S with type t = 'a) -> 'a -> packed 31 | val create' : poll_f -> packed 32 | val empty : packed 33 | end 34 | -------------------------------------------------------------------------------- /src/by_descr.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | type 'a t = 'a Option_array.t 5 | 6 | let capacity t = Option_array.length t 7 | 8 | let create ~num_file_descrs = 9 | if num_file_descrs < 0 10 | then 11 | raise_s 12 | [%message 13 | "[By_descr.create] got negative [num_file_descrs]" (num_file_descrs : int)]; 14 | Option_array.create ~len:num_file_descrs 15 | ;; 16 | 17 | let bounds_check t file_descr = 18 | let i = file_descr |> File_descr.to_int in 19 | 0 <= i && i < capacity t 20 | ;; 21 | 22 | let bounds_check_error t file_descr = 23 | [%message 24 | "The file descriptor is not in the range that Async allows, which probably means \ 25 | that the program has created too many file descriptors without closing them. You \ 26 | can cause Async to allow more file descriptors via the [ASYNC_CONFIG] environment \ 27 | variable, like this: ASYNC_CONFIG='((max_num_open_file_descrs ))' foo.exe \ 28 | arg1 arg2 ..." 29 | (file_descr : File_descr.t) 30 | ~min_file_descr:0 31 | ~max_file_descr:(capacity t - 1 : int)] 32 | ;; 33 | 34 | let bounds_check_exn t file_descr = 35 | if not (bounds_check t file_descr) then raise_s (bounds_check_error t file_descr) 36 | ;; 37 | 38 | let mem t file_descr = 39 | bounds_check t file_descr && Option_array.is_some t (file_descr |> File_descr.to_int) 40 | ;; 41 | 42 | let find t file_descr = 43 | if not (bounds_check t file_descr) 44 | then None 45 | else Option_array.get t (file_descr |> File_descr.to_int) 46 | ;; 47 | 48 | let find_exn t file_descr = 49 | bounds_check_exn t file_descr; 50 | if Option_array.is_none t (file_descr |> File_descr.to_int) 51 | then 52 | raise_s 53 | [%message "[By_descr.find_exn] got unknown file_descr" (file_descr : File_descr.t)]; 54 | Option_array.get_some_exn t (file_descr |> File_descr.to_int) 55 | ;; 56 | 57 | let remove t (fd : File_descr.t) = 58 | bounds_check_exn t fd; 59 | Option_array.set_none t (fd |> File_descr.to_int) 60 | ;; 61 | 62 | let add t file_descr v = 63 | if not (bounds_check t file_descr) 64 | then error_s (bounds_check_error t file_descr) 65 | else if Option_array.is_some t (file_descr |> File_descr.to_int) 66 | then 67 | error_s 68 | [%message 69 | "Attempt to register a file descriptor with Async that Async believes it is \ 70 | already managing."] 71 | else ( 72 | Option_array.set_some t (file_descr |> File_descr.to_int) v; 73 | Ok ()) 74 | ;; 75 | 76 | let fold t ~init ~f = 77 | let r = ref init in 78 | for i = 0 to capacity t - 1 do 79 | if Option_array.is_some t i then r := f !r (Option_array.get_some_exn t i) 80 | done; 81 | !r 82 | ;; 83 | 84 | let foldi t ~init ~f = 85 | let r = ref init in 86 | for i = 0 to capacity t - 1 do 87 | if Option_array.is_some t i then r := f i !r (Option_array.get_some_exn t i) 88 | done; 89 | !r 90 | ;; 91 | 92 | let iter t ~f = 93 | for i = 0 to capacity t - 1 do 94 | if Option_array.is_some t i then f (Option_array.get_some_exn t i) 95 | done 96 | ;; 97 | 98 | let exists t ~f = 99 | Option_array.exists t ~f:(function 100 | | None -> false 101 | | Some x -> f x) 102 | ;; 103 | 104 | (* The default sexp representation of this is huge and pollutes debug output *) 105 | let sexp_of_t sexp_of t = 106 | let fd_alist = foldi ~init:[] t ~f:(fun i acc x -> (i, sexp_of x) :: acc) in 107 | [%sexp_of: (int * Sexp.t) list] (List.rev fd_alist) 108 | ;; 109 | 110 | let invariant t = 111 | try 112 | for i = 0 to capacity t - 1 do 113 | match Option_array.get t i with 114 | | None -> () 115 | | Some fd -> 116 | Raw_fd.invariant fd; 117 | assert (File_descr.equal (i |> File_descr.of_int) (Raw_fd.file_descr fd)) 118 | done 119 | with 120 | | exn -> 121 | raise_s [%message "By_descr.invariant failure" (exn : exn) ~fd:(t : Raw_fd.t t)] 122 | ;; 123 | -------------------------------------------------------------------------------- /src/by_descr.mli: -------------------------------------------------------------------------------- 1 | (** [Fd_by_descr] is a table of the open [Fd.t]s, indexed by file descriptor number. 2 | 3 | In this interface, we use [Raw_fd.t] rather than [Fd.t] to avoid a dependency cycle, 4 | because the [Fd] module can't be defined yet. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | type 'a t [@@deriving sexp_of] 10 | 11 | include Invariant.S with type t := Raw_fd.t t 12 | 13 | val create : num_file_descrs:int -> 'a t 14 | val capacity : 'a t -> int 15 | val add : 'a t -> File_descr.t -> 'a -> unit Or_error.t 16 | val mem : 'a t -> File_descr.t -> bool 17 | val find : 'a t -> File_descr.t -> 'a option 18 | val find_exn : 'a t -> File_descr.t -> 'a 19 | val remove : 'a t -> File_descr.t -> unit 20 | val fold : 'a t -> init:'acc -> f:('acc -> 'a -> 'acc) -> 'acc 21 | val iter : 'a t -> f:('a -> unit) -> unit 22 | val exists : 'a t -> f:('a -> bool) -> bool 23 | -------------------------------------------------------------------------------- /src/clock.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | open Async_kernel.Clock_ns 4 | module Or_timeout = Or_timeout 5 | 6 | let run_at time f a = run_at (Time_ns.of_time_float_round_nearest time) f a 7 | let run_after span f a = run_after (Time_ns.Span.of_span_float_round_nearest span) f a 8 | let at time = at (Time_ns.of_time_float_round_nearest time) 9 | let after span = after (Time_ns.Span.of_span_float_round_nearest span) 10 | let with_timeout span d = with_timeout (Time_ns.Span.of_span_float_round_nearest span) d 11 | 12 | let with_timeout_exn span d ~error = 13 | with_timeout_exn (Time_ns.Span.of_span_float_round_nearest span) d ~error 14 | ;; 15 | 16 | module Event = struct 17 | module Abort_result = Event.Abort_result 18 | module Fired = Event.Fired 19 | module Reschedule_result = Event.Reschedule_result 20 | 21 | type ('a, 'h) t = ('a, 'h) Event.t [@@deriving sexp_of] 22 | type t_unit = Event.t_unit [@@deriving sexp_of] 23 | 24 | let invariant = Event.invariant 25 | let abort = Event.abort 26 | let abort_exn = Event.abort_exn 27 | let abort_if_possible = Event.abort_if_possible 28 | let fired = Event.fired 29 | let scheduled_at t = Time_ns.to_time_float_round_nearest (Event.scheduled_at t) 30 | let at time = Event.at (Time_ns.of_time_float_round_nearest time) 31 | let after span = Event.after (Time_ns.Span.of_span_float_round_nearest span) 32 | 33 | let reschedule_at t time = 34 | Event.reschedule_at t (Time_ns.of_time_float_round_nearest time) 35 | ;; 36 | 37 | let reschedule_after t span = 38 | Event.reschedule_after t (Time_ns.Span.of_span_float_round_nearest span) 39 | ;; 40 | 41 | let run_at time f x = Event.run_at (Time_ns.of_time_float_round_nearest time) f x 42 | 43 | let run_after span f x = 44 | Event.run_after (Time_ns.Span.of_span_float_round_nearest span) f x 45 | ;; 46 | 47 | module Status = struct 48 | type ('a, 'h) t = 49 | | Aborted of 'a 50 | | Happened of 'h 51 | | Scheduled_at of Time.t 52 | [@@deriving sexp_of] 53 | end 54 | 55 | let status t : _ Status.t = 56 | match Event.status t with 57 | | Aborted a -> Aborted a 58 | | Happened h -> Happened h 59 | | Scheduled_at time -> Scheduled_at (Time_ns.to_time_float_round_nearest time) 60 | ;; 61 | end 62 | 63 | let at_varying_intervals ?stop f = 64 | at_varying_intervals ?stop (fun () -> Time_ns.Span.of_span_float_round_nearest (f ())) 65 | ;; 66 | 67 | let at_intervals ?start ?stop span = 68 | let start = Option.map start ~f:Time_ns.of_time_float_round_nearest in 69 | at_intervals ?start ?stop (Time_ns.Span.of_span_float_round_nearest span) 70 | ;; 71 | 72 | let every' ?start ?stop ?continue_on_error ?finished span f = 73 | every' 74 | ?start 75 | ?stop 76 | ?continue_on_error 77 | ?finished 78 | (Time_ns.Span.of_span_float_round_nearest span) 79 | f 80 | ;; 81 | 82 | let every ?start ?stop ?continue_on_error span f = 83 | every ?start ?stop ?continue_on_error (Time_ns.Span.of_span_float_round_nearest span) f 84 | ;; 85 | 86 | let run_at_intervals' ?start ?stop ?continue_on_error ?finished span f = 87 | let start = Option.map start ~f:Time_ns.of_time_float_round_nearest in 88 | run_at_intervals' 89 | ?start 90 | ?stop 91 | ?continue_on_error 92 | ?finished 93 | (Time_ns.Span.of_span_float_round_nearest span) 94 | f 95 | ;; 96 | 97 | let run_at_intervals ?start ?stop ?continue_on_error span f = 98 | let start = Option.map start ~f:Time_ns.of_time_float_round_nearest in 99 | run_at_intervals 100 | ?start 101 | ?stop 102 | ?continue_on_error 103 | (Time_ns.Span.of_span_float_round_nearest span) 104 | f 105 | ;; 106 | 107 | let duration_of f = 108 | let%map res, span = duration_of f in 109 | res, Time_ns.Span.to_span_float_round_nearest span 110 | ;; 111 | -------------------------------------------------------------------------------- /src/clock.mli: -------------------------------------------------------------------------------- 1 | (** A {{!Async_kernel.Clock_intf.Clock} [Clock]} based on [Core.Time]. *) 2 | 3 | open! Core 4 | open! Import 5 | 6 | include Async_kernel.Clock_ns.Clock with module Time := Time (** @open *) 7 | -------------------------------------------------------------------------------- /src/config.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Unix = Core_unix 3 | include Async_kernel.Async_kernel_config 4 | 5 | let file_descr_watcher = 6 | match file_descr_watcher with 7 | | (Epoll | Select | Io_uring) as x -> x 8 | | Epoll_if_timerfd -> 9 | (* Without timerfd, epoll_wait(2) timeouts would have only millisecond precision. *) 10 | if Result.is_ok Linux_ext.Timerfd.create then Epoll else Select 11 | ;; 12 | 13 | let max_num_open_file_descrs = 14 | if not 15 | (Max_num_open_file_descrs.equal 16 | max_num_open_file_descrs 17 | Max_num_open_file_descrs.default) 18 | then max_num_open_file_descrs 19 | else ( 20 | match file_descr_watcher with 21 | | Select -> 22 | (* The maximum numeric value for a file descriptor watchable by [select] is limited 23 | by [FD_SETSIZE], which happens to be 1024 on Linux. *) 24 | Max_num_open_file_descrs.create_exn 1024 25 | | Epoll | Epoll_if_timerfd | Io_uring -> 26 | Int.min 27 | Max_num_open_file_descrs.(default |> raw) 28 | (match Unix.RLimit.(get num_file_descriptors).max with 29 | | Infinity -> Int.max_value 30 | | Limit int64 -> int64 |> Int64.to_int_exn) 31 | |> Max_num_open_file_descrs.create_exn) 32 | ;; 33 | -------------------------------------------------------------------------------- /src/config.mli: -------------------------------------------------------------------------------- 1 | include module type of struct 2 | include Async_kernel.Async_kernel_config 3 | end 4 | -------------------------------------------------------------------------------- /src/dump_core_on_job_delay.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | module Dump_type = struct 5 | (* This variant mirrors an enum in the C, so order in this declaration matters. *) 6 | type t = 7 | | Call_abort 8 | | Call_gcore 9 | end 10 | 11 | external dump_core : Dump_type.t -> unit = "dump_core_on_job_delay_dump_core" 12 | external watch : float -> Dump_type.t -> unit = "dump_core_on_job_delay_watch" 13 | external tick : unit -> unit = "dump_core_on_job_delay_tick" 14 | 15 | module How_to_dump = struct 16 | include Config.Dump_core_on_job_delay.How_to_dump 17 | 18 | let choose_dump_type : t -> Dump_type.t = function 19 | | Call_abort -> Call_abort 20 | | Call_gcore -> Call_gcore 21 | | Default -> 22 | (match Sys_unix.file_exists "/usr/bin/gcore" with 23 | | `Yes -> Call_gcore 24 | | `No | `Unknown -> Call_abort) 25 | ;; 26 | end 27 | 28 | let start_watching ~dump_if_delayed_by ~how_to_dump = 29 | let dump_type = How_to_dump.choose_dump_type how_to_dump in 30 | let dump_if_delayed_by_sec = Time.Span.to_sec dump_if_delayed_by in 31 | let tick_interval = sec (dump_if_delayed_by_sec /. 10.) in 32 | ignore 33 | (Thread.create 34 | ~on_uncaught_exn:`Print_to_stderr 35 | (fun () -> watch dump_if_delayed_by_sec dump_type) 36 | () 37 | : Thread.t); 38 | Clock.every tick_interval tick 39 | ;; 40 | 41 | let dump_core ?(how_to_dump = How_to_dump.Default) () = 42 | dump_core (How_to_dump.choose_dump_type how_to_dump) 43 | ;; 44 | -------------------------------------------------------------------------------- /src/dump_core_on_job_delay.mli: -------------------------------------------------------------------------------- 1 | (** Dump core if jobs are delayed, to get additional debug information when running on 2 | UNIX systems that support core dumps. 3 | 4 | It is not normally enabled, but may be enabled for any program by setting the 5 | appropriate field, [dump_core_on_job_delay], in the [ASYNC_CONFIG] environment 6 | variable. *) 7 | 8 | open! Core 9 | open! Import 10 | 11 | module How_to_dump : sig 12 | type t = Config.Dump_core_on_job_delay.How_to_dump.t = 13 | | Default 14 | | Call_abort 15 | | Call_gcore 16 | [@@deriving sexp_of] 17 | end 18 | 19 | (** [start_watching] starts a regular async job (via [Clock.every]) that increments a 20 | counter, and a C thread to make sure that the counter is incremented in a timely 21 | manner. *) 22 | val start_watching : dump_if_delayed_by:Time.Span.t -> how_to_dump:How_to_dump.t -> unit 23 | 24 | (** [dump_core ()] dumps a core file using [/usr/bin/gcore] if it exists, or by calling 25 | [abort()] if not (or with [~how_to_dump:Call_abort]). With gcore, the dump is done in 26 | a child process, and the core file is written to [/tmp/core.$N.$PID], where [$PID] is 27 | the process id and [$N] is a counter that is incremented on each call to [dump_core]. *) 28 | val dump_core : ?how_to_dump:How_to_dump.t -> unit -> unit 29 | -------------------------------------------------------------------------------- /src/dump_core_on_job_delay_stubs.c: -------------------------------------------------------------------------------- 1 | #define _GNU_SOURCE 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include "ocaml_utils.h" 12 | 13 | /* this type must be kept strictly in sync with the OCaml type */ 14 | typedef enum { 15 | CALL_ABORT = 0, 16 | CALL_GCORE = 1, 17 | DUMP_TYPE_LIMIT = 2 /* used to catch mismatch between this type and the OCaml type */ 18 | } core_dump_type; 19 | 20 | static int num_ticks = 0; /* updated by regular Async job */ 21 | static int core_dump_count = 0; 22 | 23 | #define CORE_FILENAME_MAX_LEN (4 + 1 + 10 + 1) 24 | 25 | /* max pid is 2^22 on 64 bit systems, which is 7 digits + 1 for terminating NULL. */ 26 | #define PID_STR_MAX_LEN 10 27 | 28 | static void dump_core (core_dump_type dump_type) 29 | { 30 | pid_t main_pid = getpid (); 31 | pid_t fork_pid; 32 | int status; 33 | char gcore_path[] = "/usr/bin/gcore"; 34 | char pid_str[PID_STR_MAX_LEN]; 35 | char core_filename[CORE_FILENAME_MAX_LEN]; /* core.. */ 36 | char *args[] = { NULL, NULL, NULL, NULL, NULL }; 37 | char *env[] = { NULL }; 38 | 39 | core_dump_count = core_dump_count + 1; 40 | 41 | switch (dump_type) { 42 | case CALL_ABORT: 43 | abort (); 44 | break; 45 | case CALL_GCORE: 46 | fork_pid = fork (); 47 | if (fork_pid) { 48 | waitpid (fork_pid, &status, 0); 49 | } else { 50 | assert (snprintf (core_filename, CORE_FILENAME_MAX_LEN, "core.%i", 51 | core_dump_count) 52 | < CORE_FILENAME_MAX_LEN); 53 | assert (snprintf (pid_str, PID_STR_MAX_LEN, "%d", main_pid) < PID_STR_MAX_LEN); 54 | args[0] = gcore_path; 55 | args[1] = "-o"; 56 | args[2] = core_filename; 57 | args[3] = pid_str; 58 | execve(gcore_path, args, env); 59 | }; 60 | break; 61 | case DUMP_TYPE_LIMIT: 62 | caml_leave_blocking_section(); 63 | caml_failwith ("bug in dump_core_on_job_delay_dump_core"); 64 | }; 65 | } 66 | 67 | CAMLprim value dump_core_on_job_delay_dump_core (value v_dump_type) 68 | { 69 | CAMLparam1 (v_dump_type); 70 | core_dump_type dump_type = Int_val (v_dump_type); 71 | if ( dump_type >= DUMP_TYPE_LIMIT ) 72 | caml_failwith ("bug in dump_core_on_job_delay_dump_core"); 73 | dump_core (dump_type); 74 | CAMLreturn (Val_unit); 75 | } 76 | 77 | CAMLprim value dump_core_on_job_delay_watch (value v_dump_if_delayed_by, 78 | value v_dump_type) 79 | { 80 | CAMLparam2 (v_dump_if_delayed_by, v_dump_type); 81 | 82 | useconds_t dump_if_delayed_by = Double_val (v_dump_if_delayed_by) * 1000 * 1000; 83 | core_dump_type dump_type = CALL_ABORT; 84 | int last_num_ticks_seen = num_ticks; 85 | bool already_dumped_this_cycle = false; 86 | 87 | dump_type = Int_val (v_dump_type); 88 | if ( dump_type >= DUMP_TYPE_LIMIT ) 89 | caml_failwith ("bug in dump_core_on_job_delay_watch"); 90 | 91 | /* We give up the CAML lock because we intend to run the following 92 | loop for the life of the program. */ 93 | caml_enter_blocking_section(); 94 | 95 | for (;;) { 96 | usleep (dump_if_delayed_by); 97 | 98 | /* If [last_num_ticks_seen] is the same as the last time we woke 99 | up, then the Async tick job has been delayed. */ 100 | if (last_num_ticks_seen == num_ticks) { 101 | if (!already_dumped_this_cycle) { 102 | already_dumped_this_cycle = true; 103 | dump_core (dump_type); 104 | } 105 | } else { 106 | /* Otherwise, if the count has changed, and we reset everything. */ 107 | already_dumped_this_cycle = false; 108 | last_num_ticks_seen = num_ticks; 109 | }; 110 | }; 111 | 112 | caml_leave_blocking_section(); 113 | 114 | CAMLreturn (Val_unit); 115 | } 116 | 117 | CAMLprim value dump_core_on_job_delay_tick (value v_unit) 118 | { 119 | /* Not strictly needed, but it keeps the compiler from complaining 120 | about an unused [v_unit] arg, and there really isn't a need to make 121 | this as fast as possible. */ 122 | CAMLparam1 (v_unit); 123 | num_ticks = num_ticks + 1; 124 | CAMLreturn (Val_unit); 125 | } 126 | 127 | 128 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (foreign_stubs 3 | (language c) 4 | (names dump_core_on_job_delay_stubs magic_trace_stubs)) 5 | (name async_unix) 6 | (public_name async_unix) 7 | (libraries async_kernel core_unix.bigstring_unix 8 | core_kernel.bounded_int_table core_kernel.caml_unix core 9 | core_unix.core_thread core_unix cstruct async_kernel.eager_deferred 10 | core_unix.filename_unix core_kernel.iobuf core_unix.iobuf_unix 11 | core_unix.linux_ext core_unix.nano_mutex async_kernel.read_write_pair 12 | sexplib core_unix.signal_unix core_unix.squeue core_unix.sys_unix 13 | thread_pool thread_safe_ivar core_kernel.thread_safe_queue 14 | core_unix.time_float_unix core_unix.time_ns_unix 15 | core_unix.time_stamp_counter) 16 | (preprocessor_deps io_uring_config.h) 17 | (preprocess 18 | (pps ppx_jane ppx_optcomp))) 19 | -------------------------------------------------------------------------------- /src/epoll_file_descr_watcher.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | open File_descr_watcher_intf 4 | open Read_write_pair.Export 5 | module Epoll = Linux_ext.Epoll 6 | module Timerfd = Linux_ext.Timerfd 7 | 8 | module Flags = struct 9 | include Epoll.Flags 10 | 11 | let in_out = in_ + out 12 | 13 | (* Use the edge-triggered behavior so we don't have to reset the timerfd when it 14 | expires. *) 15 | let for_timerfd = in_ + et 16 | 17 | let of_rw = function 18 | | `Read -> in_ 19 | | `Write -> out 20 | ;; 21 | end 22 | 23 | type t = 24 | { timerfd : Timerfd.t 25 | ; epoll : Epoll.t 26 | ; handle_fd_read_ready : File_descr.t -> Flags.t -> unit 27 | ; handle_fd_write_ready : File_descr.t -> Flags.t -> unit 28 | } 29 | [@@deriving sexp_of, fields ~iterators:iter] 30 | 31 | let backend = Config.File_descr_watcher.Epoll 32 | let is_timerfd t fd = File_descr.equal fd (Timerfd.to_file_descr t.timerfd) 33 | 34 | let invariant t : unit = 35 | try 36 | let check f field = f (Field.get field t) in 37 | Fields.iter 38 | ~timerfd: 39 | (check (fun timerfd -> 40 | [%test_result: Flags.t option] 41 | (Epoll.find t.epoll (Timerfd.to_file_descr timerfd)) 42 | ~expect:(Some Flags.for_timerfd))) 43 | ~epoll: 44 | (check (fun epoll -> 45 | Epoll.iter epoll ~f:(fun _ flags -> 46 | assert ( 47 | List.exists 48 | Flags.[ in_; out; in_out; for_timerfd ] 49 | ~f:(fun flags' -> Flags.equal flags flags'))))) 50 | ~handle_fd_read_ready:ignore 51 | ~handle_fd_write_ready:ignore 52 | with 53 | | exn -> 54 | raise_s 55 | [%message 56 | "Epoll_file_descr_watcher.invariant failed" 57 | (exn : exn) 58 | ~epoll_file_descr_watcher:(t : t)] 59 | ;; 60 | 61 | type 'a additional_create_args = timerfd:Linux_ext.Timerfd.t -> 'a 62 | 63 | let create ~timerfd ~num_file_descrs ~handle_fd_read_ready ~handle_fd_write_ready = 64 | let epoll = 65 | Or_error.ok_exn 66 | Epoll.create 67 | ~num_file_descrs 68 | ~max_ready_events:(Epoll_max_ready_events.raw Config.epoll_max_ready_events) 69 | in 70 | let err_or_hup = Flags.(hup + err) in 71 | let handle_fd read_or_write handle_fd = 72 | let bit = Flags.of_rw read_or_write in 73 | fun file_descr flags -> 74 | (* A difference between select and epoll crops up here: epoll has implicit event 75 | flags for hangup (HUP) and error (ERR), whereas select will just return that fd 76 | as "ready" in its appropriate fd_set. Since we don't know if it's ready for IN 77 | or OUT, we have to go lookup the entry if the HUP or ERR flag is set. *) 78 | if Flags.do_intersect flags bit 79 | || (Flags.do_intersect flags err_or_hup 80 | && Flags.do_intersect (Epoll.find_exn epoll file_descr) bit) 81 | then handle_fd file_descr 82 | in 83 | Epoll.set epoll (Timerfd.to_file_descr timerfd) Flags.for_timerfd; 84 | { timerfd 85 | ; epoll 86 | ; handle_fd_read_ready = handle_fd `Read handle_fd_read_ready 87 | ; handle_fd_write_ready = handle_fd `Write handle_fd_write_ready 88 | } 89 | ;; 90 | 91 | let reset_in_forked_process t = Epoll.close t.epoll 92 | 93 | let iter t ~f = 94 | Epoll.iter t.epoll ~f:(fun file_descr flags -> 95 | if not (is_timerfd t file_descr) 96 | then ( 97 | if Flags.do_intersect flags Flags.in_ then f file_descr `Read; 98 | if Flags.do_intersect flags Flags.out then f file_descr `Write)) 99 | ;; 100 | 101 | let set t file_descr desired = 102 | let actual_flags = Epoll.find t.epoll file_descr in 103 | let desired_flags = 104 | match desired.read, desired.write with 105 | | false, false -> None 106 | | true, false -> Some Flags.in_ 107 | | false, true -> Some Flags.out 108 | | true, true -> Some Flags.in_out 109 | in 110 | match actual_flags, desired_flags with 111 | | None, None -> `Ok 112 | | None, Some d -> 113 | (match Epoll.set t.epoll file_descr d with 114 | | exception Core_unix.Unix_error (EPERM, _, _) -> `Unsupported 115 | | () -> `Ok) 116 | | Some _, None -> 117 | Epoll.remove t.epoll file_descr; 118 | `Ok 119 | | Some a, Some d -> 120 | if not (Flags.equal a d) then Epoll.set t.epoll file_descr d; 121 | `Ok 122 | ;; 123 | 124 | module Pre = struct 125 | type t = unit [@@deriving sexp_of] 126 | end 127 | 128 | let pre_check _t = () 129 | 130 | module Check_result = struct 131 | type t = ([ `Ok | `Timeout ], exn * Backtrace.t) Result.t [@@deriving sexp_of] 132 | 133 | let ok = Ok `Ok 134 | let timeout = Ok `Timeout 135 | end 136 | 137 | let epoll_wait (type a) (epoll : Epoll.t) (timeout : a Timeout.t) (span_or_unit : a) = 138 | match timeout with 139 | | Immediately -> Epoll.wait epoll ~timeout:`Immediately 140 | | After -> Epoll.wait_timeout_after epoll span_or_unit 141 | ;; 142 | 143 | let thread_safe_check t () timeout span_or_unit = 144 | match epoll_wait t.epoll timeout span_or_unit with 145 | | `Ok -> Check_result.ok 146 | | `Timeout -> Check_result.timeout 147 | | exception e -> Error (e, Backtrace.Exn.most_recent ()) 148 | ;; 149 | 150 | let post_check t check_result = 151 | try 152 | match check_result with 153 | (* We think 514 should be treated like EINTR. *) 154 | | Error (Unix.Unix_error ((EINTR | EUNKNOWNERR 514), _, _), _) -> () 155 | | Error (exn, backtrace) -> 156 | raise_s 157 | [%message "epoll raised unexpected exn" (exn : exn) (backtrace : Backtrace.t)] 158 | | Ok `Timeout -> () 159 | | Ok `Ok -> 160 | Epoll.iter_ready t.epoll ~f:t.handle_fd_write_ready; 161 | Epoll.iter_ready t.epoll ~f:t.handle_fd_read_ready; 162 | Epoll.Expert.clear_ready t.epoll 163 | with 164 | | exn -> 165 | let backtrace = Backtrace.Exn.most_recent () in 166 | raise_s 167 | [%message 168 | "Epoll.post_check bug" 169 | (exn : exn) 170 | (backtrace : Backtrace.t) 171 | (check_result : Check_result.t) 172 | ~epoll_file_descr_watcher:(t : t)] 173 | ;; 174 | -------------------------------------------------------------------------------- /src/epoll_file_descr_watcher.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | type 'a additional_create_args = timerfd:Linux_ext.Timerfd.t -> 'a 5 | 6 | include 7 | File_descr_watcher_intf.S 8 | with type 'a additional_create_args := 'a additional_create_args 9 | -------------------------------------------------------------------------------- /src/file_descr_watcher_intf.ml: -------------------------------------------------------------------------------- 1 | (** [File_descr_watcher_intf.S] provides an API for for watching a set of file descriptors 2 | to see if they are ready for reading or writing. 3 | 4 | We have two implementations, one using epoll, and one using select. 5 | 6 | None of the functions need to be thread-safe, with the exception of 7 | [thread_safe_check]. So that implementations can easily do non-thread-safe actions, 8 | checking for ready I/O is always done in three steps: 9 | 10 | 1. [pre_check], while holding the async lock 11 | 2. [thread_safe_check], while not holding the async lock 12 | 3. [post_check], while holding the async lock *) 13 | 14 | open! Core 15 | open Import 16 | 17 | module Timeout = struct 18 | type 'a t = 19 | (*_ performance hack: avoid allocation *) 20 | | Immediately : unit t 21 | | After : Time_ns.Span.t t 22 | 23 | let variant_of : type a. a t -> a -> [ `Immediately | `After of Time_ns.Span.t ] = 24 | fun t span_or_unit -> 25 | match t with 26 | | Immediately -> `Immediately 27 | | After -> `After (span_or_unit : Time_ns.Span.t) 28 | ;; 29 | end 30 | 31 | module type S = sig 32 | (** A file-descr-watcher is essentially a map from [File_descr.t] to 33 | [bool Read_write_pair.t], which defines the set of file descriptors being watched, 34 | and for each file descriptor, whether it is being watched for read, write, or both. 35 | If a file descriptor is not being watched for either, it is not in the map. *) 36 | type t [@@deriving sexp_of] 37 | 38 | include Invariant.S with type t := t 39 | 40 | (** [additional_create_args] abstracts over the additional arguments to different 41 | file-descr-watcher's [create] function. *) 42 | type 'a additional_create_args 43 | 44 | (** [create ~num_file_descrs] creates a new file-descr-watcher that is able to watch 45 | file descriptors in [\[0, num_file_descrs)]. *) 46 | val create 47 | : (num_file_descrs:int 48 | -> handle_fd_read_ready:(File_descr.t -> unit) 49 | -> handle_fd_write_ready:(File_descr.t -> unit) 50 | -> t) 51 | additional_create_args 52 | 53 | val backend : Config.File_descr_watcher.t 54 | 55 | (** [set] alters the map of file descriptors being watched. It will take effect on the 56 | next call to [thread_safe_check]. Calling [set fd] with 57 | [{ read = false, write = false }] removes [fd] from the map. [`Unsupported] can be 58 | returned for file descriptors that do not support polling. This usually (always?) 59 | means that they are always ready for read or write. *) 60 | val set : t -> File_descr.t -> bool Read_write_pair.t -> [ `Ok | `Unsupported ] 61 | 62 | (** [iter t ~f] iterates over every file descriptor in the map, apply [f] to it once for 63 | each of \{`Read,`Write\} that it is being watched for. *) 64 | val iter : t -> f:(File_descr.t -> Read_write_pair.Key.t -> unit) -> unit 65 | 66 | (** [pre_check t] does whatever non-thread-safe work is necessary to prepare for the 67 | system call that checks file descriptors being ready for read or write. [pre_check] 68 | does not side effect [t]. *) 69 | module Pre : sig 70 | type t [@@deriving sexp_of] 71 | end 72 | 73 | val pre_check : t -> Pre.t 74 | 75 | (** [thread_safe_check t pre timeout span_or_unit] checks the file descriptors for their 76 | status and returns when at least one is available, or the [timeout, span_or_unit] 77 | passes. [thread_safe_check] does not side effect [t]. Unlike the rest of the 78 | functions in this module, [thread_safe_check] is thread safe. *) 79 | module Check_result : sig 80 | type t [@@deriving sexp_of] 81 | end 82 | 83 | val thread_safe_check : t -> Pre.t -> 'a Timeout.t -> 'a -> Check_result.t 84 | 85 | (** [post_check t check_result] calls the [handle_fd*] functions supplied to [create]: 86 | 87 | 1. for each file descriptor that is ready to be written to, then 88 | 2. for each file descriptor that is ready to be read from. 89 | 90 | We handle writes before reads so that we get all the writes started going to the 91 | external world before we process all the reads. This will nicely batch together all 92 | the output based on the reads for the next writes. 93 | 94 | It is guaranteed that it calls [handle_fd_read*] only on an [fd] that is watched for 95 | read as per [set], and [handle_fd_write*] only on an [fd] that is watched for write 96 | as per [set]. *) 97 | val post_check : t -> Check_result.t -> unit 98 | 99 | val reset_in_forked_process : t -> unit 100 | end 101 | -------------------------------------------------------------------------------- /src/import.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | module Unix = Core_unix 3 | module Thread = Core_thread 4 | module Time = Time_float_unix 5 | module Time_ns = Time_ns_unix 6 | include Int.Replace_polymorphic_compare 7 | include Async_kernel 8 | module Epoll_max_ready_events = Config.Epoll_max_ready_events 9 | module Io_uring_max_submission_entries = Config.Io_uring_max_submission_entries 10 | module Io_uring_mode = Config.Io_uring_mode 11 | module Max_inter_cycle_timeout = Config.Max_inter_cycle_timeout 12 | module Max_num_open_file_descrs = Config.Max_num_open_file_descrs 13 | module Max_num_threads = Config.Max_num_threads 14 | module Min_inter_cycle_timeout = Config.Min_inter_cycle_timeout 15 | module Debug = Async_kernel_private.Debug 16 | module Job = Async_kernel_private.Job 17 | module Kernel_scheduler = Async_kernel_scheduler.Private 18 | module File_descr = Unix.File_descr 19 | 20 | let print_s sexp = Core.printf "%s\n%!" (sexp |> Sexp.to_string_hum) 21 | let am_test_runner = Base.Exported_for_specific_uses.am_testing 22 | 23 | let () = 24 | if Async_kernel_config.Print_debug_messages_for.thread_pool 25 | then Thread_pool.debug := true 26 | ;; 27 | -------------------------------------------------------------------------------- /src/in_thread.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | open Raw_scheduler 4 | module Priority = Linux_ext.Priority 5 | 6 | module When_finished = struct 7 | type t = 8 | | Notify_the_scheduler 9 | | Take_the_async_lock 10 | | Try_to_take_the_async_lock 11 | [@@deriving enumerate, sexp_of] 12 | 13 | let default = ref Try_to_take_the_async_lock 14 | end 15 | 16 | let try_to_lock_for_cycle_if_scheduler_sleeping t = 17 | if try_lock t 18 | then 19 | if not (Interruptor.already_interrupted t.interruptor) 20 | then true 21 | else ( 22 | unlock t; 23 | false) 24 | else false 25 | ;; 26 | 27 | let stuck_check_interval () = Time_ns.Span.of_sec 1. 28 | 29 | let rec schedule_stuck_check t = 30 | t.thread_pool_stuck 31 | <- Stuck 32 | { stuck_since = Time_ns.now () 33 | ; num_work_completed = Thread_pool.num_work_completed t.thread_pool 34 | }; 35 | Clock_ns.run_after (stuck_check_interval ()) check_still_stuck t 36 | 37 | and check_still_stuck t = 38 | match t.thread_pool_stuck with 39 | | No_unstarted_work -> () 40 | | Stuck _ when not (Thread_pool.has_unstarted_work t.thread_pool) -> 41 | t.thread_pool_stuck <- No_unstarted_work 42 | | Stuck { stuck_since; num_work_completed } -> 43 | if num_work_completed = Thread_pool.num_work_completed t.thread_pool 44 | then ( 45 | t.handle_thread_pool_stuck 46 | t.thread_pool 47 | ~stuck_for:(Time_ns.diff (Time_ns.now ()) stuck_since); 48 | Clock_ns.run_after (stuck_check_interval ()) check_still_stuck t) 49 | else schedule_stuck_check t 50 | ;; 51 | 52 | let maybe_mark_thread_pool_stuck t = 53 | if Thread_pool.has_unstarted_work t.thread_pool 54 | then ( 55 | match t.thread_pool_stuck with 56 | | No_unstarted_work -> schedule_stuck_check t 57 | | _ -> ()) 58 | ;; 59 | 60 | let try_with_backtrace f = 61 | try Ok (f ()) with 62 | | exn -> 63 | let backtrace = 64 | match Backtrace.Exn.most_recent_for_exn exn with 65 | | None -> 66 | (* raised with raise_notrace *) 67 | Stdlib.Printexc.get_callstack 0 68 | | Some backtrace -> backtrace 69 | in 70 | Error (exn, backtrace) 71 | ;; 72 | 73 | let run_after_scheduler_is_started 74 | ~priority 75 | ~thread 76 | ~(when_finished : When_finished.t) 77 | ~name 78 | ~t 79 | f 80 | = 81 | let ivar = Ivar.create () in 82 | let execution_context = current_execution_context t in 83 | let send_result result = 84 | match result with 85 | | Ok v -> Ivar.fill_exn ivar v 86 | | Error (exn, backtrace) -> 87 | Monitor.send_exn 88 | (Execution_context.monitor execution_context) 89 | ~backtrace:(`This backtrace) 90 | exn 91 | in 92 | let doit () = 93 | (* At this point, we are in a thread-pool thread, not the async thread. *) 94 | let result = try_with_backtrace f in 95 | let locked = 96 | match when_finished with 97 | | Take_the_async_lock -> 98 | lock t; 99 | true 100 | | Notify_the_scheduler -> false 101 | | Try_to_take_the_async_lock -> 102 | (match thread_pool_cpu_affinity t with 103 | | Inherit -> try_to_lock_for_cycle_if_scheduler_sleeping t 104 | | Cpuset _ -> 105 | (* If the user specified an affinity for the thread pool, they presumably intend 106 | for Async jobs to be affinitized differently from thread-pool threads, so we 107 | don't even attempt to run jobs on the thread-pool thread. *) 108 | false) 109 | in 110 | if locked 111 | then 112 | protect 113 | ~finally:(fun () -> unlock t) 114 | ~f:(fun () -> 115 | send_result result; 116 | have_lock_do_cycle t) 117 | else 118 | thread_safe_enqueue_external_job t (current_execution_context t) send_result result 119 | in 120 | (match thread with 121 | | None -> 122 | ok_exn (Thread_pool.add_work t.thread_pool doit ?name ?priority); 123 | if Thread_pool.num_threads t.thread_pool = 0 124 | then 125 | raise_s 126 | [%message 127 | "Async's thread pool was unable to create a single thread" 128 | ~_: 129 | (Thread_pool.last_thread_creation_failure t.thread_pool 130 | : (Sexp.t option[@sexp.option]))] 131 | | Some helper_thread -> 132 | ok_exn 133 | (Thread_pool.add_work_for_helper_thread 134 | t.thread_pool 135 | helper_thread 136 | doit 137 | ?name 138 | ?priority)); 139 | maybe_mark_thread_pool_stuck t; 140 | Ivar.read ivar 141 | ;; 142 | 143 | let run ?priority ?thread ?name f = 144 | let when_finished = !When_finished.default in 145 | (* We use [with_t_once_started] to force calls to [run_after_scheduler_is_started] to 146 | wait until after the scheduler is started. We do this because 147 | [run_after_scheduler_is_started] will cause things to run in other threads, and when 148 | a job is finished in another thread, it will try to acquire the async lock and 149 | manipulate async datastructures. This seems hard to think about if async hasn't even 150 | started yet. *) 151 | Raw_scheduler.with_t_once_started ~f:(fun t -> 152 | run_after_scheduler_is_started ~priority ~thread ~when_finished ~name ~t f) 153 | ;; 154 | 155 | module Helper_thread = struct 156 | (* A wrapper around [Thread_pool]'s helper thread, so we can attach a finalizer. *) 157 | type t = { thread_pool_helper_thread : Thread_pool.Helper_thread.t } 158 | [@@deriving fields ~getters, sexp_of] 159 | 160 | let finalize scheduler { thread_pool_helper_thread } = 161 | Thread_pool.finished_with_helper_thread 162 | scheduler.thread_pool 163 | thread_pool_helper_thread 164 | ;; 165 | 166 | let finished_with t = 167 | let scheduler = the_one_and_only () in 168 | finalize scheduler t 169 | ;; 170 | 171 | (* Both [create] and [create_now] add Async finalizers to the returned helper thread so 172 | that the thread can be added back to the set of worker threads when there are no 173 | references to the helper thread and the thread has no pending work. Because 174 | [Thread_pool.finished_with_helper_thread] needs to acquire the thread pool lock, it 175 | cannot be run within an ordinary finalizer, since that could cause it to be run in a 176 | context where the code interrupted by the GC might already be holding the thread pool 177 | lock, which would result in a deadlock. Hence we use an Async finalizer -- this 178 | causes the GC to merely schedule an Async job that calls 179 | [Thread_pool.finished_with_helper_thread]. We don't attach the finalizer inside 180 | [Thread_pool] because the thread pool doesn't know about Async, and in particular 181 | doesn't know about Async finalizers. *) 182 | let create_internal scheduler thread_pool_helper_thread = 183 | let t = { thread_pool_helper_thread } in 184 | add_finalizer_exn scheduler t (finalize scheduler); 185 | t 186 | ;; 187 | 188 | let create_now ?priority ?name () = 189 | let scheduler = the_one_and_only () in 190 | Result.map 191 | (Thread_pool.create_helper_thread scheduler.thread_pool ?name ?priority) 192 | ~f:(fun helper_thread -> create_internal scheduler helper_thread) 193 | ;; 194 | 195 | let create ?priority ?name () = 196 | let scheduler = the_one_and_only () in 197 | let%map helper_thread = 198 | run (fun () -> 199 | Thread_pool.become_helper_thread scheduler.thread_pool ?name ?priority) 200 | in 201 | create_internal scheduler (ok_exn helper_thread) 202 | ;; 203 | end 204 | 205 | let run ?priority ?thread ?name f = 206 | let thread = Option.map thread ~f:Helper_thread.thread_pool_helper_thread in 207 | run ?priority ?thread ?name f 208 | ;; 209 | 210 | let syscall ~name f = run ~name (fun () -> Syscall.syscall f) 211 | let syscall_exn ~name f = run ~name (fun () -> Result.ok_exn (Syscall.syscall f)) 212 | 213 | let pipe_of_squeue sq = 214 | let r, w = Pipe.create () in 215 | (* The functions are defined to avoid unnecessary allocation. *) 216 | let pull () = 217 | let q = Linked_queue.create () in 218 | Squeue.transfer_queue sq q; 219 | q 220 | in 221 | let rec continue q = 222 | Linked_queue.iter q ~f:(Pipe.write_without_pushback w); 223 | Pipe.pushback w >>> loop 224 | (* [run pull] runs [pull] in a thread, because [Squeue.transfer_queue] can block. *) 225 | and loop () = run pull >>> continue in 226 | loop (); 227 | r 228 | ;; 229 | -------------------------------------------------------------------------------- /src/in_thread.mli: -------------------------------------------------------------------------------- 1 | (** The [In_thread] module has functions for interaction between the Async world and other 2 | (kernel) threads. The name is to remind us to think about threads and race conditions. 3 | 4 | All threads come from the one thread pool used for all Async-managed threads. *) 5 | 6 | open! Core 7 | open Async_kernel 8 | module Priority : module type of Linux_ext.Priority with type t = Linux_ext.Priority.t 9 | 10 | module Helper_thread : sig 11 | (** A Helper_thread is a thread that is dedicated to handling computations external to 12 | Async. We need them because some libraries (e.g. Sqlite3) require that certain 13 | collections of computations run in the same thread. *) 14 | type t 15 | 16 | (** [create ?name ()] creates a new helper thread. The [name] will be used as the thread 17 | name for any work that that is done by the thread that doesn't get its own name. 18 | 19 | [create] uses a thread from Async's thread pool, reserving that thread for exclusive 20 | use by the helper thread until the helper thread is no longer used (specifically, 21 | finalized and is finished with all its work), at which point the thread is made 22 | available for general use by the pool. 23 | 24 | [create] returns a deferred that becomes determined when a helper thread is 25 | available. On the other hand, [create_now] checks if a helper thread is available 26 | now, and if so returns it, or else returns [Error]. *) 27 | val create : ?priority:Priority.t -> ?name:string -> unit -> t Deferred.t 28 | 29 | val create_now : ?priority:Priority.t -> ?name:string -> unit -> t Or_error.t 30 | 31 | (** [finished_with t] informs Async's thread pool that no future work will be added for 32 | [t], making it an error to add work to [t] in the future. See 33 | {!Thread_pool.finished_with_helper_thread} for details. 34 | 35 | For almost all usages of [t], you do not need to call this function. As noted in the 36 | [create] documentation, when [t] is garbage collected this function is called for 37 | you already. This function is exposed only so that you can more eagerly release the 38 | helper thread to the Async thread pool *) 39 | val finished_with : t -> unit 40 | end 41 | 42 | (** [pipe_of_squeue squeue] returns a pipe [p] and consumes the contents [squeue], placing 43 | them in [p]. It repeatedly grabs everything from [squeue], places it in [p], and then 44 | waits for pushback on [p]. *) 45 | val pipe_of_squeue : 'a Squeue.t -> 'a Pipe.Reader.t 46 | 47 | (** [When_finished] describes how [In_thread.run f] behaves when the helper thread 48 | finishes [f ()]. *) 49 | module When_finished : sig 50 | type t = 51 | | Notify_the_scheduler 52 | (** The helper thread notifies the Async scheduler that the result is ready, so that 53 | the scheduler will wake up in a timely manner and run a cycle. *) 54 | | Take_the_async_lock 55 | (** The helper thread blocks until it can acquire the Async lock, at which point it 56 | runs a cycle. *) 57 | | Try_to_take_the_async_lock 58 | (** If the [thread_pool_cpu_affinity] is [Inherit], then the helper hread tries to 59 | take the Async lock and run a cycle. If the [thread_pool_cpu_affinity] is [Cpuset] 60 | or the helper thread is unable to acquire the Async lock, then it behaves as in 61 | [Notify_the_scheduler]. *) 62 | [@@deriving enumerate, sexp_of] 63 | 64 | (** [default] defines the default value used for [In_thread.run]'s [?when_finished] 65 | argument. Changes to [default] affect subsequent calls to [In_thread.run]. 66 | Initially, [default = Try_to_take_the_async_lock], which typically leads to better 67 | latency by avoiding an extra context switch to pass the result to the Async 68 | scheduler thread. However, there are applications (e.g. jenga) where 69 | [Notify_the_scheduler] leads to significantly higher throughput by greatly 70 | decreasing the total number of Async cycles. *) 71 | val default : t ref 72 | end 73 | 74 | (** [run ?priority ?thread ?name f] runs [f ()] in a separate thread outside Async and 75 | returns the result as a Deferred in the Async world. If [f ()] raises an exception 76 | (asynchronously, since it is another thread) then that exception will be raised to the 77 | monitor that called [run]. 78 | 79 | WARNING: Async code MUST NOT be used from within [f]. By Async code we mean 80 | pretty-much all functions of libraries making use of Async. Only a few functions of 81 | the Async library can be called inside [In_thread.run]. These are explicitly marked as 82 | such, using the phrase "thread-safe". 83 | 84 | If [thread] is not supplied, then any thread from the thread pool could be used. If 85 | you need to run routines in a specific thread (as is required by some libraries like 86 | Sqlite), you should create a helper thread and supply it to [run]. 87 | 88 | If [priority] is supplied, the priority of the thread in the linux scheduler will be 89 | set to [priority] for the duration of [f ()], provided the thread is allowed to do so 90 | (see [man setpriority]). 91 | 92 | If you call [run] several times with the same helper thread, the [f ()] calls will run 93 | in sequence, in the order in which they are supplied to [run]. Each [f ()] will 94 | complete (return or raise) before another [f ()] starts. 95 | 96 | For example, if you do: 97 | 98 | {[ 99 | let () = 100 | run ~thread f1; 101 | run ~thread f2; 102 | run ~thread f3 103 | ;; 104 | ]} 105 | 106 | Then the thread will run [f1 ()] to completion, then [f2 ()] to completion, then 107 | [f3 ()] to completion. 108 | 109 | If [name] is supplied, the name of the thread will be set to it for the duration of 110 | the execution of [f ()]. 111 | 112 | Once [f ()] has completed, the helper thread behaves as {!When_finished.default} 113 | specifies. *) 114 | val run 115 | : ?priority:Priority.t 116 | -> ?thread:Helper_thread.t 117 | -> ?name:string 118 | -> (unit -> 'a) 119 | -> 'a Deferred.t 120 | 121 | (** [syscall f] runs f, which should be a single system call, and returns the result, 122 | handling the restarting of interrupted system calls. To avoid race conditions, the [f] 123 | supplied to [syscall] should just make a system call. That way, everything else is 124 | done holding the Async lock. *) 125 | val syscall : name:string -> (unit -> 'a) -> ('a, exn) Result.t Deferred.t 126 | 127 | val syscall_exn : name:string -> (unit -> 'a) -> 'a Deferred.t 128 | -------------------------------------------------------------------------------- /src/interruptor.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | module Fd = Raw_fd 4 | 5 | let debug = Debug.interruptor 6 | 7 | (* The [phase] state machine of an interruptor looks like this: 8 | 9 | [create] 10 | | 11 | v 12 | +---> Awake <---------- [clear] ----------+ 13 | | | | 14 | | +-- [interrupt] ----------> Interrupted 15 | [clear] | ^ 16 | | [sleep] | 17 | | | | 18 | | v | 19 | +- Sleeping --[interrupt+write]-----------+ 20 | 21 | The key is that [interrupt] writes to the pipe only when transitioning from [Sleeping] 22 | to [Interrupted]. 23 | 24 | When an [interrupt] happens while the sleeper is [Awake], no write to/read from the 25 | pipe is needed. 26 | *) 27 | 28 | type phase = 29 | | Sleeping 30 | | Awake 31 | | Interrupted 32 | [@@deriving sexp_of] 33 | 34 | type t = 35 | { read_fd : (Fd.t Capsule.Initial.Data.t[@sexp.opaque]) 36 | ; write_fd : File_descr.t 37 | ; (* See the [phase] state machine description above. *) 38 | phase : phase Atomic.t 39 | ; clearbuffer : (Bytes.t[@sexp.opaque]) 40 | } 41 | [@@deriving sexp_of] 42 | 43 | let invariant _ = () 44 | let read_fd t = Capsule.Initial.Data.unwrap t.read_fd 45 | 46 | let create ~create_fd = 47 | let pipe_read, pipe_write = Unix.pipe () in 48 | Unix.set_close_on_exec pipe_read; 49 | Unix.set_close_on_exec pipe_write; 50 | let pipe_read = 51 | create_fd Fd.Kind.Fifo pipe_read (Info.of_string "interruptor_pipe_read") 52 | in 53 | let pipe_write = create_fd Fifo pipe_write (Info.of_string "interruptor_pipe_write") in 54 | { read_fd = Capsule.Initial.Data.wrap pipe_read 55 | ; write_fd = pipe_write.file_descr 56 | ; phase = Atomic.make Awake 57 | ; clearbuffer = Bytes.make 1 ' ' 58 | } 59 | ;; 60 | 61 | (* [thread_safe_interrupt] 62 | As the name implies, it is safe to call from any thread; [thread_safe_interrupt] does 63 | not assume the scheduler lock is held, although it is fine if it is. *) 64 | let thread_safe_interrupt t = 65 | if debug then Debug.log_string "Interruptor.thread_safe_interrupt"; 66 | let rec loop () = 67 | match Atomic.get t.phase with 68 | | Interrupted -> 69 | ( (* Nothing to do as both of these indicate that an interrupt was already made. *) ) 70 | | Awake -> 71 | (match 72 | Atomic.compare_and_set t.phase ~if_phys_equal_to:Awake ~replace_with:Interrupted 73 | with 74 | | Set_here -> () 75 | | Compare_failed -> 76 | (* There are two (main) possibilities: 77 | 78 | - either the watcher just went to sleep, or 79 | 80 | - someone else finished an interrupt. 81 | 82 | Neither of these cases is likely to be contended. If the watcher went to 83 | sleep, we should just wake it up. If someone else finished an interrupt, then 84 | we are done. It is highly unlikely that we would need multiple retries and 85 | adding a backoff here is unlikely to improve performance. *) 86 | loop ()) 87 | | Sleeping -> 88 | (match 89 | Atomic.compare_and_set 90 | t.phase 91 | ~if_phys_equal_to:Sleeping 92 | ~replace_with:Interrupted 93 | with 94 | | Compare_failed -> 95 | ( (* Nothing to do as failure here means that the watcher either woke up or was 96 | woken up. *) ) 97 | | Set_here -> 98 | if debug then Debug.log_string "writing to interrupt_pipe_write"; 99 | Syscall.syscall_exn (fun () -> 100 | let bytes_written = Caml_unix.write_substring t.write_fd " " 0 1 in 101 | (* The above blocking write should always succeed immediately as we do not 102 | accumulate bytes in the pipe. *) 103 | assert (bytes_written = 1))) 104 | in 105 | loop () 106 | ;; 107 | 108 | module Sleep = struct 109 | type t = 110 | | Clear_pending_interrupts 111 | | Sleep 112 | end 113 | 114 | let sleep t : Sleep.t = 115 | match Atomic.compare_and_set t.phase ~if_phys_equal_to:Awake ~replace_with:Sleeping with 116 | | Set_here -> Sleep 117 | | Compare_failed -> Clear_pending_interrupts 118 | ;; 119 | 120 | let clear_fd t = 121 | Fd.syscall_exn (read_fd t) ~nonblocking:true (fun file_descr -> 122 | match 123 | let bytes_read = Caml_unix.read file_descr t.clearbuffer 0 1 in 124 | assert (bytes_read = 1) 125 | with 126 | | () -> () 127 | | exception Unix.Unix_error (EAGAIN, _, _) -> 128 | (* This happens because Async schedules fd readiness callback jobs every cycle, 129 | with no guarantee that these jobs run the same cycle. 130 | 131 | So if the limit of 500 jobs per cycle is reached, these callbacks are left in 132 | the queue and duplicated next cycle. *) 133 | ()) 134 | ;; 135 | 136 | let clear t = 137 | if debug then Debug.log_string "Interruptor.clear"; 138 | Atomic.set t.phase Awake 139 | ;; 140 | 141 | let already_interrupted t = 142 | match Atomic.get t.phase with 143 | | Interrupted -> true 144 | | Sleeping | Awake -> false 145 | ;; 146 | -------------------------------------------------------------------------------- /src/interruptor.mli: -------------------------------------------------------------------------------- 1 | (** An interruptor provides a file descriptor that can be used to cause a 2 | file-descr-watcher to detect the file descriptor is ready for reading. We use an 3 | interruptor when a thread needs the Async scheduler to service a request. 4 | 5 | {v 6 | Knock, knock. 7 | Who's there? 8 | Interruptor cow. 9 | Interrup- 10 | _________________________ 11 | / \ 12 | | __ __ ____ ____ | 13 | | | \/ |/ __ \ / __ \ | 14 | | | \ / | | | | | | | | 15 | | | |\/| | | | | | | | | 16 | | | | | | |__| | |__| | | 17 | | |_| |_|\____/ \____/ | 18 | \ / 19 | ------------------------- 20 | \ ^__^ 21 | \ (oo)\_______ 22 | (__)\ )\/\ 23 | ||----w | 24 | || || 25 | v} *) 26 | 27 | open! Core 28 | open! Import 29 | 30 | type t [@@deriving sexp_of] 31 | 32 | include Invariant.S with type t := t 33 | 34 | val create : create_fd:(Raw_fd.Kind.t -> Unix.File_descr.t -> Info.t -> Raw_fd.t) -> t 35 | val read_fd : t -> Raw_fd.t 36 | 37 | (** [thread_safe_interrupt t] causes an interrupt, which either makes the next [sleep] 38 | return [Clear_pending_interrupts], or makes [read_fd] ready to read, as appropriate, 39 | depending on what state the watcher is in. *) 40 | val thread_safe_interrupt : t -> unit 41 | 42 | module Sleep : sig 43 | type t = 44 | | Clear_pending_interrupts 45 | | Sleep 46 | end 47 | 48 | (** [sleep t] tells the interruptor that the watcher is about to go to sleep. Returns 49 | [Sleep] when the watcher should go to sleep and [Clear_pending_interrupts] in case an 50 | interrupt has happened while the watcher was awake and the watcher should now [clear] 51 | the interruptor and make sure to service queued requests. 52 | 53 | If [Sleep] is returned, then the watcher is allowed to go to sleep while being 54 | sensitive to [read_fd]. *) 55 | val sleep : t -> Sleep.t 56 | 57 | (** [clear t] should be called on wakeup after [sleep]. It clears the interruptor's 58 | knowledge of past interrupts, if any, and makes it responsive to future interrupts. 59 | Any calls to [thread_safe_interrupt] after [clear t] returns will be reflected in the 60 | next call to [sleep] (or the readiness of the [read_fd] if we do end up going to 61 | [Sleep]). *) 62 | val clear : t -> unit 63 | 64 | (** [clear_fd] must be called by the scheduler any time it wakes up due to the [read_fd] 65 | being ready to read. *) 66 | val clear_fd : t -> unit 67 | 68 | (** [already_interrupted t] is true if [thread_safe_interrupt t] has completed since the 69 | last call to [clear t]. *) 70 | val already_interrupted : t -> bool 71 | -------------------------------------------------------------------------------- /src/io_stats.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = 4 | { mutable total : Int63.t 5 | ; mutable char : Int63.t 6 | ; mutable fifo : Int63.t 7 | ; mutable file : Int63.t 8 | ; mutable socket : Int63.t 9 | } 10 | [@@deriving sexp] 11 | 12 | let create () = 13 | { total = Int63.zero 14 | ; char = Int63.zero 15 | ; fifo = Int63.zero 16 | ; file = Int63.zero 17 | ; socket = Int63.zero 18 | } 19 | ;; 20 | 21 | let update t ~(kind : Fd.Kind.t) ~bytes = 22 | t.total <- Int63.(t.total + bytes); 23 | match kind with 24 | | Char -> t.char <- Int63.( + ) t.char bytes 25 | | Fifo -> t.fifo <- Int63.( + ) t.fifo bytes 26 | | File -> t.file <- Int63.( + ) t.file bytes 27 | | Socket _ -> t.socket <- Int63.( + ) t.socket bytes 28 | ;; 29 | 30 | let total t = t.total 31 | 32 | let get t ~(kind : Fd.Kind.t) = 33 | match kind with 34 | | Char -> t.char 35 | | Fifo -> t.fifo 36 | | File -> t.file 37 | | Socket _ -> t.socket 38 | ;; 39 | -------------------------------------------------------------------------------- /src/io_stats.mli: -------------------------------------------------------------------------------- 1 | (** Gives stats about system IO usage. *) 2 | 3 | open! Core 4 | 5 | type t [@@deriving sexp] 6 | 7 | val create : unit -> t 8 | val update : t -> kind:Fd.Kind.t -> bytes:Int63.t -> unit 9 | val total : t -> Int63.t 10 | val get : t -> kind:Fd.Kind.t -> Int63.t 11 | -------------------------------------------------------------------------------- /src/io_uring.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | type t = Io_uring_raw.t 5 | 6 | let create = Io_uring_raw.create 7 | let exit = Io_uring_raw.exit 8 | let submit = Io_uring_raw.submit 9 | let fill_completions = Io_uring_raw.fill_completions 10 | let the_one_and_only = Io_uring_raw_singleton.the_one_and_only 11 | let max_tries = 1000 12 | 13 | let rec attempt_syscall_internal f count = 14 | if count = max_tries then failwith "syscall interrupted too many times"; 15 | match%bind Io_uring_raw.syscall_result_noretry (f ()) with 16 | | Error Unix.Error.EINTR -> 17 | (* We don't know if io_uring completions can actually return [EINTR] (probably not?), 18 | so this is possibly dead code. To be on the safe side, we're just replicating the 19 | traditional retry loop from [Syscall.syscall]. *) 20 | let%bind () = Raw_scheduler.yield () in 21 | attempt_syscall_internal f (count + 1) 22 | | Error (Unix.EUNKNOWNERR 125) -> 23 | (* We've seen some weird behavior where our calls return with ECANCELED 24 | even though we're not asking to cancel. Work around this issue, 25 | which seems like it may be a kernel bug. 26 | 27 | This can't be a real cancellation because the job handle is made by 28 | [f ()] above and we don't ever call cancel on that. *) 29 | attempt_syscall_internal f (count + 1) 30 | | Error err -> return (Error err) 31 | | Ok result -> return (Ok result) 32 | ;; 33 | 34 | let attempt_syscall f = attempt_syscall_internal f 0 35 | 36 | let with_file_descr_deferred ~name fd f = 37 | match%map Fd.with_file_descr_deferred ~extract_exn:true fd (fun fd -> f fd) with 38 | | `Already_closed -> 39 | (* We have to match the error messages of [Fd.syscall_in_thread_exn] because if we 40 | default [Async] to using [Io_uring], inline tests that catch error messages 41 | will start failing. *) 42 | Error 43 | (try 44 | raise_s 45 | [%message "Fd.syscall_in_thread_exn of a closed fd" name ~_:(fd : Fd.t_hum)] 46 | with 47 | | exn -> exn) 48 | | `Error exn -> raise exn 49 | | `Ok ok -> ok 50 | ;; 51 | 52 | let with_file_descr_deferred_opt ~name fd_opt ~f = 53 | match fd_opt with 54 | | None -> f None 55 | | Some fd -> with_file_descr_deferred ~name fd (fun fd -> f (Some fd)) 56 | ;; 57 | 58 | let read_file_descr_or_unix_error t ?(file_offset = -1) file_descr ?off ?len buf = 59 | attempt_syscall (fun () -> 60 | Io_uring_raw.read 61 | t 62 | ~file_offset:(Io_uring_raw.Int63.of_int file_offset) 63 | file_descr 64 | (Cstruct.of_bigarray ?off ?len buf)) 65 | ;; 66 | 67 | let read_file_descr t ?file_offset file_descr ?off ?len buf = 68 | match%map read_file_descr_or_unix_error t ?file_offset file_descr ?off ?len buf with 69 | | Error err -> Error (Unix.Unix_error (err, "read", "")) 70 | | Ok res -> Ok res 71 | ;; 72 | 73 | let read t ?(file_offset = -1) fd ?off ?len buf = 74 | with_file_descr_deferred ~name:"read" fd (fun fd -> 75 | read_file_descr t ~file_offset fd ?off ?len buf) 76 | ;; 77 | 78 | let write t ?(file_offset = -1) fd ?off ?len buf = 79 | with_file_descr_deferred ~name:"write" fd (fun fd -> 80 | match%map 81 | attempt_syscall (fun () -> 82 | Io_uring_raw.write 83 | t 84 | ~file_offset:(Io_uring_raw.Int63.of_int file_offset) 85 | fd 86 | (Cstruct.of_bigarray ?off ?len buf)) 87 | with 88 | | Error err -> Error (Unix.Unix_error (err, "write", "")) 89 | | Ok res -> Ok res) 90 | ;; 91 | 92 | let to_cstruct (iovecs : Bigstring.t Core_unix.IOVec.t array) = 93 | Array.to_list iovecs 94 | |> List.map ~f:(fun { buf; pos; len } -> Cstruct.of_bigarray ~off:pos ~len buf) 95 | ;; 96 | 97 | let readv t ?(file_offset = -1) fd bufs = 98 | with_file_descr_deferred ~name:"readv" fd (fun fd -> 99 | match%map 100 | attempt_syscall (fun () -> 101 | Io_uring_raw.readv 102 | t 103 | ~file_offset:(Io_uring_raw.Int63.of_int file_offset) 104 | fd 105 | (to_cstruct bufs)) 106 | with 107 | | Error err -> Error (Unix.Unix_error (err, "readv", "")) 108 | | Ok res -> Ok res) 109 | ;; 110 | 111 | let writev t ?(file_offset = -1) fd (bufs : Bigstring.t Core_unix.IOVec.t array) = 112 | with_file_descr_deferred ~name:"writev" fd (fun fd -> 113 | match%map 114 | attempt_syscall (fun () -> 115 | Io_uring_raw.writev 116 | t 117 | ~file_offset:(Io_uring_raw.Int63.of_int file_offset) 118 | fd 119 | (to_cstruct bufs)) 120 | with 121 | | Error err -> Error (Unix.Unix_error (err, "writev", "")) 122 | | Ok res -> Ok res) 123 | ;; 124 | 125 | let openat2 t ~access ~flags ?(perm = 0o644) ~resolve ?info ?fd filename = 126 | let perm = 127 | let open Io_uring_raw.Open_flags in 128 | if mem creat flags || mem tmpfile flags then perm else 0 129 | in 130 | let info = Option.value info ~default:(Info.create_s [%sexp (filename : string)]) in 131 | let openat2_syscall fd_opt = 132 | attempt_syscall (fun () -> 133 | Io_uring_raw.openat2 t ~access ~flags ~perm ~resolve ?fd:fd_opt filename) 134 | in 135 | let failure_error err = Unix.Unix_error (err, "open", Info.to_string_mach info) in 136 | let success_fd res = Fd.create Fd.Kind.File (File_descr.of_int res) info in 137 | with_file_descr_deferred_opt ~name:"open" fd ~f:(fun fd -> 138 | match%map openat2_syscall fd with 139 | | Error err -> Error (failure_error err) 140 | | Ok res -> Ok (success_fd res)) 141 | ;; 142 | 143 | let unlink t ~dir ?fd filename = 144 | let unlink_syscall fd_opt = 145 | attempt_syscall (fun () -> Io_uring_raw.unlink t ~dir ?fd:fd_opt filename) 146 | in 147 | let to_exn err = 148 | Unix.Unix_error 149 | (err, "unlink", Core_unix.Private.sexp_to_string_hum [%sexp { filename : string }]) 150 | in 151 | with_file_descr_deferred_opt fd ~name:"unlink" ~f:(fun fd -> 152 | match%map unlink_syscall fd with 153 | | Error err -> Error (to_exn err) 154 | | Ok _ -> Ok ()) 155 | ;; 156 | 157 | (* The [force] case for this function is implemented this way in order to align with the 158 | [Unix_syscalls] error message which outputs the arguments of the [link] in the case 159 | [unlink] fails. 160 | *) 161 | let link t ?(follow = false) ?(force = false) ~target ~link_name () = 162 | let args_for_error () = 163 | Core_unix.Private.sexp_to_string_hum [%sexp { target : string; link_name : string }] 164 | in 165 | let%bind unlink_res = 166 | match force with 167 | | true -> 168 | (match%map unlink t ~dir:false link_name with 169 | | Error (Unix.Unix_error (Unix.ENOENT, _, _)) -> Ok () 170 | | Error (Unix.Unix_error (e, s, _)) -> 171 | Error (Unix.Unix_error (e, s, args_for_error ())) 172 | | Error exn -> Error exn 173 | | Ok () -> Ok ()) 174 | | false -> return (Ok ()) 175 | in 176 | match unlink_res with 177 | | Error exn -> return (Error exn) 178 | | Ok () -> 179 | (match%map 180 | attempt_syscall (fun () -> Io_uring_raw.link t ~follow ~target ~link_name) 181 | with 182 | | Error err -> Error (Unix.Unix_error (err, "link", args_for_error ())) 183 | | Ok _ -> Ok ()) 184 | ;; 185 | 186 | let do_statx t ?fd ?(mask = Io_uring_raw.Statx.Mask.basic_stats) path flags = 187 | let statx_buffer = Io_uring_raw.Statx.create () in 188 | match%map 189 | attempt_syscall (fun () -> Io_uring_raw.statx t ?fd ~mask path statx_buffer flags) 190 | with 191 | | Error err -> Error err 192 | | Ok res -> 193 | assert (res = 0); 194 | Ok statx_buffer 195 | ;; 196 | 197 | let statx t ?fd ?(mask = Io_uring_raw.Statx.Mask.basic_stats) path flags = 198 | let statx_syscall fd_opt = do_statx t ?fd:fd_opt ~mask path flags in 199 | let failure_error err = 200 | Unix.Unix_error 201 | ( err 202 | , "statx" 203 | , Core_unix.Private.sexp_to_string_hum [%sexp { fd : Fd.t option; path : string }] 204 | ) 205 | in 206 | with_file_descr_deferred_opt ~name:"statx" fd ~f:(fun fd -> 207 | match%map statx_syscall fd with 208 | | Error err -> Error (failure_error err) 209 | | Ok res -> Ok res) 210 | ;; 211 | 212 | let stat_or_unix_error t ?mask filename = 213 | do_statx t ?mask filename Io_uring_raw.Statx.Flags.empty 214 | ;; 215 | 216 | let stat t ?mask filename = 217 | match%map stat_or_unix_error t ?mask filename with 218 | | Error err -> 219 | Error 220 | (Unix.Unix_error 221 | (err, "stat", Core_unix.Private.sexp_to_string_hum [%sexp { filename : string }])) 222 | | Ok res -> Ok res 223 | ;; 224 | 225 | let fstat t ?mask fd = 226 | with_file_descr_deferred ~name:"fstat" fd (fun fd -> 227 | match%map do_statx t ?mask ~fd "" Io_uring_raw.Statx.Flags.empty_path with 228 | | Ok res -> Ok res 229 | | Error err -> 230 | Error 231 | (Unix.Unix_error 232 | ( err 233 | , "fstat" 234 | , Core_unix.Private.sexp_to_string_hum [%sexp { fd : File_descr.t }] ))) 235 | ;; 236 | 237 | let lstat_or_unix_error t ?mask filename = 238 | do_statx t ?mask filename Io_uring_raw.Statx.Flags.symlink_nofollow 239 | ;; 240 | 241 | let lstat t ?mask filename = 242 | match%map lstat_or_unix_error t ?mask filename with 243 | | Ok res -> Ok res 244 | | Error err -> 245 | Error 246 | (Unix.Unix_error 247 | (err, "lstat", Core_unix.Private.sexp_to_string_hum [%sexp { filename : string }])) 248 | ;; 249 | -------------------------------------------------------------------------------- /src/io_uring.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | type t = Io_uring_raw.t 5 | 6 | val create : ?polling_timeout:int -> queue_depth:int -> unit -> t Or_error.t 7 | val exit : t -> unit 8 | val submit : t -> int 9 | val fill_completions : t -> int 10 | 11 | val read 12 | : t 13 | -> ?file_offset:int 14 | -> Fd.t 15 | -> ?off:int 16 | -> ?len:int 17 | -> Bigstring.t 18 | -> (int, Exn.t) Result.t Deferred.t 19 | 20 | val read_file_descr_or_unix_error 21 | : t 22 | -> ?file_offset:int 23 | -> File_descr.t 24 | -> ?off:int 25 | -> ?len:int 26 | -> Bigstring.t 27 | -> (int, Unix.Error.t) Result.t Deferred.t 28 | 29 | val write 30 | : t 31 | -> ?file_offset:int 32 | -> Fd.t 33 | -> ?off:int 34 | -> ?len:int 35 | -> Bigstring.t 36 | -> (int, Exn.t) Result.t Deferred.t 37 | 38 | val readv 39 | : t 40 | -> ?file_offset:int 41 | -> Fd.t 42 | -> Bigstring.t Unix.IOVec.t Array.t 43 | -> (int, Exn.t) Result.t Deferred.t 44 | 45 | val writev 46 | : t 47 | -> ?file_offset:int 48 | -> Fd.t 49 | -> Bigstring.t Unix.IOVec.t array 50 | -> (int, Exn.t) Result.t Deferred.t 51 | 52 | val openat2 53 | : t 54 | -> access:[ `R | `W | `RW ] 55 | -> flags:Io_uring_raw.Open_flags.t 56 | -> ?perm:Unix.file_perm 57 | -> resolve:Io_uring_raw.Resolve.t 58 | -> ?info:Info.t 59 | -> ?fd:Fd.t 60 | -> string 61 | -> (Fd.t, Exn.t) Result.t Deferred.t 62 | 63 | val unlink : t -> dir:bool -> ?fd:Fd.t -> string -> (unit, Exn.t) Result.t Deferred.t 64 | 65 | val link 66 | : t 67 | -> ?follow:bool 68 | -> ?force:bool 69 | -> target:string 70 | -> link_name:string 71 | -> unit 72 | -> (unit, Exn.t) Result.t Deferred.t 73 | 74 | val statx 75 | : t 76 | -> ?fd:Fd.t 77 | -> ?mask:Io_uring_raw.Statx.Mask.t 78 | -> string 79 | -> Io_uring_raw.Statx.Flags.t 80 | -> (Io_uring_raw.Statx.t, Exn.t) Result.t Deferred.t 81 | 82 | val stat 83 | : t 84 | -> ?mask:Io_uring_raw.Statx.Mask.t 85 | -> string 86 | -> (Io_uring_raw.Statx.t, Exn.t) Result.t Deferred.t 87 | 88 | val stat_or_unix_error 89 | : t 90 | -> ?mask:Io_uring_raw.Statx.Mask.t 91 | -> string 92 | -> (Io_uring_raw.Statx.t, Unix.Error.t) Result.t Deferred.t 93 | 94 | val fstat 95 | : t 96 | -> ?mask:Io_uring_raw.Statx.Mask.t 97 | -> Fd.t 98 | -> (Io_uring_raw.Statx.t, Exn.t) Result.t Deferred.t 99 | 100 | val lstat 101 | : t 102 | -> ?mask:Io_uring_raw.Statx.Mask.t 103 | -> string 104 | -> (Io_uring_raw.Statx.t, Exn.t) Result.t Deferred.t 105 | 106 | val lstat_or_unix_error 107 | : t 108 | -> ?mask:Io_uring_raw.Statx.Mask.t 109 | -> string 110 | -> (Io_uring_raw.Statx.t, Unix.Error.t) Result.t Deferred.t 111 | 112 | val the_one_and_only : unit -> t option 113 | -------------------------------------------------------------------------------- /src/io_uring_config.h: -------------------------------------------------------------------------------- 1 | #ifndef IO_URING_CONFIG_H 2 | #define IO_URING_CONFIG_H 3 | #undef JSC_IO_URING 4 | #endif 5 | -------------------------------------------------------------------------------- /src/io_uring_file_descr_watcher.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | open File_descr_watcher_intf 4 | open Read_write_pair.Export 5 | module Table = Bounded_int_table 6 | 7 | module Flags = struct 8 | include Io_uring_raw.Poll_mask 9 | 10 | let of_rw = function 11 | | `Read -> pollin 12 | | `Write -> pollout 13 | ;; 14 | end 15 | 16 | module Fd_state = struct 17 | type t = 18 | { running_job : Io_uring_raw.Handle.t 19 | ; flags : Io_uring_raw.Poll_mask.t 20 | } 21 | end 22 | 23 | type t = 24 | { uring : (Io_uring_raw.t[@sexp.opaque]) 25 | ; states : ((File_descr.t, Fd_state.t) Table.t[@sexp.opaque]) 26 | ; handle_fd_read_ready : File_descr.t -> Flags.t -> unit 27 | ; handle_fd_write_ready : File_descr.t -> Flags.t -> unit 28 | } 29 | [@@deriving sexp_of, fields ~iterators:iter] 30 | 31 | let backend = Config.File_descr_watcher.Io_uring 32 | 33 | let invariant t : unit = 34 | try 35 | let check f field = f (Field.get field t) in 36 | Fields.iter 37 | ~uring:ignore 38 | ~states: 39 | (check (fun states -> 40 | Table.iter states ~f:(fun { Fd_state.running_job = _; flags } -> 41 | assert ( 42 | List.exists 43 | Flags.[ pollin; pollout; pollin + pollout ] 44 | ~f:(fun flags' -> Flags.(mem flags' flags && mem flags flags')))))) 45 | ~handle_fd_read_ready:ignore 46 | ~handle_fd_write_ready:ignore 47 | with 48 | | exn -> 49 | raise_s 50 | [%message 51 | "Io_uring_file_descr_watcher.invariant failed" 52 | (exn : exn) 53 | ~io_uring_file_descr_watcher:(t : t)] 54 | ;; 55 | 56 | type 'a additional_create_args = uring:Io_uring_raw.t -> 'a 57 | 58 | let create ~uring ~num_file_descrs ~handle_fd_read_ready ~handle_fd_write_ready = 59 | if not (Io_uring_raw.supports_ext_arg uring) 60 | then 61 | raise_s 62 | [%sexp 63 | "Cannot create an Ocaml_uring file descriptor watcher if IORING_FEAT_EXT_ARG is \ 64 | not supported because then it is not thread safe."]; 65 | let states = 66 | Table.create 67 | ~num_keys:num_file_descrs 68 | ~key_to_int:File_descr.to_int 69 | ~sexp_of_key:File_descr.sexp_of_t 70 | () 71 | in 72 | let handle_fd read_or_write handle_fd = 73 | let bit = Flags.of_rw read_or_write in 74 | fun file_descr flags -> 75 | (* [io_uring], similar to [epoll], has an implicit event 76 | flags for hangup (HUP) and error (ERR), whereas select will just return that fd 77 | as "ready" in its appropriate fd_set. Since we don't know if it's ready for IN 78 | or OUT, we have to go lookup the entry if the HUP or ERR flag is set. *) 79 | if Flags.mem bit flags 80 | || ((Flags.mem Flags.pollerr flags || Flags.mem Flags.pollhup flags) 81 | && 82 | match Table.find states file_descr with 83 | | None -> false 84 | | Some { Fd_state.running_job = _; flags } -> Flags.mem bit flags) 85 | then handle_fd file_descr 86 | in 87 | { uring 88 | ; states 89 | ; handle_fd_read_ready = handle_fd `Read handle_fd_read_ready 90 | ; handle_fd_write_ready = handle_fd `Write handle_fd_write_ready 91 | } 92 | ;; 93 | 94 | let reset_in_forked_process _ = () 95 | 96 | let iter t ~f = 97 | Table.iteri t.states ~f:(fun ~key:file_descr ~data:{ running_job = _; flags } -> 98 | if Flags.mem Flags.pollin flags then f file_descr `Read; 99 | if Flags.mem Flags.pollout flags then f file_descr `Write) 100 | ;; 101 | 102 | let rec add_poll t file_descr flags = 103 | let job_handle = Io_uring_raw.poll_add t.uring file_descr flags in 104 | Table.set t.states ~key:file_descr ~data:{ running_job = job_handle; flags }; 105 | upon (Io_uring_raw.syscall_result_noretry job_handle) (fun res -> 106 | on_poll_result t ~job_handle ~file_descr res) 107 | 108 | and on_poll_result t ~job_handle ~file_descr res = 109 | match Table.find t.states file_descr with 110 | | None -> () 111 | | Some { running_job; flags } -> 112 | if phys_equal running_job job_handle 113 | then ( 114 | match res with 115 | (* This is ECANCELED *) 116 | | Error (Unix.EUNKNOWNERR 125) -> () 117 | | Error err -> failwith (Unix.Error.message err) 118 | | Ok res -> 119 | handle_fd_read_ready t file_descr (Flags.of_int res); 120 | handle_fd_write_ready t file_descr (Flags.of_int res); 121 | add_poll t file_descr flags); 122 | () 123 | ;; 124 | 125 | let remove_poll_exn t file_descr = 126 | match Table.find t.states file_descr with 127 | | Some { running_job; _ } -> 128 | Table.remove t.states file_descr; 129 | Deferred.don't_wait_for (Io_uring_raw.cancel t.uring running_job) 130 | | None -> 131 | raise_s 132 | [%sexp 133 | "Attempted to remove polling for a file descriptor that was not being polled"] 134 | ;; 135 | 136 | let set t file_descr desired = 137 | let actual_flags = 138 | match Table.find t.states file_descr with 139 | | None -> None 140 | | Some { running_job = _; flags } -> Some flags 141 | in 142 | let desired_flags = 143 | match desired.read, desired.write with 144 | | false, false -> None 145 | | true, false -> Some Flags.pollin 146 | | false, true -> Some Flags.pollout 147 | | true, true -> Some Flags.(pollin + pollout) 148 | in 149 | match actual_flags, desired_flags with 150 | | None, None -> `Ok 151 | | None, Some d -> 152 | add_poll t file_descr d; 153 | `Ok 154 | | Some _, None -> 155 | remove_poll_exn t file_descr; 156 | `Ok 157 | | Some a, Some d -> 158 | if not (Flags.mem a d && Flags.mem d a) 159 | then ( 160 | remove_poll_exn t file_descr; 161 | add_poll t file_descr d); 162 | `Ok 163 | ;; 164 | 165 | module Pre = struct 166 | type t = unit [@@deriving sexp_of] 167 | end 168 | 169 | let pre_check t = 170 | (* This has the efect of submitting at the end of every cycle. *) 171 | let (_ : int) = Io_uring_raw.submit t.uring in 172 | () 173 | ;; 174 | 175 | module Check_result = struct 176 | type t = bool [@@deriving sexp_of] 177 | end 178 | 179 | (* Filling completions is cheap when nothing is ready, so in case we want to timeout 180 | immediately, it's ok to just try and fill completions without checking the completion 181 | queue as well. *) 182 | let thread_safe_check (type a) t () (timeout : a Timeout.t) (span_or_unit : a) = 183 | match timeout with 184 | | Immediately -> true 185 | | After -> Io_uring_raw.cqe_ready t.uring ~timeout:(Time_ns.Span.to_sec span_or_unit) 186 | ;; 187 | 188 | let post_check t ready = 189 | if ready 190 | then ( 191 | let (_ : int) = Io_uring_raw.fill_completions t.uring in 192 | ()) 193 | ;; 194 | -------------------------------------------------------------------------------- /src/io_uring_file_descr_watcher.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | type 'a additional_create_args = uring:Io_uring_raw.t -> 'a 5 | 6 | include 7 | File_descr_watcher_intf.S 8 | with type 'a additional_create_args := 'a additional_create_args 9 | -------------------------------------------------------------------------------- /src/io_uring_raw.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | module _ = Io_uring_raw_null 4 | 5 | [%%import "io_uring_config.h"] 6 | [%%ifdef JSC_IO_URING] 7 | 8 | module Uring = Ocaml_uring.Uring 9 | module Int63 = Optint.Int63 10 | module Poll_mask = Uring.Poll_mask 11 | 12 | module Clock = struct 13 | type t = 14 | | Boottime 15 | | Realtime 16 | 17 | let to_uring_clock t = 18 | match t with 19 | | Boottime -> Uring.Boottime 20 | | Realtime -> Uring.Realtime 21 | ;; 22 | end 23 | 24 | module Statx = Uring.Statx 25 | module Open_flags = Uring.Open_flags 26 | module Resolve = Uring.Resolve 27 | 28 | module Syscall_result = struct 29 | type t = (int, Unix.Error.t) Result.t [@@deriving sexp_of] 30 | end 31 | 32 | type t = Syscall_result.t Ivar.t Uring.t 33 | 34 | module Status = struct 35 | type t = 36 | | To_prepare 37 | | Prepared_or_finished 38 | | Cancel_prepared of (Syscall_result.t Ivar.t[@sexp.opaque]) 39 | | Cancelled_early 40 | [@@deriving sexp_of] 41 | end 42 | 43 | module Handle = struct 44 | type t = 45 | { result : Syscall_result.t Ivar.t 46 | ; mutable job : Syscall_result.t Ivar.t Ocaml_uring.Uring.job option 47 | ; mutable status : Status.t 48 | } 49 | [@@deriving fields ~getters] 50 | 51 | let invariant (t : t) = 52 | try 53 | match t.status with 54 | | To_prepare -> 55 | assert (Ivar.is_empty t.result); 56 | assert (Option.is_none t.job) 57 | | Prepared_or_finished | Cancel_prepared _ -> assert (Option.is_some t.job) 58 | | Cancelled_early -> assert (Ivar.is_full t.result) 59 | with 60 | | exn -> raise_s [%message "Io_uring_raw.Status.invariant failed" (exn : exn)] 61 | ;; 62 | 63 | let set_job t new_job = t.job <- new_job 64 | let set_status t new_status = t.status <- new_status 65 | end 66 | 67 | let supports_ops probe = 68 | List.for_all 69 | ~f:(fun op -> Uring.op_supported probe op) 70 | Uring.Op. 71 | [ nop 72 | ; read 73 | ; write 74 | ; readv 75 | ; writev 76 | ; poll_add 77 | ; openat2 78 | ; close 79 | ; linkat 80 | ; unlinkat 81 | ; timeout 82 | ; statx 83 | ; async_cancel 84 | ] 85 | ;; 86 | 87 | let create ?polling_timeout ~queue_depth () = 88 | let uring = Uring.create ?polling_timeout ~queue_depth () in 89 | let probe = Uring.get_probe uring in 90 | if supports_ops probe 91 | then Ok uring 92 | else ( 93 | Uring.exit uring; 94 | error_s 95 | [%sexp "The underlying kernel does not support all the io_uring operations needed"]) 96 | ;; 97 | 98 | let exit = Uring.exit 99 | let supports_ext_arg = Uring.supports_ext_arg 100 | let register_eventfd = Uring.register_eventfd 101 | let submit t = Uring.submit t 102 | let cqe_ready t = Uring.cqe_ready t 103 | 104 | let rec iter_completions_internal io_uring ~f count = 105 | match Uring.get_cqe_nonblocking io_uring with 106 | | Some { result; data } -> 107 | f ~result ~data; 108 | iter_completions_internal io_uring ~f (count + 1) 109 | | None -> count 110 | ;; 111 | 112 | let iter_completions io_uring ~f = iter_completions_internal io_uring ~f 0 113 | 114 | let fill_syscall_ivar ~result ~data = 115 | if result >= 0 116 | then Ivar.fill_exn data (Ok result) 117 | else Ivar.fill_exn data (Error (Unix.Error.of_system_int ~errno:(-result))) 118 | ;; 119 | 120 | let fill_completions t = iter_completions t ~f:fill_syscall_ivar 121 | let max_attempts = -1 122 | 123 | let prepare_internal f = 124 | let ivar = Ivar.create () in 125 | let handle = { Handle.result = ivar; job = None; status = To_prepare } in 126 | Deferred.don't_wait_for 127 | (let rec submit_until_success count = 128 | match handle.status with 129 | | To_prepare -> 130 | (match f ivar with 131 | | None -> 132 | if count = max_attempts 133 | then failwith "Tried resubmitting to the Io_uring queue too many times"; 134 | let%bind () = Async_kernel_scheduler.yield () in 135 | submit_until_success (count + 1) 136 | | Some job -> 137 | Handle.set_status handle Prepared_or_finished; 138 | Handle.set_job handle (Some job); 139 | return ()) 140 | | Cancelled_early -> 141 | Handle.set_status handle Prepared_or_finished; 142 | return () 143 | | Cancel_prepared _ | Prepared_or_finished -> 144 | raise_s 145 | [%sexp 146 | (( "Io_uring_raw syscall found in unexpected state while submitting" 147 | , Handle.status handle ) 148 | : string * Status.t)] 149 | in 150 | submit_until_success 0); 151 | Deferred.upon (Ivar.read ivar) (fun _ -> 152 | Handle.set_job handle None; 153 | (* We need this branching in order to keep the invariant of the submit_until_success 154 | loop. Otherwise, there is a race that can happen: the submit_until_success job gets 155 | scheduled, a cancel job moves the job to Cancelled_early and fills its ivar, but 156 | the ivar being filled triggers this callback that moves it to Prepared_or_finished. 157 | *) 158 | match handle.status with 159 | | Cancelled_early | Prepared_or_finished -> () 160 | | Cancel_prepared _ -> Handle.set_status handle Prepared_or_finished 161 | | To_prepare -> 162 | raise_s [%sexp "Io_uring_raw syscall ivar filled while in state To_prepare"]); 163 | handle 164 | ;; 165 | 166 | let noop t = prepare_internal (Uring.noop t) 167 | let read t ~file_offset fd buf = prepare_internal (Uring.read t ~file_offset fd buf) 168 | let write t ~file_offset fd buf = prepare_internal (Uring.write t ~file_offset fd buf) 169 | let readv t ~file_offset fd bufs = prepare_internal (Uring.readv t ~file_offset fd bufs) 170 | let writev t ~file_offset fd bufs = prepare_internal (Uring.writev t ~file_offset fd bufs) 171 | let poll_add t fd flags = prepare_internal (Uring.poll_add t fd flags) 172 | 173 | let openat2 t ~access ~flags ~perm ~resolve ?fd filename = 174 | prepare_internal (Uring.openat2 t ~access ~flags ~perm ~resolve ?fd filename) 175 | ;; 176 | 177 | let close t fd = prepare_internal (Uring.close t fd) 178 | 179 | let link t ~follow ~target ~link_name = 180 | prepare_internal (Uring.linkat t ~follow ~target ~link_name) 181 | ;; 182 | 183 | let unlink t ~dir ?fd filename = prepare_internal (Uring.unlink t ~dir ?fd filename) 184 | 185 | let timeout t ?absolute clock timeout_ns = 186 | let clock = Clock.to_uring_clock clock in 187 | prepare_internal (Uring.timeout t ?absolute clock timeout_ns) 188 | ;; 189 | 190 | let statx t ?fd ~mask path statx flags = 191 | prepare_internal (Uring.statx t ?fd ~mask path statx flags) 192 | ;; 193 | 194 | let cancel t handle = 195 | let rec cancel_until_success () = 196 | if Ivar.is_full (Handle.result handle) 197 | then return () 198 | else ( 199 | match Handle.status handle with 200 | | Cancelled_early -> return () 201 | | Cancel_prepared cancel_ivar -> 202 | (match%map Ivar.read cancel_ivar with 203 | | Ok _ -> () 204 | | Error Unix.Error.EALREADY -> 205 | (* This means the job has alreay started running and can't be cancelled. *) 206 | () 207 | | Error Unix.Error.ENOENT -> 208 | (* The job we are trying to cancel has already finished by the time the cancel 209 | was executed. *) 210 | () 211 | | Error err -> raise (Unix.Unix_error (err, "cancel", ""))) 212 | | To_prepare -> 213 | Handle.set_status handle Cancelled_early; 214 | Ivar.fill_if_empty (Handle.result handle) (Error (Unix.Error.EUNKNOWNERR 125)); 215 | return () 216 | | Prepared_or_finished -> 217 | let cancel_ivar = Ivar.create () in 218 | (* [Uring.cancel] requires that the completion wasn't collected yet. We know it 219 | wasn't collected because we just checked [Ivar.is_full result_ivar] earlier. 220 | *) 221 | (match Uring.cancel t (Option.value_exn handle.job) cancel_ivar with 222 | | None -> 223 | let%bind () = Async_kernel_scheduler.yield () in 224 | cancel_until_success () 225 | | Some _cancel_job -> 226 | Handle.set_status handle (Cancel_prepared cancel_ivar); 227 | cancel_until_success ())) 228 | in 229 | cancel_until_success () 230 | ;; 231 | 232 | let syscall_result_noretry handle = Ivar.read (Handle.result handle) 233 | let has_pending_jobs t = Uring.active_ops t > 0 234 | 235 | [%%else] 236 | 237 | include Io_uring_raw_null 238 | 239 | [%%endif] 240 | 241 | let syscall_result_retry_on_ECANCELED f = 242 | let rec retry_loop f count = 243 | let max_tries = 1000 in 244 | if count = max_tries 245 | then return (Error (Unix.EUNKNOWNERR 125)) 246 | else ( 247 | match%bind syscall_result_noretry (f ()) with 248 | | Error (Unix.EUNKNOWNERR 125) -> 249 | (* We've seen some weird behavior where our calls return with ECANCELED 250 | even though we're not asking to cancel. Work around this issue, 251 | which seems like it may be a kernel bug. 252 | 253 | This can't be a real cancellation because the job handle is made by 254 | [f ()] above and we don't ever call cancel on that. *) 255 | retry_loop f (count + 1) 256 | | Error err -> return (Error err) 257 | | Ok result -> return (Ok result)) 258 | in 259 | retry_loop f 0 260 | ;; 261 | -------------------------------------------------------------------------------- /src/io_uring_raw.mli: -------------------------------------------------------------------------------- 1 | include Io_uring_raw_intf.S (** @inline *) 2 | 3 | val syscall_result_retry_on_ECANCELED 4 | : (unit -> Handle.t) 5 | -> Syscall_result.t Async_kernel.Deferred.t 6 | -------------------------------------------------------------------------------- /src/io_uring_raw_intf.ml: -------------------------------------------------------------------------------- 1 | (** [Io_uring_raw] is Async's wrapper over the Ocaml_uring API for using io_uring. 2 | 3 | Each Io_uring_raw has an internal submission queue and a completion queue. Whenever 4 | you make a syscall it is actually only added to the submission queue and you receive a 5 | Handle that can be used to either get the Deferred of the underlying syscall or cancel 6 | the syscall entirely (cancellation is only best effort, not a guarantee). 7 | 8 | After some syscalls have been queued in the submission queue they can be sent to the 9 | kernel in a batch via [submit] which will send all or part of the submission queue. 10 | 11 | At this point the kernel will take care of the syscalls and whenever one is completed, 12 | the corresponding event is added to the completion queue. 13 | 14 | The completion queue can be consumed using [fill_completions] which will make the 15 | syscalls deferred be filled up and makes room for new syscalls to be submitted. There 16 | is no guarantee about the order in which syscalls are completed. 17 | 18 | Extra care should be taken when using this module as certain usages might cause 19 | starvation or even deadlocks. For instance, it could be the case that we fill up the 20 | queue with very slow syscalls and are unable to quickly execute cheap syscalls while 21 | waiting. Even worse, we might fill up the queue with blocking syscalls that can only 22 | be executed after an additional syscall is made - which we cannot submit. 23 | 24 | For further documenation on the internals of each syscall, read the analog 25 | documentation in external/lib/ocaml_uring. *) 26 | 27 | open! Core 28 | open Import 29 | 30 | module type S = sig 31 | include Io_uring_types_intf.S 32 | 33 | type t 34 | 35 | module Syscall_result : sig 36 | type t = (int, Unix.Error.t) Result.t [@@deriving sexp_of] 37 | end 38 | 39 | module Handle : sig 40 | type t 41 | 42 | include Invariant.S with type t := t 43 | end 44 | 45 | val create : ?polling_timeout:int -> queue_depth:int -> unit -> t Or_error.t 46 | val supports_ext_arg : t -> bool 47 | val exit : t -> unit 48 | val register_eventfd : t -> File_descr.t -> unit 49 | val submit : t -> int 50 | val cqe_ready : t -> timeout:float -> bool 51 | val fill_completions : t -> int 52 | val noop : t -> Handle.t 53 | val read : t -> file_offset:Int63.t -> File_descr.t -> Cstruct.t -> Handle.t 54 | val write : t -> file_offset:Int63.t -> File_descr.t -> Cstruct.t -> Handle.t 55 | val readv : t -> file_offset:Int63.t -> File_descr.t -> Cstruct.t list -> Handle.t 56 | val writev : t -> file_offset:Int63.t -> File_descr.t -> Cstruct.t list -> Handle.t 57 | val poll_add : t -> File_descr.t -> Poll_mask.t -> Handle.t 58 | 59 | (** Openat2 will fail if non-zero perms are passed while no file is being created (i.e. 60 | when creat or tmpfile are not passed as flags) *) 61 | val openat2 62 | : t 63 | -> access:[ `R | `W | `RW ] 64 | -> flags:Open_flags.t 65 | -> perm:Unix.file_perm 66 | -> resolve:Resolve.t 67 | -> ?fd:File_descr.t 68 | -> string 69 | -> Handle.t 70 | 71 | val close : t -> File_descr.t -> Handle.t 72 | val link : t -> follow:bool -> target:string -> link_name:string -> Handle.t 73 | val unlink : t -> dir:bool -> ?fd:File_descr.t -> string -> Handle.t 74 | val timeout : t -> ?absolute:bool -> Clock.t -> int64 -> Handle.t 75 | 76 | val statx 77 | : t 78 | -> ?fd:File_descr.t 79 | -> mask:Statx.Mask.t 80 | -> string 81 | -> Statx.t 82 | -> Statx.Flags.t 83 | -> Handle.t 84 | 85 | val cancel : t -> Handle.t -> unit Deferred.t 86 | val syscall_result_noretry : Handle.t -> Syscall_result.t Deferred.t 87 | val has_pending_jobs : t -> bool 88 | end 89 | -------------------------------------------------------------------------------- /src/io_uring_raw_null.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | 4 | type t 5 | 6 | module Int63 = struct 7 | type t [@@immediate64] 8 | 9 | let of_int _ = assert false 10 | let to_int _ = assert false 11 | end 12 | 13 | module FLAGS = struct 14 | type t = int 15 | 16 | let empty = 0 17 | let _ = empty 18 | let of_int x = x 19 | let ( + ) = ( lor ) 20 | let mem a b = a land b = a 21 | end 22 | 23 | module Poll_mask = struct 24 | include FLAGS 25 | 26 | let pollin = 0 27 | let pollout = 0 28 | let pollerr = 0 29 | let pollhup = 0 30 | end 31 | 32 | module Clock = struct 33 | type t = 34 | | Boottime 35 | | Realtime 36 | end 37 | 38 | module Statx = struct 39 | type t 40 | 41 | type kind = 42 | [ `Unknown 43 | | `Fifo 44 | | `Character_special 45 | | `Directory 46 | | `Block_device 47 | | `Regular_file 48 | | `Symbolic_link 49 | | `Socket 50 | ] 51 | 52 | let create _ = assert false 53 | 54 | module Flags = struct 55 | include FLAGS 56 | 57 | let empty = 0 58 | let empty_path = 0 59 | let no_automount = 0 60 | let symlink_nofollow = 0 61 | let statx_sync_as_stat = 0 62 | let statx_force_sync = 0 63 | let statx_dont_sync = 0 64 | end 65 | 66 | module Attr = struct 67 | include FLAGS 68 | 69 | let compressed = 0 70 | let immutable = 0 71 | let append = 0 72 | let nodump = 0 73 | let encrypted = 0 74 | let verity = 0 75 | 76 | (** Since Linux 5.8 *) 77 | let dax = 0 78 | 79 | let check ?mask:_ _ _ = false 80 | end 81 | 82 | module Mask = struct 83 | include FLAGS 84 | 85 | let type' = 0 86 | let mode = 0 87 | let nlink = 0 88 | let uid = 0 89 | let gid = 0 90 | let atime = 0 91 | let mtime = 0 92 | let ctime = 0 93 | let ino = 0 94 | let size = 0 95 | let blocks = 0 96 | let basic_stats = 0 97 | let btime = 0 98 | 99 | (** As of Linux 5.8 *) 100 | let mnt_id = 0 101 | 102 | (** As of Linux 6.1 *) 103 | let dioalign = 0 104 | 105 | let check _ _ = false 106 | end 107 | 108 | let blksize _ = Int64.zero 109 | let attributes _ = Int64.zero 110 | let nlink _ = Int64.zero 111 | let uid _ = Int64.zero 112 | let gid _ = Int64.zero 113 | let ino _ = Int64.zero 114 | let size _ = Int64.zero 115 | let blocks _ = Int64.zero 116 | let attributes_mask _ = Int64.zero 117 | let rdev _ = Int64.zero 118 | let dev _ = Int64.zero 119 | let mask _ = Int64.zero 120 | 121 | (** See {! Mask.mnt_id}. *) 122 | let mnt_id _ = Int64.zero 123 | 124 | (** See {! Mask.dioalign}. *) 125 | let dio_mem_align _ = Int64.zero 126 | 127 | (** See {! Mask.dioalign}. *) 128 | let dio_offset_align _ = Int64.zero 129 | 130 | let atime_sec _ = Int64.zero 131 | let btime_sec _ = Int64.zero 132 | let ctime_sec _ = Int64.zero 133 | let mtime_sec _ = Int64.zero 134 | let atime_nsec _ = 0 135 | let btime_nsec _ = 0 136 | let ctime_nsec _ = 0 137 | let mtime_nsec _ = 0 138 | let mode _ = 0 139 | let perm _ = 0 140 | let kind _ = `Unknown 141 | end 142 | 143 | module Syscall_result = struct 144 | type t = (int, Unix.Error.t) Result.t [@@deriving sexp_of] 145 | end 146 | 147 | module Handle = struct 148 | type t 149 | 150 | let invariant _ = () 151 | end 152 | 153 | (** Flags that can be passed to openat2. *) 154 | module Open_flags = struct 155 | include FLAGS 156 | 157 | let empty = 0 158 | let append = 0 159 | let cloexec = 0 160 | let creat = 0 161 | let direct = 0 162 | let directory = 0 163 | let dsync = 0 164 | let excl = 0 165 | let largefile = 0 166 | let noatime = 0 167 | let noctty = 0 168 | let nofollow = 0 169 | let nonblock = 0 170 | let path = 0 171 | let sync = 0 172 | let tmpfile = 0 173 | let trunc = 0 174 | end 175 | 176 | (** Flags that can be passed to openat2 to control path resolution. *) 177 | module Resolve = struct 178 | include FLAGS 179 | 180 | let empty = 0 181 | let beneath = 0 182 | let in_root = 0 183 | let no_magiclinks = 0 184 | let no_symlinks = 0 185 | let no_xdev = 0 186 | let cached = 0 187 | end 188 | 189 | let create ?polling_timeout:_ ~queue_depth:_ () = 190 | Or_error.unimplemented "Io_uring_raw.create" 191 | ;; 192 | 193 | let exit _ = assert false 194 | let supports_ext_arg _ = assert false 195 | let submit _ = assert false 196 | let cqe_ready _ ~timeout:_ = assert false 197 | let fill_completions _ = assert false 198 | let noop _ = assert false 199 | let read _ = assert false 200 | let write _ = assert false 201 | let readv _ = assert false 202 | let writev _ = assert false 203 | let poll_add _ = assert false 204 | let openat2 _ = assert false 205 | let close _ = assert false 206 | let unlink _ = assert false 207 | let link _ = assert false 208 | let timeout _ = assert false 209 | let statx _ = assert false 210 | let cancel _ = assert false 211 | let syscall_result_noretry _ = assert false 212 | let register_eventfd _ = assert false 213 | let has_pending_jobs _ = assert false 214 | -------------------------------------------------------------------------------- /src/io_uring_raw_null.mli: -------------------------------------------------------------------------------- 1 | include Io_uring_raw_intf.S 2 | -------------------------------------------------------------------------------- /src/io_uring_raw_singleton.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | module Eventfd = Linux_ext.Eventfd 4 | 5 | type t = 6 | | Not_supported of unit 7 | | Ok of Io_uring_raw.t 8 | 9 | module Eventfd_driver = struct 10 | (** The submission and completion of tasks is completely autonomous, using two async 11 | jobs (one for submission and one for completion) that get scheduled when needed. 12 | Submission is done at the end of every cycle (submissions when the queue is empty 13 | should be very cheap). If a syscall makes its way to the completion queue, the job 14 | that will fill the corresponding deferred is scheduled the next time the async 15 | scheduler checks for I/O through the file descriptor watcher. *) 16 | let register_hooks uring eventfd = 17 | Io_uring_raw.register_eventfd uring (Eventfd.to_file_descr eventfd); 18 | Async_kernel_scheduler.Expert.run_every_cycle_end (fun () -> 19 | let (_ : int) = Io_uring_raw.submit uring in 20 | ()); 21 | let fd = 22 | Raw_scheduler.create_fd 23 | Raw_fd.Kind.Fifo 24 | (Eventfd.to_file_descr eventfd) 25 | (Info.create_s [%sexp "io_uring_raw eventfd"]) 26 | in 27 | (* Although this job is only ever scheduled when the eventfd is ready to read, we 28 | still have to run it in nonblocking mode and handle operations that would block. 29 | This is needed because this job could end up being scheduled more than once at a 30 | time and be run multiple times within the same async cycle. 31 | (max_num_jobs_per_priority_per_cycle can cause this job to be run in a future cycle) 32 | *) 33 | let eventfd_ready_job = 34 | Raw_scheduler.create_job 35 | (Raw_scheduler.the_one_and_only ()) 36 | (fun () -> 37 | try 38 | let (_ : Int64.t) = Eventfd.read eventfd in 39 | let (_ : int) = Io_uring_raw.fill_completions uring in 40 | () 41 | with 42 | | Unix.Unix_error ((EAGAIN | EWOULDBLOCK), _, _) -> () 43 | | exn -> raise exn) 44 | () 45 | in 46 | let finished_watching = Ivar.create () in 47 | (match 48 | Raw_scheduler.request_start_watching 49 | (Raw_scheduler.the_one_and_only ()) 50 | fd 51 | `Read 52 | (Raw_fd.Watching.Watch_repeatedly 53 | { job = eventfd_ready_job 54 | ; finished_ivar = finished_watching 55 | ; pending = (fun () -> Io_uring_raw.has_pending_jobs uring) 56 | }) 57 | with 58 | | `Watching -> () 59 | | (`Already_closed | `Already_watching) as result -> 60 | raise_s 61 | [%sexp 62 | (("unexpected result when asked to watch eventfd", result) 63 | : string * [ `Already_closed | `Already_watching ])]); 64 | Deferred.upon (Ivar.read finished_watching) (fun reason -> 65 | raise_s 66 | [%sexp 67 | (("unexpectedly stopped watching eventfd", reason) 68 | : string * [ `Bad_fd | `Closed | `Interrupted | `Unsupported ])]) 69 | ;; 70 | 71 | let force_uring_exn () = 72 | let uring = 73 | Io_uring_raw.create 74 | ~queue_depth: 75 | (Io_uring_max_submission_entries.raw Config.io_uring_max_submission_entries) 76 | () 77 | in 78 | match Eventfd.create, uring with 79 | | Error eventfd_error, Error uring_error -> 80 | Error.raise (Error.of_list [ eventfd_error; uring_error ]) 81 | | Error eventfd_error, Ok uring -> 82 | Io_uring_raw.exit uring; 83 | Error.raise eventfd_error 84 | | Ok _, Error uring_error -> Error.raise uring_error 85 | | Ok create_eventfd, Ok uring -> 86 | let eventfd = 87 | create_eventfd ~flags:Eventfd.Flags.(cloexec + nonblock) (Int32.of_int_exn 0) 88 | in 89 | register_hooks uring eventfd; 90 | Ok uring 91 | ;; 92 | 93 | let force_uring_noraise () = 94 | try force_uring_exn () with 95 | | _exn -> Not_supported () 96 | ;; 97 | end 98 | 99 | module From_scheduler_driver = struct 100 | let force_uring () = 101 | match Raw_scheduler.uring (Raw_scheduler.t ()) with 102 | | None -> Not_supported () 103 | | Some uring -> Ok uring 104 | ;; 105 | end 106 | 107 | let create_global_io_uring () = 108 | match Config.io_uring_mode with 109 | | Disabled -> Not_supported () 110 | | Eventfd -> Eventfd_driver.force_uring_exn () 111 | | If_available_eventfd -> Eventfd_driver.force_uring_noraise () 112 | | From_scheduler -> From_scheduler_driver.force_uring () 113 | ;; 114 | 115 | let global_io_uring = lazy (create_global_io_uring ()) 116 | 117 | let the_one_and_only () = 118 | match force global_io_uring with 119 | | Not_supported () -> None 120 | | Ok io_uring -> Some io_uring 121 | ;; 122 | -------------------------------------------------------------------------------- /src/io_uring_raw_singleton.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | (** This module contains a singleton that wraps over different possible drivers of the 4 | [Io_uring_raw]. Currently it only supports an [Eventfd] driver or not using [Io_uring] 5 | at all. The underlying implementation can be picked via the io_uring_mode async 6 | config. *) 7 | 8 | val the_one_and_only : unit -> Io_uring_raw.t option 9 | -------------------------------------------------------------------------------- /src/io_uring_types_intf.ml: -------------------------------------------------------------------------------- 1 | (** This module contains a copy of the interfaces of types used by Io_uring. We keep these 2 | separated from the main Io_uring_raw_intf where this modules is included. This is done 3 | such that we can have different implementation for all those types in the case where 4 | io_uring is/is not supported by the underlying system, such that we do not have any 5 | dependency on Ocaml_uring. *) 6 | 7 | module type FLAGS = sig 8 | (** A set of flags. *) 9 | type t = private int 10 | 11 | val of_int : int -> t 12 | 13 | (** [a + b] is the union of the sets. *) 14 | val ( + ) : t -> t -> t 15 | 16 | (** [mem x flags] is [true] iff [x] is a subset of [flags]. *) 17 | val mem : t -> t -> bool 18 | end 19 | 20 | module type S = sig 21 | module Int63 : sig 22 | (** The type of integers with exactly 63-bits. *) 23 | type t [@@immediate64] 24 | 25 | val of_int : int -> t 26 | val to_int : t -> int 27 | end 28 | 29 | module Poll_mask : sig 30 | include FLAGS 31 | 32 | val pollin : t 33 | val pollout : t 34 | val pollerr : t 35 | val pollhup : t 36 | end 37 | 38 | module Clock : sig 39 | type t = 40 | | Boottime 41 | | Realtime 42 | end 43 | 44 | module Statx : sig 45 | (** A statx struct. *) 46 | type t 47 | 48 | type kind = 49 | [ `Unknown 50 | | `Fifo 51 | | `Character_special 52 | | `Directory 53 | | `Block_device 54 | | `Regular_file 55 | | `Symbolic_link 56 | | `Socket 57 | ] 58 | 59 | (** Use [create] to make a statx result buffer to pass to {! statx}. *) 60 | val create : unit -> t 61 | 62 | module Flags : sig 63 | include FLAGS 64 | 65 | val empty : t 66 | val empty_path : t 67 | val no_automount : t 68 | val symlink_nofollow : t 69 | val statx_sync_as_stat : t 70 | val statx_force_sync : t 71 | val statx_dont_sync : t 72 | end 73 | 74 | module Attr : sig 75 | include FLAGS 76 | 77 | val compressed : t 78 | val immutable : t 79 | val append : t 80 | val nodump : t 81 | val encrypted : t 82 | val verity : t 83 | 84 | (** Since Linux 5.8 *) 85 | val dax : t 86 | 87 | (** [check ?mask attr t] will check if [t] is set in [attr]. 88 | 89 | If [mask] is not [None] then it will first check the mask to see if the file 90 | attribute is supported and if not raise [Invalid_argument]. *) 91 | val check : ?mask:Int64.t -> Int64.t -> t -> bool 92 | end 93 | 94 | module Mask : sig 95 | include FLAGS 96 | 97 | val type' : t 98 | val mode : t 99 | val nlink : t 100 | val uid : t 101 | val gid : t 102 | val atime : t 103 | val mtime : t 104 | val ctime : t 105 | val ino : t 106 | val size : t 107 | val blocks : t 108 | 109 | (** All of the above flags. *) 110 | val basic_stats : t 111 | 112 | val btime : t 113 | 114 | (** As of Linux 5.8 *) 115 | val mnt_id : t 116 | 117 | (** As of Linux 6.1 *) 118 | val dioalign : t 119 | 120 | (** [check mask t] checks if [t] is set in [mask]. *) 121 | val check : Int64.t -> t -> bool 122 | end 123 | 124 | (** You may wish to use {! Mask.check} to verify the field has actually been returned 125 | with a sensible value first. *) 126 | 127 | val blksize : t -> Int64.t 128 | val attributes : t -> Int64.t 129 | val nlink : t -> Int64.t 130 | val uid : t -> Int64.t 131 | val gid : t -> Int64.t 132 | val ino : t -> Int64.t 133 | val size : t -> Int64.t 134 | val blocks : t -> Int64.t 135 | val attributes_mask : t -> Int64.t 136 | val rdev : t -> Int64.t 137 | val dev : t -> Int64.t 138 | val mask : t -> Int64.t 139 | 140 | (** See {! Mask.mnt_id}. *) 141 | val mnt_id : t -> Int64.t 142 | 143 | (** See {! Mask.dioalign}. *) 144 | val dio_mem_align : t -> Int64.t 145 | 146 | (** See {! Mask.dioalign}. *) 147 | val dio_offset_align : t -> Int64.t 148 | 149 | val atime_sec : t -> int64 150 | val btime_sec : t -> int64 151 | val ctime_sec : t -> int64 152 | val mtime_sec : t -> int64 153 | val atime_nsec : t -> int 154 | val btime_nsec : t -> int 155 | val ctime_nsec : t -> int 156 | val mtime_nsec : t -> int 157 | val mode : t -> int 158 | val perm : t -> int 159 | val kind : t -> kind 160 | end 161 | 162 | (** Flags that can be passed to openat2. *) 163 | module Open_flags : sig 164 | include FLAGS 165 | 166 | val empty : t 167 | val append : t 168 | val cloexec : t 169 | val creat : t 170 | val direct : t 171 | val directory : t 172 | val dsync : t 173 | val excl : t 174 | val largefile : t 175 | val noatime : t 176 | val noctty : t 177 | val nofollow : t 178 | val nonblock : t 179 | val path : t 180 | val sync : t 181 | val tmpfile : t 182 | val trunc : t 183 | end 184 | 185 | (** Flags that can be passed to openat2 to control path resolution. *) 186 | module Resolve : sig 187 | include FLAGS 188 | 189 | val empty : t 190 | val beneath : t 191 | val in_root : t 192 | val no_magiclinks : t 193 | val no_symlinks : t 194 | val no_xdev : t 195 | val cached : t 196 | end 197 | end 198 | -------------------------------------------------------------------------------- /src/magic_trace_stubs.c: -------------------------------------------------------------------------------- 1 | #include "caml/mlvalues.h" 2 | 3 | /* This empty function is here so magic-trace users can put a breakpoint on it. */ 4 | value magic_trace_long_async_cycle() { return Val_unit; } 5 | -------------------------------------------------------------------------------- /src/process.mli: -------------------------------------------------------------------------------- 1 | (** [Async.Process] is for creating child processes of the current process, and 2 | communicating with children via their stdin, stdout, and stderr. [Async.Process] is 3 | the Async analog of [Core_unix.create_process] and related functions. *) 4 | 5 | open! Core 6 | open! Import 7 | 8 | type t [@@deriving sexp_of] 9 | 10 | (** accessors *) 11 | 12 | val pid : t -> Pid.t 13 | val stdin : t -> Writer.t 14 | val stdout : t -> Reader.t 15 | val stderr : t -> Reader.t 16 | 17 | type env = Unix.env [@@deriving sexp] 18 | 19 | (** [create ~prog ~args ()] uses [Core_unix.create_process_env] to create a child process 20 | that runs the executable [prog] with [args] as arguments. 21 | 22 | This creates pipes to communicate with the child process's [stdin], [stdout], and 23 | [stderr]. The caller is responsible for closing all these pipes. A lot of calls in the 24 | [Reader] module will close the underlying fd (e.g. iterating on [Reader.pipe]). You 25 | likely will have to explicitly call [Writer.close] on the [stdin] writer unless you 26 | call [collect_output_and_wait]. 27 | 28 | Unlike [exec], [args] should not include [prog] as the first argument. 29 | 30 | If [buf_len] is supplied, it determines the size of the reader and writer buffers used 31 | to communicate with the child process's [stdin], [stdout], and [stderr]. 32 | 33 | If [stdin] is supplied, then the writer to the child's stdin will have 34 | [~raise_when_consumer_leaves:false] and [~buffer_age_limit:`Unlimited], which makes it 35 | more robust. 36 | 37 | [env] specifies the environment of the child process. 38 | 39 | If [working_dir] is supplied, then the child process will [chdir()] there before 40 | calling [exec()]. 41 | 42 | If [argv0] is given, it is used (instead of [prog]) as the first element of the [argv] 43 | array passed to [exec]. 44 | 45 | [create] returns [Error] if it is unable to create the child process. This can happen 46 | in any number of situations (unable to fork, unable to create the pipes, unable to cd 47 | to [working_dir], unable to [exec] etc.). [create] does not return [Error] if the 48 | binary exits with non-zero exit code; instead, it returns [OK t], where [wait t] 49 | returns an [Error]. 50 | 51 | See [Core_unix.create_process_env] for more details. *) 52 | type 'a create := 53 | ?argv0:string 54 | -> ?buf_len:int 55 | -> ?env:env (** default is [`Extend []] *) 56 | -> ?prog_search_path:string list 57 | -> ?stdin:string 58 | -> ?working_dir:string 59 | -> ?setpgid:Unix.Pgid.t 60 | -> prog:string 61 | -> args:string list 62 | -> unit 63 | -> 'a Deferred.t 64 | 65 | val create : t Or_error.t create 66 | val create_exn : t create 67 | 68 | (** [wait t = Unix.waitpid (pid t)]. [wait]'s result becomes determined when the child 69 | process terminates, via exit or signal. [wait] does not touch [stdin], [stdout] or 70 | [stderr]. The caller should ensure that [stdout] and [stderr] are being drained in the 71 | background to avoid the child process blocking on a write due to pushback. See 72 | [collect_output_and_wait] for a higher-level alternative that handles this. *) 73 | val wait : t -> Unix.Exit_or_signal.t Deferred.t 74 | 75 | module Output : sig 76 | type t = 77 | { stdout : string 78 | ; stderr : string 79 | ; exit_status : Unix.Exit_or_signal.t 80 | } 81 | [@@deriving compare, sexp_of] 82 | 83 | module Stable : sig 84 | module V1 : sig 85 | type nonrec t = t [@@deriving compare, sexp] 86 | end 87 | end 88 | end 89 | 90 | (** [collect_output_and_wait t] closes [stdin t] and then begins collecting the output 91 | produced on [t]'s [stdout] and [stderr], continuing to collect output until [t] 92 | terminates and the pipes for [stdout] and [stderr] are closed. Usually when [t] 93 | terminates, the pipes are closed; however, [t] could fork other processes which 94 | survive after [t] terminates and in turn keep the pipes open -- 95 | [collect_output_and_wait] will not become determined until both pipes are closed in 96 | all descendant processes. *) 97 | val collect_output_and_wait : t -> Output.t Deferred.t 98 | 99 | (** [run] [create]s a process, feeds it [stdin] if provided, and [wait]s for it to 100 | complete. If the process exits with an acceptable status, then [run] returns its 101 | stdout. If the process exits unacceptably, then [run] returns an error indicating what 102 | went wrong that includes stdout and stderr. 103 | 104 | Acceptable statuses are zero, and any nonzero values specified in 105 | [accept_nonzero_exit]. 106 | 107 | Some care is taken so that an error displays nicely as a sexp---in particular, if the 108 | child's output can already be parsed as a sexp, then it will display as a sexp (rather 109 | than a sexp embedded in a string). Also, if the output isn't a sexp, it will be split 110 | on newlines into a list of strings, so that it displays on multiple lines rather than 111 | a single giant line with embedded "\n"'s. 112 | 113 | [run_lines] is like [run] but returns the lines of stdout as a string list, using 114 | [String.split_lines]. 115 | 116 | [run_expect_no_output] is like [run] but expects the command to produce no output, and 117 | returns an error if the command does produce output. 118 | 119 | [run_forwarding] is like [run] but it forwards the stdout and stderr of the child 120 | process to the stdout and stderr of the calling process. One can choose to share the 121 | stdout/stderr file descriptors with the child process ([`Share]) or copy the data 122 | ([`Splice] [0], which is the default). Sharing the file descriptors minimizes 123 | performance overhead, but it may change behavior. For example if a shared fd 124 | corresponds to the terminal then the child process may choose to write colored output 125 | where it'd otherwise write ASCII. If there's an error (e.g. SIGPIPE) writing to a 126 | shared fd, that will be handled by the child process directly, instead of being 127 | handled in the parent. If [`Share] is passed, [run_forwarding] will wait for 128 | [Writer.stdout] and [Writer.stderr] to be flushed before spawning the child process to 129 | avoid interleaving output with anything previously written to the writers. 130 | 131 | [0] The name splice is a reference to the linux splice syscall, though note that it's 132 | not actually used here for portability reasons. *) 133 | type 'a run := 134 | ?accept_nonzero_exit:int list (** default is [] *) 135 | -> ?argv0:string 136 | -> ?env:env (** default is [`Extend []] *) 137 | -> ?prog_search_path:string list 138 | -> ?stdin:string 139 | -> ?working_dir:string 140 | -> prog:string 141 | -> args:string list 142 | -> unit 143 | -> 'a Deferred.t 144 | 145 | val run : string Or_error.t run 146 | val run_exn : string run 147 | val run_lines : string list Or_error.t run 148 | val run_lines_exn : string list run 149 | val run_expect_no_output : unit Or_error.t run 150 | val run_expect_no_output_exn : unit run 151 | val run_forwarding : ?child_fds:[ `Share | `Splice ] -> unit Or_error.t run 152 | val run_forwarding_exn : ?child_fds:[ `Share | `Splice ] -> unit run 153 | 154 | (** [collect_stdout_and_wait] and [collect_stdout_lines_and_wait] are like [run] and 155 | [run_lines] but work from an existing process instead of creating a new one. *) 156 | type 'a collect := 157 | ?accept_nonzero_exit:int list (** default is [] *) -> t -> 'a Deferred.t 158 | 159 | val collect_stdout_and_wait : string Or_error.t collect 160 | val collect_stdout_and_wait_exn : string collect 161 | val collect_stdout_lines_and_wait : string list Or_error.t collect 162 | val collect_stdout_lines_and_wait_exn : string list collect 163 | 164 | (** [forward_output_and_wait] is like [run_forwarding] but works from an existing process 165 | instead of creating a new one. *) 166 | 167 | val forward_output_and_wait : unit Or_error.t collect 168 | val forward_output_and_wait_exn : unit collect 169 | 170 | module How_to_handle_output : sig 171 | type ('output, 'child_fds) t = 172 | | Collect_stdout_and_wait : (string, 'child_fds) t 173 | | Collect_stdout_lines_and_wait : (string list, 'child_fds) t 174 | | Forward_output_and_wait : 'child_fds -> (unit, 'child_fds) t 175 | end 176 | 177 | (** Same as the above run functions but uses a GADT to represent how to handle the output. 178 | When forwarding output, if you aren't sure you want the child process to share file 179 | descriptors with the parent, pass [false]. *) 180 | val run' 181 | : ('a, [ `Share_fds_with_child of bool ]) How_to_handle_output.t 182 | -> 'a Or_error.t run 183 | 184 | val run'_exn : ('a, [ `Share_fds_with_child of bool ]) How_to_handle_output.t -> 'a run 185 | 186 | (** Save as the above output-collecting functions but uses a GADT to represent how to 187 | handle the output. *) 188 | val handle_output : ('a, unit) How_to_handle_output.t -> 'a Or_error.t collect 189 | 190 | val handle_output_exn : ('a, unit) How_to_handle_output.t -> 'a collect 191 | 192 | (** Sends a signal to this process. This is safe to call concurrently with [wait t], even 193 | if the Pid is reused after the process died. 194 | 195 | If the process was already terminated, the call succeeds and silently does nothing, 196 | regardless of whether or not the process was waited for. *) 197 | val send_signal : t -> Signal.t -> unit 198 | 199 | (** Similar to [send_signal], but additionally reports if a signal was actually sent, or a 200 | process was already terminated and waited for. 201 | 202 | Note that if you never called [wait] on this process, you will always get [`Ok], which 203 | can be surprising. This function is exposed for compatibility with the code that used 204 | [Signal_unix.send]. *) 205 | val send_signal_compat : t -> Signal.t -> [ `Ok | `No_such_process ] 206 | 207 | (** Similar to [send_signal_compat], but raises an exception on [`No_such_process]. Used 208 | to migrate the code that uses [Signal_unix.send_exn]. *) 209 | val send_signal_compat_exn : t -> Signal.t -> unit 210 | 211 | (** [Lines_or_sexp] is useful for rendering a string nicely in a sexp, avoiding quoting if 212 | the string is multi-line or was produced by converting a sexp to a string. 213 | [Output.sexp_of_t] uses [Lines_or_sexp] to nicely render stdout and stderr of a child 214 | process. *) 215 | module Lines_or_sexp : sig 216 | type t [@@deriving sexp_of] 217 | 218 | val create : string -> t 219 | end 220 | 221 | (** Aliases exposed for other libraries that want to match Process's style of process 222 | manipulation, but not really part of the modules proper interface. *) 223 | module Aliases : sig 224 | type nonrec 'a create = 'a create 225 | type nonrec 'a run = 'a run 226 | type nonrec 'a collect = 'a collect 227 | end 228 | 229 | module For_tests : sig 230 | val send_signal_internal 231 | : t 232 | -> Signal.t 233 | -> [ `Ok | `No_such_process_internal | `No_such_process_OS ] 234 | end 235 | -------------------------------------------------------------------------------- /src/raw_signal_manager.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | module Signal = Core.Signal 3 | 4 | type delivered = Signal.t Thread_safe_queue.t 5 | 6 | type t = 7 | { original_dispositions_of_managed_signals : Signal.Expert.behavior Signal.Table.t 8 | ; delivered : (delivered[@sexp.opaque]) 9 | ; thread_safe_notify_signal_delivered : unit -> unit 10 | } 11 | [@@deriving sexp_of] 12 | 13 | let invariant _ = () 14 | 15 | let create ~thread_safe_notify_signal_delivered = 16 | { original_dispositions_of_managed_signals = Signal.Table.create () 17 | ; delivered = Thread_safe_queue.create () 18 | ; thread_safe_notify_signal_delivered 19 | } 20 | ;; 21 | 22 | let is_managing t signal = Hashtbl.mem t.original_dispositions_of_managed_signals signal 23 | 24 | let manage t signal = 25 | let _original_disposition = 26 | Hashtbl.find_or_add 27 | t.original_dispositions_of_managed_signals 28 | signal 29 | ~default:(fun () -> 30 | Signal.Expert.signal 31 | signal 32 | (`Handle 33 | (fun _ -> 34 | (* Everything in this function body must be thread safe, since it is running in an 35 | OCaml signal handler. *) 36 | Thread_safe_queue.enqueue t.delivered signal; 37 | t.thread_safe_notify_signal_delivered ()))) 38 | in 39 | () 40 | ;; 41 | 42 | let iter_delivered t ~f = 43 | Thread_safe_queue.dequeue_until_empty t.delivered ~f:(fun signal -> 44 | let original_disposition = 45 | Hashtbl.find_exn t.original_dispositions_of_managed_signals signal 46 | in 47 | f ~original_disposition signal) 48 | [@nontail] 49 | ;; 50 | -------------------------------------------------------------------------------- /src/raw_signal_manager.mli: -------------------------------------------------------------------------------- 1 | (** A signal manager keeps track of a set of signals to be managed. When a signal manager 2 | is managing a signal, it installs its own OCaml handler for that signal that records 3 | delivery of the signal. It then later, upon request, will report the set of signals 4 | that it collected. 5 | 6 | Once a signal manager starts managing a signal, it never stops. *) 7 | 8 | open! Core 9 | module Signal := Core.Signal 10 | 11 | type t [@@deriving sexp_of] 12 | 13 | include Invariant.S with type t := t 14 | 15 | (** [create] creates and returns a signal manager [t]. Whenever a signal that [t] is 16 | managing is delivered, it will call [thread_safe_notify_signal_delivered] from within 17 | the OCaml signal handler. Therefore [thread_safe_notify_signal_delivered] must be 18 | thread safe. *) 19 | val create : thread_safe_notify_signal_delivered:(unit -> unit) -> t 20 | 21 | (** [manage t signal] causes [t] to manage [signal], thus overriding 22 | [default_sys_behavior] for that signal, and any other OCaml handler for that signal. *) 23 | val manage : t -> Signal.t -> unit 24 | 25 | (** [is_managing t signal] returns true iff [manage t signal] has been called *) 26 | val is_managing : t -> Signal.t -> bool 27 | 28 | (** [handle_delivered t] runs all signal handlers on the signals that have been delivered 29 | but not yet handled. *) 30 | val iter_delivered 31 | : t 32 | -> f:(original_disposition:Signal.Expert.behavior -> Signal.t -> unit) 33 | -> unit 34 | -------------------------------------------------------------------------------- /src/reader.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | include Reader0 4 | module Writer = Writer0 5 | 6 | let of_pipe info pipe_r = 7 | let%map `Reader reader_fd, `Writer writer_fd = Unix.pipe info in 8 | let reader = create reader_fd in 9 | let writer = 10 | Writer.create ~buffer_age_limit:`Unlimited ~raise_when_consumer_leaves:false writer_fd 11 | in 12 | if false 13 | then 14 | Debug.log 15 | "Reader.of_pipe" 16 | (pipe_r, reader, writer) 17 | [%sexp_of: string Pipe.Reader.t * t * Writer.t]; 18 | don't_wait_for 19 | (let%bind () = 20 | Writer.transfer writer pipe_r ~stop:(close_finished reader) (fun s -> 21 | Writer.write writer s) 22 | in 23 | Writer.close writer); 24 | reader 25 | ;; 26 | 27 | module For_testing = struct 28 | let of_string ?(info = Info.of_string "reader of string contents for tests") str = 29 | of_pipe info (Pipe.singleton str) 30 | ;; 31 | end 32 | -------------------------------------------------------------------------------- /src/require_explicit_time_source.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | include Require_explicit_time_source_intf 4 | include From_kernel 5 | module Scheduler = Scheduler 6 | module Time = Time_float_unix 7 | module Time_float_unix = Time_float_unix 8 | module Time_float = Time_float_unix 9 | module Time_ns_unix = Time_ns_unix 10 | module Time_ns = Time_ns_unix 11 | module Clock = Clock 12 | module Date = Core.Date 13 | -------------------------------------------------------------------------------- /src/require_explicit_time_source.mli: -------------------------------------------------------------------------------- 1 | (** Deprecates functions that use wall-clock time, so that code must be explicit about 2 | what time source is used. 3 | 4 | Idiomatic usage is: 5 | 6 | {[ 7 | open! Require_explicit_time_source 8 | ]} 9 | 10 | or, in an import.ml: 11 | 12 | {[ 13 | include Require_explicit_time_source 14 | ]} *) 15 | 16 | include Require_explicit_time_source_intf.Require_explicit_time_source (** @open *) 17 | -------------------------------------------------------------------------------- /src/require_explicit_time_source_intf.ml: -------------------------------------------------------------------------------- 1 | (** Deprecates functions that use wall-clock time, so that code must be explicit about 2 | what time source is used. Idiomatic usage is: 3 | 4 | {[ 5 | open! Require_explicit_time_source 6 | ]} 7 | 8 | or, in an import.ml: 9 | 10 | {[ 11 | include Require_explicit_time_source 12 | ]} *) 13 | 14 | open! Core 15 | open! Import 16 | module From_kernel = Async_kernel_require_explicit_time_source 17 | 18 | module type Require_explicit_time_source = sig 19 | include module type of struct 20 | include From_kernel 21 | end 22 | 23 | module Scheduler : sig 24 | include module type of struct 25 | include Scheduler 26 | end 27 | 28 | val cycle_start : unit -> Time.t [@@deprecated "[since 2016-02] Use [Time_source]"] 29 | end 30 | 31 | module Date : sig 32 | include module type of struct 33 | include Core.Date 34 | end 35 | 36 | val today : zone:Time.Zone.t -> t [@@deprecated "[since 2019-05] Use [Time_source]"] 37 | end 38 | 39 | module Time_float : sig 40 | include module type of struct 41 | include Time_float_unix 42 | end 43 | 44 | module Ofday : sig 45 | include module type of struct 46 | include Ofday 47 | end 48 | 49 | val now : zone:Zone.t -> t [@@deprecated "[since 2019-05] Use [Time_source]"] 50 | end 51 | 52 | val now : unit -> t [@@deprecated "[since 2016-02] Use [Time_source]"] 53 | end 54 | 55 | module Time_float_unix = Time_float 56 | 57 | module Time : sig 58 | include module type of struct 59 | include Time_float_unix 60 | end 61 | 62 | module Ofday : sig 63 | include module type of struct 64 | include Ofday 65 | end 66 | 67 | val now : zone:Zone.t -> t [@@deprecated "[since 2019-05] Use [Time_source]"] 68 | end 69 | 70 | val now : unit -> t [@@deprecated "[since 2016-02] Use [Time_source]"] 71 | end 72 | [@@deprecated "[since 2022-04] Use [Time_float]"] 73 | 74 | module Time_ns : sig 75 | include module type of struct 76 | include Time_ns_unix 77 | end 78 | 79 | module Ofday : sig 80 | include module type of struct 81 | include Ofday 82 | end 83 | 84 | val now : zone:Time_float.Zone.t -> t 85 | [@@deprecated "[since 2019-05] Use [Time_source]"] 86 | end 87 | 88 | val now : unit -> t [@@deprecated "[since 2016-02] Use [Time_source]"] 89 | end 90 | 91 | module Time_ns_unix = Time_ns 92 | module Clock : Async_kernel.Clock_ns.Clock_deprecated with module Time := Time_float 93 | end 94 | -------------------------------------------------------------------------------- /src/scheduler.ml: -------------------------------------------------------------------------------- 1 | (* [Raw_scheduler] is distinct from [Scheduler], because the former exposes some things 2 | that are used internally within Async that are not exposed in scheduler.mli. 3 | Also, it breaks a cyclic dependency [Raw_scheduler -> Log -> Scheduler]. *) 4 | 5 | open! Core 6 | open! Import 7 | include Raw_scheduler 8 | 9 | let current_execution_context = Async_kernel_scheduler.current_execution_context 10 | 11 | let time_spent_waiting_for_io () = 12 | let t = t () in 13 | t.time_spent_waiting_for_io 14 | |> Tsc.Span.to_ns ~calibrator:(force Time_stamp_counter.calibrator) 15 | |> Time_ns.Span.of_int63_ns 16 | ;; 17 | 18 | let set_min_inter_cycle_timeout min_inter_cycle_timeout = 19 | let t = t () in 20 | if Time_ns.Span.( > ) 21 | min_inter_cycle_timeout 22 | (t.max_inter_cycle_timeout :> Time_ns.Span.t) 23 | then 24 | Error.raise 25 | ([%message 26 | "min_inter_cycle_timeout too large" 27 | (min_inter_cycle_timeout : Time_ns.Span.t) 28 | (t.max_inter_cycle_timeout : Max_inter_cycle_timeout.t)] 29 | |> [%of_sexp: Error.t]); 30 | t.min_inter_cycle_timeout <- Min_inter_cycle_timeout.create_exn min_inter_cycle_timeout 31 | ;; 32 | 33 | let max_num_open_file_descrs () = max_num_open_file_descrs (t ()) 34 | let fds_may_produce_events () = fds_may_produce_events (t ()) 35 | let thread_pool_has_unfinished_work () = thread_pool_has_unfinished_work (t ()) 36 | let has_pending_external_jobs () = has_pending_external_jobs (t ()) 37 | let max_num_threads () = max_num_threads (t ()) 38 | let _ = current_execution_context 39 | let is_running () = is_the_one_and_only_running () 40 | 41 | module For_tests = struct 42 | let warm_up_fds () = 43 | let () = Thread_safe.block_on_async_exn (fun () -> Deferred.return ()) in 44 | let (_ : Io_uring_raw.t option) = Io_uring_raw_singleton.the_one_and_only () in 45 | () 46 | ;; 47 | end 48 | 49 | module Expert = struct 50 | include Expert 51 | 52 | let lock () = Raw_scheduler.lock (t ()) 53 | let unlock () = Raw_scheduler.unlock (t ()) 54 | end 55 | -------------------------------------------------------------------------------- /src/select_file_descr_watcher.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | open File_descr_watcher_intf 4 | open Read_write_pair.Export 5 | module Table = Bounded_int_table 6 | 7 | type t = 8 | { descr_tables : (File_descr.t, unit) Table.t Read_write_pair.t 9 | ; handle_fd_read_ready : File_descr.t -> unit 10 | ; handle_fd_read_bad : File_descr.t -> unit 11 | ; handle_fd_write_ready : File_descr.t -> unit 12 | ; handle_fd_write_bad : File_descr.t -> unit 13 | } 14 | [@@deriving sexp_of] 15 | 16 | let backend = Config.File_descr_watcher.Select 17 | 18 | let invariant t : unit = 19 | try Read_write_pair.iter t.descr_tables ~f:(Table.invariant ignore ignore) with 20 | | exn -> 21 | raise_s 22 | [%message 23 | "Select_file_descr_watcher.invariant failed" 24 | (exn : exn) 25 | ~select_file_descr_watcher:(t : t)] 26 | ;; 27 | 28 | type 'a additional_create_args = 29 | handle_fd_read_bad:(File_descr.t -> unit) 30 | -> handle_fd_write_bad:(File_descr.t -> unit) 31 | -> 'a 32 | 33 | let create 34 | ~handle_fd_read_bad 35 | ~handle_fd_write_bad 36 | ~num_file_descrs 37 | ~handle_fd_read_ready 38 | ~handle_fd_write_ready 39 | = 40 | { descr_tables = 41 | Read_write_pair.create_fn (fun () -> 42 | Table.create 43 | ~num_keys:num_file_descrs 44 | ~key_to_int:File_descr.to_int 45 | ~sexp_of_key:File_descr.sexp_of_t 46 | ()) 47 | ; handle_fd_read_ready 48 | ; handle_fd_read_bad 49 | ; handle_fd_write_ready 50 | ; handle_fd_write_bad 51 | } 52 | ;; 53 | 54 | let reset_in_forked_process _ = () 55 | 56 | let iter t ~f = 57 | Read_write_pair.iteri t.descr_tables ~f:(fun read_or_write table -> 58 | Table.iteri table ~f:(fun ~key ~data:_ -> f key read_or_write)) 59 | ;; 60 | 61 | module Pre = struct 62 | type t = File_descr.t list Read_write_pair.t [@@deriving sexp_of] 63 | end 64 | 65 | let set t file_descr desired = 66 | Read_write_pair.iteri t.descr_tables ~f:(fun read_or_write table -> 67 | if Read_write_pair.get desired read_or_write 68 | then Table.set table ~key:file_descr ~data:() 69 | else Table.remove table file_descr); 70 | `Ok 71 | ;; 72 | 73 | let pre_check t = Read_write_pair.map t.descr_tables ~f:Table.keys 74 | 75 | module Check_result = struct 76 | type t = 77 | { pre : Pre.t 78 | ; select_result : (Unix.Select_fds.t, exn) Result.t 79 | } 80 | [@@deriving sexp_of] 81 | end 82 | 83 | let thread_safe_check (type a) (_ : t) (pre : Pre.t) (timeout : a Timeout.t) (span : a) = 84 | let timeout = 85 | match timeout with 86 | | Immediately -> `Immediately 87 | (* Wait no longer than one second, which avoids any weirdness due to feeding large 88 | timeouts to select. *) 89 | | After -> `After (Time_ns.Span.min span Time_ns.Span.second) 90 | in 91 | { Check_result.pre 92 | ; select_result = 93 | Result.try_with (fun () -> 94 | Unix.select ~read:pre.read ~write:pre.write ~except:[] ~timeout ()) 95 | } 96 | ;; 97 | 98 | let post_check t ({ Check_result.pre; select_result } as check_result) = 99 | try 100 | match select_result with 101 | (* We think 514 should be treated like EINTR. *) 102 | | Error (Unix.Unix_error ((EINTR | EUNKNOWNERR 514), _, _)) -> () 103 | | Ok { read; write; except } -> 104 | assert (List.is_empty except); 105 | List.iter write ~f:t.handle_fd_write_ready; 106 | List.iter read ~f:t.handle_fd_read_ready 107 | | Error (Unix.Unix_error (EBADF, _, _)) -> 108 | let bad read_or_write = 109 | let fds = 110 | match read_or_write with 111 | | `Read -> pre.read 112 | | `Write -> pre.write 113 | in 114 | List.fold fds ~init:[] ~f:(fun ac file_descr -> 115 | match 116 | Syscall.syscall (fun () -> ignore (Unix.fstat file_descr : Unix.stats)) 117 | with 118 | | Ok () -> ac 119 | | Error (Unix.Unix_error (EBADF, _, _)) -> file_descr :: ac 120 | | Error exn -> 121 | raise_s 122 | [%message 123 | "fstat raised unexpected exn" (file_descr : File_descr.t) (exn : exn)]) 124 | in 125 | List.iter (bad `Write) ~f:t.handle_fd_write_bad; 126 | List.iter (bad `Read) ~f:t.handle_fd_read_bad 127 | | Error exn -> raise_s [%message "select raised unexpected exn" ~_:(exn : exn)] 128 | with 129 | | exn -> 130 | raise_s 131 | [%message 132 | "File_descr_watcher.post_check bug" 133 | (exn : exn) 134 | (check_result : Check_result.t) 135 | ~select_file_descr_watcher:(t : t)] 136 | ;; 137 | -------------------------------------------------------------------------------- /src/select_file_descr_watcher.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | type 'a additional_create_args = 5 | handle_fd_read_bad:(File_descr.t -> unit) 6 | -> handle_fd_write_bad:(File_descr.t -> unit) 7 | -> 'a 8 | 9 | include 10 | File_descr_watcher_intf.S 11 | with type 'a additional_create_args := 'a additional_create_args 12 | -------------------------------------------------------------------------------- /src/shutdown.ml: -------------------------------------------------------------------------------- 1 | (* Unit tests are in ../../lib_test/shutdown_tests.ml *) 2 | 3 | open Core 4 | open Import 5 | module Signal = Core.Signal 6 | 7 | module Status_compatibility = struct 8 | type t = 9 | | Incompatible 10 | | Compatible_and_replace 11 | | Compatible_and_do_not_replace 12 | end 13 | 14 | module Status = struct 15 | type t = 16 | | Exit of int 17 | | Signal of Signal.t 18 | [@@deriving equal, sexp_of] 19 | 20 | let compatibility t ~prior : Status_compatibility.t = 21 | if equal t prior 22 | then Compatible_and_do_not_replace 23 | else ( 24 | match prior, t with 25 | | _, Exit 0 -> Compatible_and_do_not_replace 26 | | Exit 0, _ -> Compatible_and_replace 27 | | _, _ -> Incompatible) 28 | ;; 29 | end 30 | 31 | module Maybe_status = struct 32 | type t = 33 | | No 34 | | Yes of Status.t 35 | [@@deriving sexp_of] 36 | end 37 | 38 | let debug = Debug.shutdown 39 | let todo = ref [] 40 | 41 | let at_shutdown f = 42 | let backtrace = Backtrace.get () in 43 | if debug then Debug.log "at_shutdown" backtrace [%sexp_of: Backtrace.t]; 44 | todo := (backtrace, f) :: !todo 45 | ;; 46 | 47 | let shutting_down_ref = ref Maybe_status.No 48 | let default_force_ref = ref (fun () -> Clock.after (sec 10.)) 49 | let default_force () = !default_force_ref 50 | let set_default_force force = default_force_ref := force 51 | let shutting_down () = !shutting_down_ref 52 | 53 | let is_shutting_down () = 54 | match shutting_down () with 55 | | No -> false 56 | | Yes _ -> true 57 | ;; 58 | 59 | (* Be careful to ensure [shutdown] doesn't raise just because 60 | stderr is closed *) 61 | let ignore_exn f = 62 | try f () with 63 | | _ -> () 64 | ;; 65 | 66 | let exit_reliably status = 67 | match (status : Status.t) with 68 | | Exit code -> 69 | (match (exit code : Nothing.t) with 70 | | exception exn -> 71 | ignore_exn (fun () -> Core.Debug.eprints "Caml.exit raised" exn [%sexp_of: Exn.t]); 72 | Core_unix.exit_immediately (if code = 0 then 1 else code) 73 | | _ -> .) 74 | | Signal signal -> 75 | (match Stdlib.do_at_exit () with 76 | | exception exn -> 77 | ignore_exn (fun () -> Core.Debug.eprints "Caml.exit raised" exn [%sexp_of: Exn.t]) 78 | | () -> ()); 79 | Signal.Expert.set signal `Default; 80 | Signal_unix.send_exn signal (`Pid (Core_unix.getpid ())); 81 | ignore_exn (fun () -> 82 | Core.Debug.eprints 83 | "Signal_unix.send_exn failed to kill process" 84 | signal 85 | [%sexp_of: Signal.t]); 86 | Core_unix.exit_immediately 1 87 | ;; 88 | 89 | let shutdown_with_status ?force status = 90 | if debug then ignore_exn (fun () -> Debug.log "shutdown" status [%sexp_of: Status.t]); 91 | match !shutting_down_ref with 92 | | Yes prior -> 93 | (match Status.compatibility status ~prior with 94 | | Incompatible -> 95 | raise_s 96 | [%message 97 | "shutdown with inconsistent status" (status : Status.t) (prior : Status.t)] 98 | | Compatible_and_replace -> shutting_down_ref := Yes status 99 | | Compatible_and_do_not_replace -> ()) 100 | | No -> 101 | shutting_down_ref := Yes status; 102 | upon 103 | (Deferred.all 104 | (List.map !todo ~f:(fun (backtrace, f) -> 105 | let%map result = Monitor.try_with_or_error ~rest:`Log f in 106 | (match result with 107 | | Ok () -> () 108 | | Error error -> 109 | ignore_exn (fun () -> 110 | Core.Debug.eprints 111 | "at_shutdown function raised" 112 | (error, backtrace) 113 | [%sexp_of: Error.t * Backtrace.t])); 114 | if debug 115 | then 116 | ignore_exn (fun () -> 117 | Debug.log 118 | "one at_shutdown function finished" 119 | backtrace 120 | [%sexp_of: Backtrace.t]); 121 | result))) 122 | (fun results -> 123 | match shutting_down () with 124 | | No -> assert false 125 | | Yes status -> 126 | let status = 127 | match Or_error.combine_errors_unit results with 128 | | Ok () -> status 129 | | Error _ -> 130 | (match status with 131 | | Exit 0 -> Exit 1 132 | | _ -> status) 133 | in 134 | exit_reliably status); 135 | let force = 136 | match force with 137 | | None -> !default_force_ref () 138 | | Some f -> f 139 | in 140 | upon force (fun () -> 141 | ignore_exn (fun () -> Debug.log_string "Shutdown forced."); 142 | exit_reliably (Exit 1)) 143 | ;; 144 | 145 | let shutdown ?force exit_code = shutdown_with_status ?force (Exit exit_code) 146 | 147 | let shutdown_with_signal_exn ?force signal = 148 | match Signal.default_sys_behavior signal with 149 | | `Terminate | `Dump_core -> shutdown_with_status ?force (Signal signal) 150 | | (`Stop | `Continue | `Ignore) as default_sys_behavior -> 151 | raise_s 152 | [%message 153 | "Shutdown.shutdown_with_signal_exn: not a terminating signal" 154 | (signal : Signal.t) 155 | (default_sys_behavior : [ `Stop | `Continue | `Ignore ])] 156 | ;; 157 | 158 | let shutdown_on_unhandled_exn () = 159 | Monitor.detach_and_iter_errors Monitor.main ~f:(fun exn -> 160 | ignore_exn (fun () -> 161 | Debug.log "shutting down due to unhandled exception" exn [%sexp_of: exn]); 162 | try shutdown 1 with 163 | | _ -> 164 | (* The above [shutdown] call raises if we have already called shutdown with a 165 | different non-zero status. *) 166 | ()) 167 | ;; 168 | 169 | let exit ?force status = 170 | shutdown ?force status; 171 | Deferred.never () 172 | ;; 173 | 174 | let don't_finish_before = 175 | let proceed_with_shutdown = Ivar.create () in 176 | let num_waiting = ref 0 in 177 | let check () = if !num_waiting = 0 then Ivar.fill_exn proceed_with_shutdown () in 178 | at_shutdown (fun () -> 179 | check (); 180 | Ivar.read proceed_with_shutdown); 181 | fun d -> 182 | match shutting_down () with 183 | | Yes _ -> () 184 | | No -> 185 | incr num_waiting; 186 | upon d (fun () -> 187 | decr num_waiting; 188 | match shutting_down () with 189 | | No -> () 190 | | Yes _ -> check ()) 191 | ;; 192 | -------------------------------------------------------------------------------- /src/shutdown.mli: -------------------------------------------------------------------------------- 1 | (** For shutting down an Async program. *) 2 | 3 | open! Core 4 | open! Import 5 | module Signal := Core.Signal 6 | 7 | (** [shutdown ?force status] initiates shutdown, which runs all the [at_shutdown] 8 | functions, waits for them to finish, and then exits with the supplied status. The 9 | [at_shutdown] functions can block -- one can use [~force] to forcibly exit (with 10 | status 1) if the [at_shutdown] functions do not finish in a reasonable amount of time. 11 | 12 | By default, [force] is [after (sec 10.)]. 13 | 14 | Repeated calls to [shutdown] with the same status will have no effect. Any call to 15 | [shutdown] with nonzero status will cause that to be the status that is exited with. A 16 | call to [shutdown] with different nonzero status from the original call will raise. *) 17 | val shutdown : ?force:unit Deferred.t -> int -> unit 18 | 19 | (** Like [shutdown], except that the process dies with a signal instead of an error code. 20 | Raises unless [Signal.default_sys_behavior] of the signal is [`Terminate] or 21 | [`Dump_core]. Instead of exiting, the process restores the default behavior of the 22 | signal and sends the signal to itself. *) 23 | val shutdown_with_signal_exn : ?force:unit Deferred.t -> Signal.t -> unit 24 | 25 | (** [shutdown_on_unhandled_exn ()] arranges things so that whenever there is an 26 | asynchronous unhandled exception, an error message is printed to stderr and 27 | [shutdown 1] is called. This is useful when one wants to ensure that [at_shutdown] 28 | handlers run when there is an unhandled exception. Calling [shutdown_on_unhandled_exn] 29 | ensures that [Scheduler.go] will not raise due to an unhandled exception, and instead 30 | that the program will exit once [at_shutdown] handlers finish. *) 31 | val shutdown_on_unhandled_exn : unit -> unit 32 | 33 | (** [exit ?force status] is [shutdown ?force status; Deferred.never ()]. 34 | 35 | We do not have an exit function that returns a non-deferred: 36 | 37 | {[ 38 | val exit : ?force:unit Deferred.t -> int -> _ 39 | ]} 40 | 41 | Such a function should not exist, for the same reason that we do not have: 42 | 43 | {[ 44 | val block : 'a Deferred.t -> 'a 45 | ]} 46 | 47 | The semantics of such an exit function would allow one to block a running Async job, 48 | and to switch to another one (to run the [at_shutdown] handlers), without expressing 49 | that switch in the type system via a [Deferred.t]. That would eliminate all the nice 50 | reasoning guarantees that Async gives about concurrent jobs. *) 51 | val exit : ?force:unit Deferred.t -> int -> _ Deferred.t 52 | 53 | (** [default_force] returns the default [force] value used by [shutdown] and [exit]. *) 54 | val default_force : unit -> unit -> unit Deferred.t 55 | 56 | (** [set_default_force f] sets the default [force] value used by [shutdown] and [exit] to 57 | [f]. Initially, the default value is [fun () -> after (sec 10.)]. A subsequent call to 58 | [shutdown] or [exit] that doesn't supply [~force] will call [f] and will force 59 | shutdown when its result becomes determined. 60 | 61 | [set_default_force] has no effect if [shutdown] or [exit] has already been called, or 62 | if the next call to [shutdown] or [exit] supplies [~force]. 63 | 64 | [set_default_force] is useful for applications that call [shutdown] indirectly via a 65 | library, yet want to modify its behavior. *) 66 | val set_default_force : (unit -> unit Deferred.t) -> unit 67 | 68 | module Status : sig 69 | type t = 70 | | Exit of int 71 | | Signal of Signal.t 72 | [@@deriving sexp_of] 73 | end 74 | 75 | module Maybe_status : sig 76 | type t = 77 | | No 78 | | Yes of Status.t 79 | [@@deriving sexp_of] 80 | end 81 | 82 | (** [shutting_down ()] reports whether we are currently shutting down, and if so, with 83 | what status. *) 84 | val shutting_down : unit -> Maybe_status.t 85 | 86 | val is_shutting_down : unit -> bool 87 | 88 | (** [at_shutdown f] causes [f ()] to be run when [shutdown] is called, and for [shutdown] 89 | to wait until the returned deferred finishes. If [f] raises (synchronously or 90 | asynchronously), then the exception is printed to stderr and the program exits 91 | nonzero, irrespective of the status supplied to [shutdown]. 92 | 93 | If [shutdown] has already been called, then calling [at_shutdown f] does nothing. 94 | 95 | The functions supplied to [at_shutdown] are run in parallel on shutdown. *) 96 | val at_shutdown : (unit -> unit Deferred.t) -> unit 97 | 98 | (** [don't_finish_before d] causes [shutdown] to wait until [d] becomes determined before 99 | finishing. It is like [at_shutdown (fun _ -> d)], except it is more efficient, and 100 | will not take any space once [d] is determined. There is a single [at_shutdown] shared 101 | among all deferreds supplied to [don't_finish_before]. [don't_finish_before] does not 102 | override the [force] argument passed to shutdown. *) 103 | val don't_finish_before : unit Deferred.t -> unit 104 | -------------------------------------------------------------------------------- /src/signal.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | include Core.Signal 4 | 5 | let handle_default `Do_not_use_with_async = assert false 6 | let ignore `Do_not_use_with_async = assert false 7 | 8 | module Scheduler = Raw_scheduler 9 | 10 | let the_one_and_only = Scheduler.the_one_and_only 11 | 12 | let handle ?(ignore_signal_when_last_handler_removed = true) ?stop ts ~f = 13 | let scheduler = the_one_and_only () in 14 | let signal_manager = scheduler.signal_manager in 15 | Signal_manager.set_composable_handler 16 | signal_manager 17 | ~behavior_when_no_handlers: 18 | (if ignore_signal_when_last_handler_removed then No_op else Original_disposition) 19 | ts; 20 | let handler = 21 | Signal_manager.install_handler 22 | signal_manager 23 | ts 24 | (unstage (Scheduler.preserve_execution_context f)) 25 | in 26 | Option.iter stop ~f:(fun stop -> 27 | upon stop (fun () -> Signal_manager.remove_handler signal_manager handler)) 28 | ;; 29 | 30 | let terminating = [ alrm; hup; int; term; usr1; usr2 ] 31 | 32 | let manage_by_async ts = 33 | let scheduler = the_one_and_only () in 34 | let signal_manager = scheduler.signal_manager in 35 | List.iter ts ~f:(fun t -> 36 | Signal_manager.manage ~behavior_when_no_handlers:Original_disposition signal_manager t) 37 | ;; 38 | 39 | let is_managed_by_async t = 40 | let scheduler = the_one_and_only () in 41 | let signal_manager = scheduler.signal_manager in 42 | Signal_manager.is_managing signal_manager t 43 | ;; 44 | -------------------------------------------------------------------------------- /src/signal.mli: -------------------------------------------------------------------------------- 1 | (** Signal handling. *) 2 | 3 | open! Import 4 | 5 | (** To discourage use of the [Signal.Expert] module, we hide it here. People can use 6 | [Core.Signal.Expert] if they need. *) 7 | include 8 | module type of Core.Signal 9 | with type t = Core.Signal.t 10 | with module Expert := Core.Signal.Expert 11 | 12 | (** We override values from [Core.Signal] that we don't want people to use with Async. *) 13 | val handle_default : [ `Do_not_use_with_async ] -> _ 14 | 15 | val ignore : [ `Do_not_use_with_async ] -> _ 16 | 17 | (** [handle ?stop signals ~f] arranges so that whenever a signal in [signals] is 18 | delivered, [f] is called on that signal. If [f] raises, then an exception will be 19 | raised to the monitor in effect when [handle] was called. 20 | 21 | Multiple calls to [handle] with the same signal will cause all the handlers to run 22 | when that signal is delivered, not just the last handler from the last call to 23 | [handle]. 24 | 25 | The first time [handle] is called for a signal, it will install a C signal handler for 26 | it, replacing the existing C signal handler for that signal. 27 | 28 | If [stop] is passed, the Async signal handler will be uninstalled when [stop] 29 | resolves. 30 | 31 | If the last Async signal handler is removed, and at least one of the handlers got 32 | registered with [ignore_signal_when_last_handler_removed:true] (which is the default), 33 | then the signal will be ignored. If all handlers were registered with 34 | [ignore_signal_when_last_handler_removed:false], then the default signal behavior is 35 | simulated (as if [manage_by_async] was called and no handlers were registered). The 36 | underlying OCaml and C signal handlers are never uninstalled. 37 | 38 | Note that if a C signal handler was installed prior to the ocaml runtime installing a 39 | signal handler, it will be ignored. *) 40 | val handle 41 | : ?ignore_signal_when_last_handler_removed:bool 42 | -> ?stop:unit Deferred.t 43 | -> t list 44 | -> f:(t -> unit) 45 | -> unit 46 | 47 | (** [manage_by_async signal] arranges so that [signal] starts being managed by Async, i.e. 48 | we install an OCaml signal handler for it. The behavior of that handler approximates 49 | the default signal behavior with the difference that for signals whose default 50 | behavior is to terminate the program, we run on-shutdown handlers first. 51 | 52 | For terminating signals the exit status of the program will be indistinguishable from 53 | the signal not being handled. (see [Shutdown.shutdown_with_signal_exn]) 54 | 55 | If [handle] is called (before or after), that takes precedence: the shutdown on signal 56 | behavior is suppressed (even if the corresponding [stop] ivar is determined). *) 57 | val manage_by_async : t list -> unit 58 | 59 | (** [terminating] is a list of signals that can be supplied to [handle] and whose default 60 | behavior is to terminate the program: [alrm hup int term usr1 usr2]. 61 | 62 | Various signals whose [default_sys_behavior] is [`Terminate] are not included: 63 | 64 | {v 65 | | kill | it's not allowed to be handled | 66 | | pipe | Async already ignores this signal, since it handles EPIPE | 67 | | prof | so that we can profile things with -p | 68 | | vtalrm | it already has a handler | 69 | v} *) 70 | val terminating : t list 71 | 72 | (** [is_managed_by_async signal] returns true iff [signal] is being managed by Async, and 73 | hence its default behavior is no longer in effect. *) 74 | val is_managed_by_async : t -> bool 75 | -------------------------------------------------------------------------------- /src/signal_manager.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | module Signal = Core.Signal 3 | 4 | module Behavior_when_no_handlers = struct 5 | type t = 6 | | No_op 7 | | Original_disposition 8 | (** approximates the default behavior by calling [shutdown] on signals that normally 9 | cause the process to terminate *) 10 | [@@deriving sexp_of] 11 | end 12 | 13 | module Deliver_result = struct 14 | type t = 15 | | Delivered 16 | | Original_disposition 17 | end 18 | 19 | module Handlers = struct 20 | type t = 21 | { bag : ((Signal.t -> unit)[@sexp.opaque]) Bag.t 22 | ; mutable behavior_when_no_handlers : Behavior_when_no_handlers.t 23 | } 24 | [@@deriving sexp_of] 25 | 26 | let create () = 27 | { bag = Bag.create (); behavior_when_no_handlers = Original_disposition } 28 | ;; 29 | 30 | let add t handler = Bag.add t.bag handler 31 | let remove t handler_elt = Bag.remove t.bag handler_elt 32 | 33 | let deliver t signal : Deliver_result.t = 34 | if Bag.is_empty t.bag 35 | then ( 36 | match t.behavior_when_no_handlers with 37 | | No_op -> Delivered 38 | | Original_disposition -> Original_disposition) 39 | else ( 40 | Bag.iter t.bag ~f:(fun handler -> 41 | try handler signal with 42 | | exn -> raise_s [%message "signal handler unexpectedly raised" (exn : exn)]); 43 | Delivered) 44 | ;; 45 | end 46 | 47 | module Handler = struct 48 | type t = T of (Handlers.t * (Signal.t -> unit) Bag.Elt.t) list 49 | end 50 | 51 | type handler = Handler.t 52 | 53 | module type Signal_dispatcher = sig 54 | type t 55 | type handler 56 | 57 | val set_composable_handler 58 | : t 59 | -> behavior_when_no_handlers:Behavior_when_no_handlers.t 60 | -> Signal.t list 61 | -> unit 62 | 63 | val install_handler : t -> Signal.t list -> (Signal.t -> unit) -> handler 64 | val remove_handler : t -> handler -> unit 65 | end 66 | 67 | module Signal_dispatcher : sig 68 | type t [@@deriving sexp_of] 69 | 70 | include Signal_dispatcher with type t := t and type handler = handler 71 | 72 | val create : unit -> t 73 | val dispatch : t -> original_disposition:Signal.Expert.behavior -> Signal.t -> unit 74 | end = struct 75 | type t = { handlers_by_signal : Handlers.t Signal.Table.t } [@@deriving sexp_of] 76 | type nonrec handler = handler 77 | 78 | let create () = { handlers_by_signal = Signal.Table.create () } 79 | 80 | let get_handlers t signal = 81 | Hashtbl.find_or_add t.handlers_by_signal signal ~default:(fun () -> 82 | Handlers.create ()) 83 | ;; 84 | 85 | let set_composable_handler 86 | t 87 | ~(behavior_when_no_handlers : Behavior_when_no_handlers.t) 88 | signals 89 | = 90 | List.iter signals ~f:(fun signal -> 91 | let handlers = (get_handlers t signal : Handlers.t) in 92 | match behavior_when_no_handlers with 93 | | No_op -> handlers.behavior_when_no_handlers <- No_op 94 | | Original_disposition -> ()) 95 | ;; 96 | 97 | let install_handler t signals handler = 98 | Handler.T 99 | (List.map signals ~f:(fun signal -> 100 | let handlers = get_handlers t signal in 101 | handlers, Handlers.add handlers handler)) 102 | ;; 103 | 104 | let remove_handler _t (Handler.T handler) = 105 | List.iter handler ~f:(fun (handlers, handler_elt) -> 106 | Handlers.remove handlers handler_elt) 107 | ;; 108 | 109 | let default_signal_handler ~original_disposition signal = 110 | Async_kernel.Async_kernel_scheduler.schedule (fun () -> 111 | match original_disposition with 112 | | `Ignore -> () 113 | | `Handle f -> f signal 114 | | `Default -> 115 | (match Signal.default_sys_behavior signal with 116 | | `Terminate | `Dump_core -> Shutdown.shutdown_with_signal_exn signal 117 | | `Stop | `Continue | `Ignore -> ())) 118 | ;; 119 | 120 | let dispatch t ~original_disposition signal = 121 | match Hashtbl.find t.handlers_by_signal signal with 122 | | None -> default_signal_handler ~original_disposition signal 123 | | Some handlers -> 124 | (match Handlers.deliver handlers signal with 125 | | Delivered -> () 126 | | Original_disposition -> default_signal_handler ~original_disposition signal) 127 | ;; 128 | end 129 | 130 | type t = 131 | { raw_signal_manager : Raw_signal_manager.t [@globalized] 132 | ; signal_dispatcher : Signal_dispatcher.t [@globalized] 133 | } 134 | [@@deriving sexp_of] 135 | 136 | let invariant _ = () 137 | 138 | let create ~thread_safe_notify_signal_delivered = 139 | { raw_signal_manager = Raw_signal_manager.create ~thread_safe_notify_signal_delivered 140 | ; signal_dispatcher = Signal_dispatcher.create () 141 | } 142 | ;; 143 | 144 | let is_managing t signal = Raw_signal_manager.is_managing t.raw_signal_manager signal 145 | 146 | let set_composable_handler t ~behavior_when_no_handlers signals = 147 | List.iter signals ~f:(Raw_signal_manager.manage t.raw_signal_manager); 148 | Signal_dispatcher.set_composable_handler 149 | t.signal_dispatcher 150 | ~behavior_when_no_handlers 151 | signals 152 | ;; 153 | 154 | let manage t ~(behavior_when_no_handlers : Behavior_when_no_handlers.t) signal = 155 | set_composable_handler t ~behavior_when_no_handlers [ signal ] 156 | ;; 157 | 158 | let install_handler t signals f = 159 | List.iter signals ~f:(Raw_signal_manager.manage t.raw_signal_manager); 160 | Signal_dispatcher.install_handler t.signal_dispatcher signals f 161 | ;; 162 | 163 | let remove_handler t handler = 164 | Signal_dispatcher.remove_handler t.signal_dispatcher handler 165 | ;; 166 | 167 | let handle_delivered t = 168 | (* The local_ annotation is there to make sure the closure can't be allocated on the 169 | heap *) 170 | let () = 171 | Raw_signal_manager.iter_delivered 172 | t.raw_signal_manager 173 | ~f:(fun ~original_disposition signal -> 174 | Signal_dispatcher.dispatch ~original_disposition t.signal_dispatcher signal) 175 | in 176 | () 177 | ;; 178 | -------------------------------------------------------------------------------- /src/signal_manager.mli: -------------------------------------------------------------------------------- 1 | (** A signal manager keeps track of a set of signals to be managed and the signal handlers 2 | for them. When a signal manager is managing a signal, it installs its own OCaml 3 | handler for that signal that records delivery of the signal. It then later, upon 4 | request, will deliver the signal to all its handlers. 5 | 6 | Once a signal manager starts managing a signal, it never stops. *) 7 | 8 | open! Core 9 | module Signal := Core.Signal 10 | 11 | type t [@@deriving sexp_of] 12 | 13 | include Invariant.S with type t := t 14 | 15 | module Behavior_when_no_handlers : sig 16 | type t = 17 | | No_op 18 | | Original_disposition 19 | [@@deriving sexp_of] 20 | end 21 | 22 | (** Signal dispatcher controls what happens to the signals once they are seen by Async. *) 23 | module type Signal_dispatcher = sig 24 | type t 25 | type handler 26 | 27 | (** [set_composable_handler] causes [t] to manage the handling of [signals], and 28 | switches to custom signal handling mode for these signals, which suppresses the 29 | default behavior, and instead runs the handlers added by [install_handler]. 30 | 31 | This function is automatically called by [install_handler], so there's no need to 32 | call it directly. *) 33 | val set_composable_handler 34 | : t 35 | -> behavior_when_no_handlers:Behavior_when_no_handlers.t 36 | -> Signal.t list 37 | -> unit 38 | 39 | (** {v 40 | [install_handler t signals f] causes [t] to manage the handling of [signals], and 41 | registers [f] to run on every signal in [signals] that is delivered. It is an 42 | error if [f] ever raises when it is called. 43 | v} *) 44 | val install_handler : t -> Signal.t list -> (Signal.t -> unit) -> handler 45 | 46 | (** [remove_handler handler] causes the particular [handler] to no longer handle the 47 | signals it was registered to handle. The signal manager continues to manage those 48 | signals, i.e. the OCaml signal handler remains installed, whether or not they still 49 | have handlers. *) 50 | val remove_handler : t -> handler -> unit 51 | end 52 | 53 | (** [create] creates and returns a signal manager [t]. Whenever a signal that [t] is 54 | managing is delivered, it will call [thread_safe_notify_signal_delivered] from within 55 | the OCaml signal handler. Therefore [thread_safe_notify_signal_delivered] must be 56 | thread safe. *) 57 | val create : thread_safe_notify_signal_delivered:(unit -> unit) -> t 58 | 59 | (** [manage t signal] causes [t] to manage [signal], thus overriding 60 | [default_sys_behavior] for that signal, and any other OCaml handler for that signal. 61 | 62 | The behavior is then controlled by [behavior_when_no_handlers] by default, and the 63 | collection of handlers installed by [install_handler]/[remove_handler], if used. *) 64 | val manage 65 | : t 66 | -> behavior_when_no_handlers:Behavior_when_no_handlers.t 67 | -> Signal.t 68 | -> unit 69 | 70 | (** [is_managing t signal] returns true iff [manage t signal] has been called *) 71 | val is_managing : t -> Signal.t -> bool 72 | 73 | include Signal_dispatcher with type t := t 74 | 75 | (** [handle_delivered t] runs all signal handlers on the signals that have been delivered 76 | but not yet handled. *) 77 | val handle_delivered : t -> unit 78 | -------------------------------------------------------------------------------- /src/syscall.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | module Unix = Core_unix 4 | module Syscall_result = Unix.Syscall_result 5 | 6 | let max_tries = 1000 7 | 8 | exception Interrupted_too_many_times 9 | 10 | let syscall_exn = 11 | let rec loop f n = 12 | if n >= max_tries 13 | then raise Interrupted_too_many_times 14 | else ( 15 | try f () with 16 | | Unix.Unix_error (EINTR, _, _) -> loop f (n + 1)) 17 | in 18 | fun f -> loop f 0 19 | ;; 20 | 21 | let too_many_tries = 22 | Error.to_exn 23 | (Error.create "syscall interrupted too many times" max_tries [%sexp_of: int]) 24 | ;; 25 | 26 | let raise_too_many_tries () = 27 | raise_s [%sexp "syscall interrupted too many times", { max_tries : int }] 28 | ;; 29 | 30 | let too_many_tries_error = Error too_many_tries 31 | 32 | let syscall f = 33 | match syscall_exn f with 34 | | x -> Ok x 35 | | exception Interrupted_too_many_times -> too_many_tries_error 36 | | exception exn -> Error exn 37 | ;; 38 | 39 | let syscall_exn f = 40 | try syscall_exn f with 41 | | Interrupted_too_many_times -> raise_too_many_tries () 42 | ;; 43 | 44 | let is_eintr r = Syscall_result.is_error r && Syscall_result.error_exn r = EINTR 45 | 46 | let syscall_result = 47 | let rec loop a f n = 48 | if n >= max_tries 49 | then raise too_many_tries 50 | else ( 51 | let r = f a in 52 | if not (is_eintr r) then r else loop a f (n + 1)) 53 | in 54 | fun a f -> loop a f 0 55 | ;; 56 | 57 | let syscall_result2 = 58 | let rec loop a b f n = 59 | if n >= max_tries 60 | then raise too_many_tries 61 | else ( 62 | let r = f a b in 63 | if not (is_eintr r) then r else loop a b f (n + 1)) 64 | in 65 | fun a b f -> loop a b f 0 66 | ;; 67 | -------------------------------------------------------------------------------- /src/syscall.mli: -------------------------------------------------------------------------------- 1 | (** Automatically retrying system calls that may be interrupted with EINTR. *) 2 | 3 | open! Core 4 | open! Import 5 | module Syscall_result = Unix.Syscall_result 6 | 7 | (** [syscall f] repeatedly calls [f] until it returns or raises an exception that isn't 8 | [Unix_error (EINTR, _, _)]. *) 9 | val syscall : (unit -> 'a) -> ('a, exn) Result.t 10 | 11 | (** [syscall_exn f] is like [syscall f], but it raises an exception on failure *) 12 | val syscall_exn : (unit -> 'a) -> 'a 13 | 14 | (** [syscall_result a f] repeatedly calls [f a] until it returns a result that is not 15 | [Syscall_result.create_error EINTR]. *) 16 | val syscall_result : 'a -> ('a -> 'b Syscall_result.t) -> 'b Syscall_result.t 17 | 18 | val syscall_result2 : 'a -> 'b -> ('a -> 'b -> 'c Syscall_result.t) -> 'c Syscall_result.t 19 | -------------------------------------------------------------------------------- /src/thread_safe.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | open Raw_scheduler 4 | 5 | let debug = Debug.thread_safe 6 | 7 | let run_holding_async_lock 8 | (type a b) 9 | ?(wakeup_scheduler = true) 10 | t 11 | (f : unit -> a) 12 | ~(finish : (a, exn) Result.t -> b) 13 | : b 14 | = 15 | if debug then Debug.log "run_holding_async_lock" t [%sexp_of: t]; 16 | if not (am_holding_lock t) then lock t; 17 | protect 18 | ~finally:(fun () -> 19 | if wakeup_scheduler then thread_safe_wakeup_scheduler t; 20 | unlock t) 21 | ~f:(fun () -> 22 | (* We run [f] within the [main_execution_context] so that any errors are sent to its 23 | monitor, rather than whatever random monitor happened to be in effect. *) 24 | finish 25 | (with_execution_context t Kernel_scheduler.main_execution_context ~f:(fun () -> 26 | Result.try_with f))) 27 | ;; 28 | 29 | let ensure_in_a_thread t function_ = 30 | if am_holding_lock t 31 | then raise_s [%message "cannot call while holding the async lock" (function_ : string)] 32 | ;; 33 | 34 | let run_in_async_with_optional_cycle ?wakeup_scheduler t f = 35 | if debug then Debug.log "run_in_async_with_optional_cycle" t [%sexp_of: t]; 36 | ensure_in_a_thread t "run_in_async_with_optional_cycle"; 37 | run_holding_async_lock ?wakeup_scheduler t f ~finish:(function 38 | | Error exn -> Error exn 39 | | Ok (maybe_run_a_cycle, a) -> 40 | (match maybe_run_a_cycle with 41 | | `Do_not_run_a_cycle -> () 42 | | `Run_a_cycle -> have_lock_do_cycle t); 43 | Ok a) 44 | ;; 45 | 46 | let with_async_lock t f = 47 | if am_holding_lock t 48 | then f () 49 | else ( 50 | lock t; 51 | protect ~f ~finally:(fun () -> unlock t)) 52 | ;; 53 | 54 | let without_async_lock t f = 55 | if am_holding_lock t 56 | then ( 57 | unlock t; 58 | protect ~f ~finally:(fun () -> lock t)) 59 | else f () 60 | ;; 61 | 62 | let ensure_the_scheduler_is_started t = 63 | if not (is_running t) 64 | then ( 65 | let starting = 66 | (* Hold the lock when deciding if we're the first thread to start the scheduler. *) 67 | with_async_lock t (fun () -> 68 | if not (is_running t) 69 | then ( 70 | t.start_type <- Called_block_on_async; 71 | let scheduler_ran_a_job = Thread_safe_ivar.create () in 72 | upon (return ()) (fun () -> Thread_safe_ivar.fill scheduler_ran_a_job ()); 73 | `Yes scheduler_ran_a_job) 74 | else `No) 75 | in 76 | match starting with 77 | | `No -> () 78 | | `Yes scheduler_ran_a_job -> 79 | (* Release the Async lock if necessary, so that the scheduler can acquire it. *) 80 | without_async_lock t (fun () -> 81 | ignore 82 | (Core_thread.create 83 | ~on_uncaught_exn:`Print_to_stderr 84 | (fun () -> 85 | Exn.handle_uncaught ~exit:true (fun () -> 86 | let () = 87 | match Linux_ext.pr_set_name_first16 with 88 | | Ok f -> f "async-scheduler" 89 | | Error _ -> () 90 | in 91 | lock t; 92 | never_returns (be_the_scheduler t))) 93 | () 94 | : Core_thread.t); 95 | (* Block until the scheduler has run the above job. *) 96 | Thread_safe_ivar.read scheduler_ran_a_job)) 97 | ;; 98 | 99 | let block_on_async_not_holding_async_lock t f = 100 | (* Create a scheduler thread if the scheduler isn't already running. *) 101 | ensure_the_scheduler_is_started t; 102 | let maybe_blocked = 103 | run_holding_async_lock 104 | t 105 | (fun () -> Monitor.try_with ~run:`Schedule ~rest:`Log f ~name:"block_on_async") 106 | ~finish:(fun res -> 107 | match res with 108 | | Error exn -> `Available (Error exn) 109 | | Ok d -> 110 | (match Deferred.peek d with 111 | | Some v -> `Available v 112 | | None -> 113 | have_lock_do_cycle t; 114 | (match Deferred.peek d with 115 | | Some v -> `Available v 116 | | None -> 117 | let q = Squeue.create 1 in 118 | upon d (fun v -> Squeue.push_uncond q v); 119 | (* Squeue.pop can block, so we have to do it outside async *) 120 | `Blocked_wait_on_squeue q))) 121 | in 122 | match maybe_blocked with 123 | | `Available v -> v 124 | | `Blocked_wait_on_squeue q -> 125 | (* [run_holding_async_lock] released the lock. If the scheduler wasn't already 126 | running when [block_on_async] was called, then we started it above. So, the 127 | scheduler is running, and will eventually run the job to put something on the 128 | squeue. So, it's OK to block waiting for it. *) 129 | Squeue.pop q 130 | ;; 131 | 132 | let block_on_async t f = 133 | if debug then Debug.log "block_on_async" t [%sexp_of: t]; 134 | (* We disallow calling [block_on_async] if the caller is running inside async. This can 135 | happen if one is the scheduler, or if one is in some other thread that has used, e.g. 136 | [run_in_async] to call into async and run a cycle. We do however, want to allow the 137 | main thread to call [block_on_async], in which case it should release the lock and 138 | allow the scheduler, which is running in another thread, to run. *) 139 | if i_am_the_scheduler t || (am_holding_lock t && not (is_main_thread ())) 140 | then raise_s [%message "called [block_on_async] from within async"]; 141 | if not (am_holding_lock t) 142 | then block_on_async_not_holding_async_lock t f 143 | else ( 144 | let execution_context = 145 | Kernel_scheduler.current_execution_context t.kernel_scheduler 146 | in 147 | unlock t; 148 | let res = block_on_async_not_holding_async_lock t f in 149 | (* If we're the main thread, we should lock the scheduler for the rest of main, to 150 | prevent the scheduler, which is now running in another thread, from interfering 151 | with the main thread. We also restore the execution context, so that the code 152 | in the main thread will be in the same execution context as before it called 153 | [block_on_async]. The restored execution context will usually be 154 | [Execution_context.main], but need not be, if the user has done operations that 155 | adjust the current execution context, e.g. [Monitor.within]. *) 156 | lock t; 157 | Kernel_scheduler.set_execution_context t.kernel_scheduler execution_context; 158 | res) 159 | ;; 160 | 161 | let block_on_async_exn t f = Result.ok_exn (block_on_async t f) 162 | 163 | let run_in_async ?wakeup_scheduler t f = 164 | if debug then Debug.log "run_in_async" t [%sexp_of: t]; 165 | ensure_in_a_thread t "run_in_async"; 166 | run_holding_async_lock ?wakeup_scheduler t f ~finish:Fn.id 167 | ;; 168 | 169 | let run_in_async_exn ?wakeup_scheduler t f = 170 | Result.ok_exn (run_in_async ?wakeup_scheduler t f) 171 | ;; 172 | 173 | let run_in_async_wait t f = 174 | if debug then Debug.log "run_in_async_wait" t [%sexp_of: t]; 175 | ensure_in_a_thread t "run_in_async_wait"; 176 | block_on_async t f 177 | ;; 178 | 179 | let run_in_async_wait_exn t f = Result.ok_exn (run_in_async_wait t f) 180 | 181 | let deferred t = 182 | let ivar = 183 | if am_holding_lock t 184 | then Ivar.create () 185 | else run_holding_async_lock t Ivar.create ~finish:Result.ok_exn 186 | in 187 | let fill x = run_in_async_exn t (fun () -> Ivar.fill_exn ivar x) in 188 | Ivar.read ivar, fill 189 | ;; 190 | 191 | let t () = the_one_and_only () 192 | let am_holding_async_lock () = am_holding_lock (t ()) 193 | let deferred () = deferred (t ()) 194 | 195 | let run_in_async_with_optional_cycle ?wakeup_scheduler f = 196 | run_in_async_with_optional_cycle ?wakeup_scheduler (t ()) f 197 | ;; 198 | 199 | let run_in_async ?wakeup_scheduler f = run_in_async ?wakeup_scheduler (t ()) f 200 | let run_in_async_exn ?wakeup_scheduler f = run_in_async_exn ?wakeup_scheduler (t ()) f 201 | let block_on_async f = block_on_async (t ()) f 202 | let block_on_async_exn f = block_on_async_exn (t ()) f 203 | let run_in_async_wait f = run_in_async_wait (t ()) f 204 | let run_in_async_wait_exn f = run_in_async_wait_exn (t ()) f 205 | 206 | let ok_to_drop_lock t = 207 | is_main_thread () && not (Kernel_scheduler.in_cycle t.kernel_scheduler) 208 | ;; 209 | 210 | let without_async_lock_unchecked = without_async_lock 211 | 212 | let without_async_lock f = 213 | let t = t () in 214 | if i_am_the_scheduler t || (am_holding_lock t && not (ok_to_drop_lock t)) 215 | then 216 | raise_s 217 | [%sexp 218 | "called [become_helper_thread_and_block_on_async] from within async" 219 | , { i_am_the_scheduler = (i_am_the_scheduler t : bool) 220 | ; am_holding_lock = (am_holding_lock t : bool) 221 | ; ok_to_drop_lock = (ok_to_drop_lock t : bool) 222 | }] 223 | else without_async_lock t f 224 | ;; 225 | 226 | module For_tests = struct 227 | let without_async_lock_unchecked f = 228 | let t = t () in 229 | without_async_lock_unchecked t f 230 | ;; 231 | end 232 | -------------------------------------------------------------------------------- /src/thread_safe.mli: -------------------------------------------------------------------------------- 1 | (** The [Thread_safe] module has functions that are safe to call from threads outside 2 | Async, such as the ones spawned by [In_thread.run]. 3 | 4 | This is in contrast with the rest of [Async] library which is generally not 5 | thread-safe. 6 | 7 | All the [Thread_safe.block*] and [Thread_safe.run*] functions wake up the Async 8 | scheduler to ensure that it continues in a timely manner with whatever jobs got 9 | started. Some functions take an optional [?wakeup_scheduler:bool] argument, which 10 | defaults to [true]. One can cause the scheduler to not be woken up by supplying 11 | [~wakeup_scheduler:false], which can reduce CPU use, but increase latency, because the 12 | scheduler may not wake up for a while to process jobs. *) 13 | 14 | open! Core 15 | open Async_kernel 16 | 17 | (** [am_holding_async_lock ()] returns true if the currently running thread is holding the 18 | Async lock. *) 19 | val am_holding_async_lock : unit -> bool 20 | 21 | (** [deferred ()] returns [(d, fill)] where [d] is a deferred that will become determined 22 | with value [v] once [fill v] is called. 23 | 24 | It is ok to call [deferred] from inside or outside Async. [fill] must be called from 25 | outside Async. *) 26 | val deferred : unit -> 'a Deferred.t * ('a -> unit) 27 | 28 | (** [run_in_async_with_optional_cycle f] acquires the Async lock and runs [f ()] while 29 | holding the lock. Depending on the result of [f], it may also run a cycle. *) 30 | val run_in_async_with_optional_cycle 31 | : ?wakeup_scheduler:bool (** default is [true] *) 32 | -> (unit -> [ `Run_a_cycle | `Do_not_run_a_cycle ] * 'a) 33 | -> ('a, exn) Result.t 34 | 35 | (** [run_in_async f] acquires the Async lock and runs [f ()] while holding the lock. It 36 | returns the result of [f ()] to the outside world. The scheduler is woken up to ensure 37 | the code that depends on [f ()] is run soon enough. 38 | 39 | [run_in_async] doesn't run a cycle. 40 | 41 | [run_in_async] does not automatically start the Async scheduler. You still need to 42 | call [Scheduler.go] elsewhere in your program. *) 43 | val run_in_async 44 | : ?wakeup_scheduler:bool (** default is [true] *) 45 | -> (unit -> 'a) 46 | -> ('a, exn) Result.t 47 | 48 | val run_in_async_exn 49 | : ?wakeup_scheduler:bool (** default is [true] *) 50 | -> (unit -> 'a) 51 | -> 'a 52 | 53 | (** [block_on_async f] runs [f ()] in the Async world and blocks until the result becomes 54 | determined. This function can be called from the main thread (before Async is started) 55 | or from a thread outside Async. 56 | 57 | [block_on_async] will run a cycle if the deferred isn't determined, in the hope that 58 | running the cycle will cause the deferred to become determined. 59 | 60 | [block_on_async] will automatically start the scheduler if it isn't already running. *) 61 | val block_on_async : (unit -> 'a Deferred.t) -> ('a, exn) Result.t 62 | 63 | val block_on_async_exn : (unit -> 'a Deferred.t) -> 'a 64 | 65 | (** [run_in_async_wait f] is like [block_on_async f], except that it must be called from a 66 | thread that's not holding the Async lock. (there's no exception for the main thread) 67 | On return, the caller does not have the Async lock. *) 68 | val run_in_async_wait : (unit -> 'a Deferred.t) -> ('a, exn) Result.t 69 | 70 | val run_in_async_wait_exn : (unit -> 'a Deferred.t) -> 'a 71 | 72 | (** [without_async_lock f] can not be called from async, usually because [f] is expected 73 | to block. It's safe to call it in these two circumstances: 74 | - from a separate thread that's not holding the async lock 75 | - from the main thread, even if it is holding the async lock, as long as it's not 76 | running async jobs. In the latter case the async lock is dropped for the duration of 77 | [f]. *) 78 | val without_async_lock : (unit -> 'a) -> 'a 79 | 80 | module For_tests : sig 81 | (** Same as [without_async_lock], but without all those pesky checks. *) 82 | val without_async_lock_unchecked : (unit -> 'a) -> 'a 83 | end 84 | -------------------------------------------------------------------------------- /src/time_source_tests.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | module Time_source = Async_kernel.Time_source 4 | 5 | let run_cycles_until_no_jobs_remain = Kernel_scheduler.run_cycles_until_no_jobs_remain 6 | 7 | module%bench [@name "Clock.every"] _ = struct 8 | let scheduler = Kernel_scheduler.t () 9 | let time_source = scheduler.time_source |> Time_source.of_synchronous 10 | 11 | let%bench "~continue-on-error:false" = 12 | let iv = Ivar.create () in 13 | let n = ref 0 in 14 | Time_source.run_repeatedly 15 | time_source 16 | ~stop:(Ivar.read iv) 17 | ~continue_on_error:false 18 | ~f:(fun () -> 19 | if !n >= 1_000 then Ivar.fill_exn iv () else incr n; 20 | return ()) 21 | ~continue:Time_source.Continue.immediately; 22 | run_cycles_until_no_jobs_remain () 23 | ;; 24 | 25 | let%bench "~continue_on_error:true" = 26 | let iv = Ivar.create () in 27 | let n = ref 0 in 28 | Time_source.run_repeatedly 29 | time_source 30 | ~stop:(Ivar.read iv) 31 | ~continue_on_error:true 32 | ~f:(fun () -> 33 | if !n >= 1_000 then Ivar.fill_exn iv () else incr n; 34 | return ()) 35 | ~continue:Time_source.Continue.immediately; 36 | run_cycles_until_no_jobs_remain () 37 | ;; 38 | end 39 | -------------------------------------------------------------------------------- /src/time_source_tests.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /src/unused.ml: -------------------------------------------------------------------------------- 1 | module Filename_unix = Filename_unix 2 | -------------------------------------------------------------------------------- /src/writer.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | include Writer0 4 | module Unix = Unix_syscalls 5 | 6 | let of_pipe ?time_source info pipe_w = 7 | let%map `Reader reader_fd, `Writer writer_fd = Unix.pipe info in 8 | let reader = Reader.create reader_fd in 9 | let writer = create ?time_source writer_fd in 10 | if Debug.writer 11 | then 12 | Debug.log 13 | "Writer.of_pipe" 14 | (pipe_w, reader, writer) 15 | [%sexp_of: string Pipe.Writer.t * Reader.t * t]; 16 | (* Shuttle bytes from [reader] to [pipe_w]. If the user calls [close writer], 17 | then [reader] will see EOF, which will cause [transfer] to complete. If [pipe_w] 18 | is closed, then [transfer] will complete. *) 19 | let closed_and_flushed_downstream = 20 | let%bind () = Reader.transfer reader pipe_w in 21 | if raise_when_consumer_leaves writer && not (is_closed writer) 22 | then 23 | Monitor.send_exn 24 | (monitor writer) 25 | (Unix.Unix_error (EPIPE, "Writer.of_pipe", Sexp.to_string (Info.sexp_of_t info))); 26 | let%map (), () = Deferred.both (Reader.close reader) (close writer) in 27 | if not (Pipe.is_closed pipe_w) then Pipe.close pipe_w 28 | in 29 | writer, `Closed_and_flushed_downstream closed_and_flushed_downstream 30 | ;; 31 | 32 | let splice_result t ~from = 33 | match%map 34 | Reader.read_one_chunk_at_a_time from ~handle_chunk:(fun buffer ~pos ~len -> 35 | schedule_bigstring t ~pos ~len buffer; 36 | match%map flushed_or_failed_with_result t with 37 | | Flushed (_ : Time_ns.t) -> `Continue 38 | | Error -> `Stop `Error 39 | | Consumer_left | Force_closed -> `Stop `Consumer_left) 40 | with 41 | | `Eof_with_unconsumed_data (_ : string) -> assert false 42 | (* unreachable because [handle_chunk] only returns [`Stop|`Continue] *) 43 | | `Eof -> `Ok 44 | | `Stopped result -> result 45 | ;; 46 | 47 | let splice t ~from = splice_result t ~from |> Deferred.ignore_m 48 | -------------------------------------------------------------------------------- /src/writer.mli: -------------------------------------------------------------------------------- 1 | open! Import 2 | include Writer_intf.Writer 3 | 4 | (** [splice_result ~from t] moves all data from [from : Reader.t] to [t] one chunk at a 5 | time. The result becomes determined with value [`Ok] after reaching EOF on [from] and 6 | the final bytes have been transferred, and with values [`Consumer_left|`Error] in 7 | those cases where [flushed_or_failed_with_result] would return [Consumer_left|Error] 8 | respectively. 9 | 10 | The latter situation has the same race condition as [flushed_or_failed_with_result], 11 | so one should consider calling [set_raise_when_consumer_leaves t false] or at least 12 | ensure program correctness does not depend on which signal propagates first. *) 13 | val splice_result : t -> from:Reader.t -> [ `Ok | `Consumer_left | `Error ] Deferred.t 14 | 15 | (** [splice t ~from] is [splice_result t ~from |> Deferred.ignore_m] *) 16 | val splice : t -> from:Reader.t -> unit Deferred.t 17 | -------------------------------------------------------------------------------- /src/writer0.mli: -------------------------------------------------------------------------------- 1 | include Writer_intf.Writer0 2 | -------------------------------------------------------------------------------- /thread_pool/README.md: -------------------------------------------------------------------------------- 1 | # Thread_pool 2 | 3 | A thread pool is a set of OCaml threads used to do work, where each 4 | piece of work is simply a thunk. 5 | 6 | The `Async_unix` library uses `Thread_pool` to make blocking system 7 | calls. 8 | -------------------------------------------------------------------------------- /thread_pool/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name thread_pool) 3 | (public_name async_unix.thread_pool) 4 | (libraries core core_unix.core_thread core_unix.linux_ext 5 | core_unix.nano_mutex core_unix.squeue core_kernel.thread_pool_cpu_affinity 6 | thread_safe_ivar core_unix.time_ns_unix) 7 | (preprocess 8 | (pps ppx_jane))) 9 | -------------------------------------------------------------------------------- /thread_pool/src/import.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Time_ns = Time_ns_unix 3 | include Int.Replace_polymorphic_compare 4 | 5 | let sec = Time_ns.Span.of_sec 6 | -------------------------------------------------------------------------------- /thread_pool/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name thread_pool_test) 3 | (libraries async_kernel expect_test_helpers_core thread_pool 4 | thread_safe_ivar core core_unix.core_thread core_unix core_unix.linux_ext 5 | core_unix.nano_mutex core_unix.time_ns_unix) 6 | (preprocess 7 | (pps ppx_jane))) 8 | -------------------------------------------------------------------------------- /thread_pool/test/test_thread_pool.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /thread_pool/test/thread_pool_test.ml: -------------------------------------------------------------------------------- 1 | module Test_thread_pool = Test_thread_pool 2 | -------------------------------------------------------------------------------- /thread_safe_ivar/README.md: -------------------------------------------------------------------------------- 1 | # Thread_safe_ivar 2 | 3 | A simple thread-safe ivar implementation. 4 | -------------------------------------------------------------------------------- /thread_safe_ivar/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name thread_safe_ivar) 3 | (public_name async_unix.thread_safe_ivar) 4 | (libraries core core_unix.error_checking_mutex) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /thread_safe_ivar/src/import.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | include Int.Replace_polymorphic_compare 3 | -------------------------------------------------------------------------------- /thread_safe_ivar/src/thread_safe_ivar.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | module Mutex = Error_checking_mutex 4 | 5 | type 'a t = 6 | { mutable value : 'a option 7 | ; mutable num_waiting : int 8 | ; mutex : 9 | (Mutex.t 10 | [@sexp.opaque] 11 | (* Threads that do [read t] when [is_none t.value] block using [Condition.wait t.full]. 12 | When [fill] sets [t.value], it uses [Condition.broadcast] to wake up all the blocked 13 | threads. *)) 14 | ; full : (Condition.t[@sexp.opaque]) 15 | } 16 | [@@deriving sexp_of] 17 | 18 | let create () = 19 | { value = None; num_waiting = 0; mutex = Mutex.create (); full = Condition.create () } 20 | ;; 21 | 22 | let critical_section t ~f = Mutex.critical_section t.mutex ~f 23 | 24 | let fill t v = 25 | critical_section t ~f:(fun () -> 26 | if is_some t.value then raise_s [%message "Thread_safe_ivar.fill of full ivar"]; 27 | t.value <- Some v; 28 | Condition.broadcast t.full) 29 | ;; 30 | 31 | let read t = 32 | match t.value with 33 | | Some v -> v 34 | | None -> 35 | critical_section t ~f:(fun () -> 36 | let rec loop () = 37 | match t.value with 38 | | Some v -> v 39 | | None -> 40 | t.num_waiting <- t.num_waiting + 1; 41 | Condition.wait t.full t.mutex; 42 | t.num_waiting <- t.num_waiting - 1; 43 | (match t.value with 44 | | Some v -> v 45 | | None -> loop ()) 46 | in 47 | loop () [@nontail]) 48 | [@nontail] 49 | ;; 50 | 51 | let peek t = t.value 52 | -------------------------------------------------------------------------------- /thread_safe_ivar/src/thread_safe_ivar.mli: -------------------------------------------------------------------------------- 1 | (** A simple thread-safe ivar implementation. *) 2 | 3 | open! Core 4 | open! Import 5 | 6 | type 'a t [@@deriving sexp_of] 7 | 8 | val create : unit -> _ t 9 | val fill : 'a t -> 'a -> unit 10 | 11 | (** [read t] blocks until [t] is filled. *) 12 | val read : 'a t -> 'a 13 | 14 | val peek : 'a t -> 'a option 15 | -------------------------------------------------------------------------------- /thread_safe_ivar/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name thread_safe_ivar_tests) 3 | (libraries core_kernel.caml_threads core_kernel.caml_unix thread_safe_ivar 4 | threads unix) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /thread_safe_ivar/test/spurious_wakeup.ml: -------------------------------------------------------------------------------- 1 | let%test_unit "spurious wakeups" = 2 | (* Arrange for an almost-guaranteed spurious wakeup by making the thread that waits on 3 | the ivar also responsible for handling the signal. 4 | 5 | There's still a small race here: if the signal is delivered before 6 | [Thread_safe_ivar.read] has a chance to run, then the signal will be processed 7 | without causing a spurious Condition.wait wakeup. Hence the tiny sleep to make 8 | that unlikely. 9 | 10 | There's another race where the signal handler can get scheduled to run in such a way 11 | that it doesn't wake up the [futex] call, but happens after the thread [t] checks for 12 | pending signals, so it never gets run. To resolve that, just send the signal in a 13 | loop until it works. 14 | *) 15 | let signal_handled = Thread_safe_ivar.create () in 16 | let main_ivar = Thread_safe_ivar.create () in 17 | let t = Caml_threads.Thread.create (fun () -> Thread_safe_ivar.read main_ivar) () in 18 | let _prev = 19 | (Sys.signal [@ocaml.alert "-unsafe_multidomain"]) 20 | Sys.sigint 21 | (Sys.Signal_handle 22 | (fun _s -> 23 | assert (Thread.self () == t); 24 | match Thread_safe_ivar.peek signal_handled with 25 | | None -> Thread_safe_ivar.fill signal_handled () 26 | | Some () -> ())) 27 | in 28 | let _previously_blocked = Caml_unix.sigprocmask SIG_BLOCK [ Sys.sigint ] in 29 | let rec signal_until_signal_handled () = 30 | match Thread_safe_ivar.peek signal_handled with 31 | | Some () -> () 32 | | None -> 33 | UnixLabels.kill ~pid:(Caml_unix.getpid ()) ~signal:Sys.sigint; 34 | Unix.sleepf 1.0; 35 | signal_until_signal_handled () 36 | in 37 | (* This sleep is to let the thread [t] get blocked on [Thread_safe_ivar.read], 38 | so there's something to wake up. *) 39 | Unix.sleepf 0.001; 40 | signal_until_signal_handled (); 41 | (* This sleep is to make sure that the wakeup is indeed spurious. 42 | (not sure it's necessary in practice, but seems necessary in theory) *) 43 | Unix.sleepf 0.001; 44 | Thread_safe_ivar.fill main_ivar (); 45 | Caml_threads.Thread.join t 46 | ;; 47 | -------------------------------------------------------------------------------- /thread_safe_ivar/test/spurious_wakeup.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/async_unix/0c4c69ba0cfa2249c9c58900c6586eb7219ee981/thread_safe_ivar/test/spurious_wakeup.mli -------------------------------------------------------------------------------- /thread_safe_ivar/test/thread_safe_ivar_tests.ml: -------------------------------------------------------------------------------- 1 | module Spurious_wakeup = Spurious_wakeup 2 | -------------------------------------------------------------------------------- /thread_safe_pipe/README.md: -------------------------------------------------------------------------------- 1 | # Thread_safe_pipe 2 | 3 | A thread-safe pipe is a thread-safe interface to the write end of a normal 4 | `Async.Pipe`. 5 | -------------------------------------------------------------------------------- /thread_safe_pipe/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name thread_safe_pipe) 3 | (public_name async_unix.thread_safe_pipe) 4 | (libraries async_kernel async_unix core) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /thread_safe_pipe/src/import.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | include Int.Replace_polymorphic_compare 3 | -------------------------------------------------------------------------------- /thread_safe_pipe/src/thread_safe_pipe.ml: -------------------------------------------------------------------------------- 1 | (* Unit tests are in ../../lib_test/thread_safe_test.ml. *) 2 | 3 | open! Core 4 | open! Async_kernel 5 | open! Async_unix 6 | open! Import 7 | 8 | type 'a t = 'a Pipe.Writer.t [@@deriving sexp_of] 9 | 10 | let in_async ?wakeup_scheduler f = Thread_safe.run_in_async_exn ?wakeup_scheduler f 11 | let in_async_wait f = Thread_safe.run_in_async_wait_exn f 12 | 13 | module Written_or_closed = struct 14 | type t = 15 | | Written 16 | | Closed 17 | end 18 | 19 | module If_closed = struct 20 | type 'a t = 21 | | Raise : unit t 22 | | Return : Written_or_closed.t t 23 | 24 | let closed : type a. a t -> a = function 25 | | Raise -> raise_s [%message "pipe is closed"] 26 | | Return -> Closed 27 | ;; 28 | 29 | let written : type a. a t -> a = function 30 | | Raise -> () 31 | | Return -> Written 32 | ;; 33 | end 34 | 35 | let in_async_unless_closed ?wakeup_scheduler t f ~if_closed = 36 | in_async ?wakeup_scheduler (fun () -> 37 | if Pipe.is_closed t 38 | then If_closed.closed if_closed 39 | else ( 40 | f (); 41 | If_closed.written if_closed)) 42 | ;; 43 | 44 | let in_async_unless_closed_wait t f ~if_closed = 45 | in_async_wait (fun () -> 46 | if Pipe.is_closed t 47 | then return (If_closed.closed if_closed) 48 | else ( 49 | let%map () = f () in 50 | If_closed.written if_closed)) 51 | ;; 52 | 53 | let create () = 54 | if Thread_safe.am_holding_async_lock () then Pipe.create () else in_async Pipe.create 55 | ;; 56 | 57 | let pushback t = in_async_wait (fun () -> Pipe.pushback t) 58 | 59 | let transfer_in t ~from ~if_closed = 60 | in_async_unless_closed_wait t ~if_closed (fun () -> Pipe.transfer_in t ~from) 61 | ;; 62 | 63 | let write t a ~if_closed = 64 | in_async_unless_closed_wait t ~if_closed (fun () -> Pipe.write t a) 65 | ;; 66 | 67 | let transfer_in_without_pushback ?wakeup_scheduler t ~from ~if_closed = 68 | in_async_unless_closed ?wakeup_scheduler t ~if_closed (fun () -> 69 | Pipe.transfer_in_without_pushback t ~from) 70 | ;; 71 | 72 | let write_without_pushback ?wakeup_scheduler t a ~if_closed = 73 | in_async_unless_closed ?wakeup_scheduler t ~if_closed (fun () -> 74 | Pipe.write_without_pushback t a) 75 | ;; 76 | 77 | let close t = in_async (fun () -> Pipe.close t) 78 | let is_closed t = in_async (fun () -> Pipe.is_closed t) 79 | let closed t = in_async_wait (fun () -> Pipe.closed t) 80 | -------------------------------------------------------------------------------- /thread_safe_pipe/src/thread_safe_pipe.mli: -------------------------------------------------------------------------------- 1 | (** A thread-safe pipe is a thread-safe interface to the write end of a normal 2 | [Async.Pipe]. 3 | {b All operations except for [create] must be called from threads outside Async}, 4 | while [create] can be called from inside or outside Async. 5 | 6 | For [Pipe] functions that return a [unit Deferred.t], the analog in [Thread_safe_pipe] 7 | blocks. 8 | 9 | For documentation of [wakeup_scheduler], see the {!Thread_safe} module. *) 10 | 11 | open! Core 12 | open! Async_kernel 13 | open! Import 14 | 15 | (** The writer end of the pipe. *) 16 | type 'a t [@@deriving sexp_of] 17 | 18 | (** [create ()] returns a reader end, which must be used inside Async, and a writer end, 19 | which must be used outside Async. [create] can be called inside or outside Async. *) 20 | val create : unit -> 'a Pipe.Reader.t * 'a t 21 | 22 | (** All the following functions must be called outside Async. They behave as their 23 | counterpart in the {!Pipe} module. *) 24 | 25 | (** [pushback writer] blocks the current thread until the pipe is empty or closed. *) 26 | val pushback : _ t -> unit 27 | 28 | module Written_or_closed : sig 29 | type t = 30 | | Written 31 | | Closed 32 | end 33 | 34 | (** Functions that write elements to the pipe take an [If_closed.t] argument to specify 35 | how to deal with the possibility that the pipe is closed. 36 | 37 | The alternatives are to [Raise] on a closed pipe, or [Return] a variant indicating 38 | whether the pipe is closed. This allows lightweight syntax for calls that want to 39 | raise if the pipe is closed: 40 | 41 | {[ 42 | write t a ~if_closed:Raise 43 | ]} 44 | 45 | It also allows lightweight syntax for calls that want to match on whether the pipe was 46 | closed: 47 | 48 | {[ 49 | match write t a ~if_closed:Return with 50 | | Closed -> ... 51 | | Written -> ... 52 | ]} 53 | 54 | Returning a variant is essential when one wants to distinguish a closed pipe from 55 | other errors. Also, since pipe-writing functions acquire the Async lock, it would be 56 | incorrect (due to races) to check [is_closed] prior to the lock acquisition. *) 57 | module If_closed : sig 58 | type 'a t = 59 | | Raise : unit t 60 | | Return : Written_or_closed.t t 61 | end 62 | 63 | (** [transfer_in_without_pushback'] and [write_without_pushback] transfer the element(s) 64 | into the pipe and return immediately. *) 65 | val transfer_in_without_pushback 66 | : ?wakeup_scheduler:bool (** default is [true] *) 67 | -> 'a t 68 | -> from:'a Queue.t 69 | -> if_closed:'b If_closed.t 70 | -> 'b 71 | 72 | val write_without_pushback 73 | : ?wakeup_scheduler:bool (** default is [true] *) 74 | -> 'a t 75 | -> 'a 76 | -> if_closed:'b If_closed.t 77 | -> 'b 78 | 79 | (** [transfer_in] and [write] transfer the element(s) into the pipe and block the current 80 | thread until the pipe is empty or closed (like {!pushback}). *) 81 | val transfer_in : 'a t -> from:'a Queue.t -> if_closed:'b If_closed.t -> 'b 82 | 83 | val write : 'a t -> 'a -> if_closed:'b If_closed.t -> 'b 84 | val close : _ t -> unit 85 | val is_closed : _ t -> bool 86 | 87 | (** [closed writer] blocks the current thread until the pipe is closed. *) 88 | val closed : _ t -> unit 89 | -------------------------------------------------------------------------------- /thread_safe_pipe/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name thread_safe_pipe_test) 3 | (libraries async core thread_safe_pipe) 4 | (preprocess 5 | (pps ppx_jane))) 6 | -------------------------------------------------------------------------------- /thread_safe_pipe/test/test_thread_safe_pipe.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Poly 3 | open! Async 4 | open! Thread_safe_pipe 5 | 6 | let%expect_test "Thread_safe_pipe" = 7 | let module P = Thread_safe_pipe in 8 | let r, p = P.create () in 9 | assert ( 10 | try 11 | P.write p 13 ~if_closed:Raise; 12 | false 13 | with 14 | | _ -> true); 15 | let throttle = Throttle.create ~continue_on_error:false ~max_concurrent_jobs:1 in 16 | let run_in_thread f = 17 | don't_wait_for (Throttle.enqueue throttle (fun () -> In_thread.run f)) 18 | in 19 | let num_elts = 100 in 20 | for i = 0 to num_elts - 1 do 21 | run_in_thread (fun () -> P.write p i ~if_closed:Raise) 22 | done; 23 | run_in_thread (fun () -> P.close p); 24 | Pipe.to_list r >>| fun list -> assert (list = List.init num_elts ~f:Fn.id) 25 | ;; 26 | 27 | let%expect_test "Thread_safe_pipe2" = 28 | In_thread.run (fun () -> Thread_safe_pipe.create ()) 29 | >>= fun (pipe_reader, pipe_writer) -> 30 | assert ( 31 | (* [write] raises if we're in Async. *) 32 | try 33 | Thread_safe_pipe.write pipe_writer 13 ~if_closed:Raise; 34 | false 35 | with 36 | | _ -> true); 37 | let throttle = Throttle.create ~continue_on_error:false ~max_concurrent_jobs:1 in 38 | let run_in_thread f = 39 | don't_wait_for (Throttle.enqueue throttle (fun () -> In_thread.run f)) 40 | in 41 | let num_elts = 100 in 42 | for i = 0 to num_elts - 1 do 43 | run_in_thread (fun () -> 44 | Thread_safe_pipe.write_without_pushback pipe_writer i ~if_closed:Raise) 45 | done; 46 | run_in_thread (fun () -> Thread_safe_pipe.close pipe_writer); 47 | Pipe.to_list pipe_reader >>| fun list -> assert (list = List.init num_elts ~f:Fn.id) 48 | ;; 49 | -------------------------------------------------------------------------------- /thread_safe_pipe/test/test_thread_safe_pipe.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /thread_safe_pipe/test/thread_safe_pipe_test.ml: -------------------------------------------------------------------------------- 1 | module Test_thread_safe_pipe = Test_thread_safe_pipe 2 | --------------------------------------------------------------------------------