├── weak_hashtbl_async ├── src │ ├── import.ml │ ├── jbuild │ ├── weak_hashtbl_async.mli │ └── weak_hashtbl_async.ml ├── test │ ├── import.ml │ ├── test_weak_hashtbl.mli │ ├── jbuild │ └── test_weak_hashtbl.ml └── README.md ├── .gitignore ├── src ├── job_or_event.mli ├── timing_wheel_ns.ml ├── async_invariant.mli ├── time_source.mli ├── persistent_connection.mli ├── deferred_list.mli ├── deferred_array.mli ├── deferred_option.mli ├── deferred_sequence.mli ├── eager_deferred.ml ├── external_job.ml ├── job.ml ├── job.mli ├── priority.ml ├── synchronous_time_source.ml ├── external_job.mli ├── priority.mli ├── jbuild ├── deferred_std.ml ├── job_pool.mli ├── clock_ns.mli ├── require_explicit_time_source.ml ├── deferred_queue.mli ├── async_quickcheck.mli ├── debug.mli ├── deferred.ml ├── scheduler0.ml ├── async_quickcheck_intf.ml ├── ivar.ml ├── debug.ml ├── async_condition.ml ├── deferred_result.mli ├── ivar_filler.mli ├── deferred_option.ml ├── job_pool.ml ├── job_queue.mli ├── time_ns.ml ├── deferred_memo.ml ├── async_condition.mli ├── execution_context.mli ├── deferred0.mli ├── ivar_filler.ml ├── deferred_result.ml ├── async_invariant.ml ├── eager_deferred_result.ml ├── async_gc.ml ├── async_quickcheck.ml ├── deferred_memo.mli ├── import.ml ├── job_or_event_intf.ml ├── tail.mli ├── execution_context.ml ├── lazy_deferred.ml ├── bvar.mli ├── tail.ml ├── eager_deferred_or_error.mli ├── bvar.ml ├── job_or_event.ml ├── require_explicit_time_source.mli ├── ivar0.mli ├── ivar.mli ├── clock_ns.ml ├── eager_deferred.mli ├── deferred_queue.ml ├── monitor0.ml ├── deferred0.ml ├── async_invariant_intf.ml ├── monad_sequence.ml ├── lazy_deferred.mli ├── deferred_map.ml ├── deferred_list.ml ├── deferred_array.ml ├── async_gc.mli ├── mvar.ml ├── async_kernel_config.mli ├── deferred_map.mli ├── mvar.mli ├── scheduler.mli ├── deferred_or_error.mli ├── async_kernel.ml ├── persistent_connection_intf.ml ├── deferred_sequence.ml ├── eager_deferred0.ml ├── synchronous_time_source.mli ├── deferred_or_error.ml ├── eager_deferred_or_error.ml ├── throttle.mli ├── deferred1.ml ├── job_queue.ml ├── async_stream.ml ├── types.ml ├── deferred.mli ├── persistent_connection.ml └── async_stream.mli ├── limiter_async ├── test │ ├── test_limiter_async.mli │ └── jbuild └── src │ ├── jbuild │ └── limiter_async.mli ├── Makefile ├── README.md ├── async_kernel.opam ├── LICENSE.md └── CONTRIBUTING.md /weak_hashtbl_async/src/import.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /weak_hashtbl_async/test/import.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | 5 | -------------------------------------------------------------------------------- /src/job_or_event.mli: -------------------------------------------------------------------------------- 1 | include Job_or_event_intf.Job_or_event 2 | -------------------------------------------------------------------------------- /src/timing_wheel_ns.ml: -------------------------------------------------------------------------------- 1 | include Core_kernel.Timing_wheel_ns 2 | -------------------------------------------------------------------------------- /src/async_invariant.mli: -------------------------------------------------------------------------------- 1 | include Async_invariant_intf.Async_invariant 2 | -------------------------------------------------------------------------------- /src/time_source.mli: -------------------------------------------------------------------------------- 1 | include Time_source_intf.Time_source (** @inline *) 2 | -------------------------------------------------------------------------------- /src/persistent_connection.mli: -------------------------------------------------------------------------------- 1 | include Persistent_connection_intf.Persistent_connection 2 | -------------------------------------------------------------------------------- /limiter_async/test/test_limiter_async.mli: -------------------------------------------------------------------------------- 1 | (*_ this interface is deliberately empty *) 2 | 3 | -------------------------------------------------------------------------------- /weak_hashtbl_async/test/test_weak_hashtbl.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /src/deferred_list.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | 3 | include Deferred1.Monad_sequence with type 'a t := 'a list 4 | -------------------------------------------------------------------------------- /src/deferred_array.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | 3 | include Deferred1.Monad_sequence with type 'a t := 'a array (** @inline *) 4 | -------------------------------------------------------------------------------- /src/deferred_option.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | 3 | include Monad.S with type 'a t = 'a option Deferred0.t (** @inline *) 4 | -------------------------------------------------------------------------------- /src/deferred_sequence.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | 3 | include Deferred1.Monad_sequence with type 'a t := 'a Sequence.t (** @inline *) 4 | -------------------------------------------------------------------------------- /src/eager_deferred.ml: -------------------------------------------------------------------------------- 1 | include Eager_deferred0 2 | module Result = Eager_deferred_result 3 | module Or_error = Eager_deferred_or_error 4 | -------------------------------------------------------------------------------- /src/external_job.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | include Types.External_job 5 | 6 | let sexp_of_t _ = Sexp.Atom "" 7 | -------------------------------------------------------------------------------- /src/job.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | type t = Job_pool.slots Pool.Pointer.t [@@deriving sexp_of] 5 | 6 | let invariant _ = () 7 | -------------------------------------------------------------------------------- /src/job.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | type t = Types.Job.t [@@deriving sexp_of] 5 | 6 | include Invariant.S with type t := t 7 | -------------------------------------------------------------------------------- /src/priority.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | type t = Normal | Low [@@deriving sexp_of] 5 | 6 | let normal = Normal 7 | let low = Low 8 | -------------------------------------------------------------------------------- /src/synchronous_time_source.ml: -------------------------------------------------------------------------------- 1 | include Synchronous_time_source0 2 | 3 | let create = Scheduler1.create_time_source 4 | let wall_clock = Scheduler1.wall_clock 5 | -------------------------------------------------------------------------------- /src/external_job.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | type t = Types.External_job.t = T : Execution_context.t * ('a -> unit) * 'a -> t 5 | [@@deriving sexp_of] 6 | -------------------------------------------------------------------------------- /weak_hashtbl_async/README.md: -------------------------------------------------------------------------------- 1 | # Weak_hashtbl_async 2 | 3 | A single-module library that extends the `Weak_hashtbl` single-module 4 | library to automatically collect unused keys. 5 | -------------------------------------------------------------------------------- /src/priority.mli: -------------------------------------------------------------------------------- 1 | (** The priority of a job. *) 2 | 3 | open! Core_kernel 4 | open! Import 5 | 6 | type t = Normal | Low [@@deriving sexp_of] 7 | 8 | val normal : t 9 | val low : t 10 | -------------------------------------------------------------------------------- /limiter_async/test/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name limiter_async_test) 3 | (libraries (expect_test_helpers 4 | limiter_async)) 5 | (preprocess (pps (ppx_jane ppxlib.runner))))) 6 | 7 | (jbuild_version 1) 8 | -------------------------------------------------------------------------------- /weak_hashtbl_async/test/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name weak_hashtbl_async_test) 3 | (libraries (async 4 | weak_hashtbl_async)) 5 | (preprocess (pps (ppx_jane ppxlib.runner))))) 6 | 7 | (jbuild_version 1) 8 | -------------------------------------------------------------------------------- /src/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name async_kernel) 3 | (public_name async_kernel) 4 | (libraries (core_kernel)) 5 | (preprocess (pps (ppx_jane -annotated-ignores -check-doc-comments ppxlib.runner))) 6 | )) 7 | 8 | 9 | (jbuild_version 1) 10 | -------------------------------------------------------------------------------- /weak_hashtbl_async/src/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name weak_hashtbl_async) 3 | (public_name async_kernel.weak_hashtbl_async) 4 | (libraries (async_kernel 5 | core_kernel.weak_hashtbl)) 6 | (preprocess (pps (ppx_jane ppxlib.runner))))) 7 | 8 | (jbuild_version 1) 9 | -------------------------------------------------------------------------------- /src/deferred_std.ml: -------------------------------------------------------------------------------- 1 | open Deferred1 2 | 3 | include Infix 4 | include Let_syntax 5 | 6 | let choice = choice 7 | let choose = choose 8 | let don't_wait_for = don't_wait_for 9 | let never = never 10 | let return = return 11 | let upon = upon 12 | -------------------------------------------------------------------------------- /src/job_pool.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | type slots = (Execution_context.t, Obj.t -> unit, Obj.t) Pool.Slots.t3 [@@deriving sexp_of] 5 | 6 | type t = slots Pool.t [@@deriving sexp_of] 7 | 8 | include Invariant.S with type t := t 9 | 10 | val create : unit -> t 11 | -------------------------------------------------------------------------------- /limiter_async/src/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name limiter_async) 3 | (public_name async_kernel.limiter_async) 4 | (libraries (async_kernel 5 | core_kernel 6 | core_kernel.limiter)) 7 | (preprocess (pps (ppx_jane ppxlib.runner))))) 8 | 9 | (jbuild_version 1) 10 | -------------------------------------------------------------------------------- /src/clock_ns.mli: -------------------------------------------------------------------------------- 1 | (** Provides a {{!Async_kernel.Clock_intf.Clock}[Clock]} with [Time_ns] as the unit. *) 2 | 3 | open! Core_kernel 4 | open! Import 5 | 6 | module type Clock = Clock_intf.Clock 7 | module type Clock_deprecated = Clock_intf.Clock_deprecated 8 | 9 | include Clock with module Time := Time_ns (** @open *) 10 | -------------------------------------------------------------------------------- /src/require_explicit_time_source.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Clock_ns = Clock_ns 5 | module Time_ns = Time_ns 6 | module Scheduler = Scheduler 7 | 8 | let after = Clock_ns.after 9 | let at = Clock_ns.at 10 | let every = Clock_ns.every 11 | let with_timeout = Clock_ns.with_timeout 12 | -------------------------------------------------------------------------------- /src/deferred_queue.mli: -------------------------------------------------------------------------------- 1 | (** All [Deferred_queue] iteration functions first copy the queue (to a list) and then 2 | start calling the user function [f]. So, if [f] modifies the queue, that will have no 3 | effect on the iteration. *) 4 | 5 | open! Core_kernel 6 | 7 | include Deferred1.Monad_sequence with type 'a t := 'a Queue.t (** @inline *) 8 | -------------------------------------------------------------------------------- /src/async_quickcheck.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open Async_quickcheck_intf 3 | 4 | module Generator = Quickcheck.Generator 5 | module Observer = Quickcheck.Observer 6 | module Shrinker = Quickcheck.Shrinker 7 | 8 | include Quickcheck_async_configured 9 | 10 | module Configure (Config : Quickcheck.Quickcheck_config) : Quickcheck_async_configured 11 | -------------------------------------------------------------------------------- /src/debug.mli: -------------------------------------------------------------------------------- 1 | (** Internal Async debugging functions. *) 2 | 3 | open! Core_kernel 4 | 5 | include module type of Async_kernel_config.Print_debug_messages_for 6 | 7 | (** Calls to [Debug.log] should look like [if Debug.??? then Debug.log ...]. *) 8 | val log : string -> 'a -> ('a -> Sexp.t) -> unit 9 | val log_string : string -> unit 10 | -------------------------------------------------------------------------------- /src/deferred.ml: -------------------------------------------------------------------------------- 1 | include Deferred1 2 | 3 | module Array = Deferred_array 4 | module List = Deferred_list 5 | module Map = Deferred_map 6 | module Memo = Deferred_memo 7 | module Option = Deferred_option 8 | module Or_error = Deferred_or_error 9 | module Queue = Deferred_queue 10 | module Result = Deferred_result 11 | module Sequence = Deferred_sequence 12 | -------------------------------------------------------------------------------- /src/scheduler0.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | include Types.Scheduler 5 | 6 | let events t = t.time_source.events 7 | 8 | let set_execution_context t execution_context = 9 | (* Avoid a caml_modify in most cases. *) 10 | if not (phys_equal t.current_execution_context execution_context) 11 | then (t.current_execution_context <- execution_context); 12 | ;; 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | # Default rule 4 | default: 5 | jbuilder build @install 6 | 7 | install: 8 | jbuilder install $(INSTALL_ARGS) 9 | 10 | uninstall: 11 | jbuilder uninstall $(INSTALL_ARGS) 12 | 13 | reinstall: uninstall install 14 | 15 | clean: 16 | rm -rf _build 17 | 18 | .PHONY: default install uninstall reinstall clean 19 | -------------------------------------------------------------------------------- /weak_hashtbl_async/src/weak_hashtbl_async.mli: -------------------------------------------------------------------------------- 1 | (** Like {{!Weak_hashtbl}[Weak_hashtbl]}, but automatically collects keys with unused 2 | data, rather than requiring user code to call [remove_keys_with_unused_data]. *) 3 | 4 | include module type of Weak_hashtbl (** @open *) 5 | 6 | val reclaim_space_for_keys_with_unused_data : [ `Do_not_use ] -> unit 7 | 8 | val set_run_when_unused_data : [ `Do_not_use ] -> unit 9 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Async_kernel 2 | 3 | `Async_kernel` contains `Async`'s core data structures, like `Deferred`. 4 | `Async_kernel` is portable, and so can be used in JavaScript using Async_js. In 5 | principle it could also be used on Windows, but no scheduler has been written 6 | for Async on Windows as of yet. 7 | 8 | API documentation for the latest release can be found 9 | [here][https://ocaml.janestreet.com/ocaml-core/latest/doc/async/index.html]. 10 | -------------------------------------------------------------------------------- /src/async_quickcheck_intf.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | module type Quickcheck_async_configured = sig 4 | 5 | include Quickcheck.Quickcheck_configured 6 | 7 | (** Like [test], but for asynchronous tests. *) 8 | val async_test 9 | : ?seed : Quickcheck.seed 10 | -> ?trials : int 11 | -> ?sexp_of : ('a -> Sexp.t) 12 | -> 'a Quickcheck.Generator.t 13 | -> f:('a -> unit Deferred.t) 14 | -> unit Deferred.t 15 | 16 | end 17 | -------------------------------------------------------------------------------- /src/ivar.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | module Deferred = Deferred0 4 | 5 | include Ivar0 6 | 7 | let read = Deferred.of_ivar 8 | 9 | let fill_if_empty t v = if is_empty t then (fill t v) 10 | 11 | include Binable.Of_binable1 (Option) (struct 12 | type nonrec 'a t = 'a t 13 | 14 | let to_binable t = peek t 15 | 16 | let of_binable = function 17 | | None -> create () 18 | | Some a -> create_full a 19 | ;; 20 | end) 21 | -------------------------------------------------------------------------------- /src/debug.ml: -------------------------------------------------------------------------------- 1 | module Time_ns_in_this_directory = Time_ns 2 | open Core_kernel 3 | module Time_ns = Time_ns_in_this_directory 4 | 5 | include Async_kernel_config.Print_debug_messages_for 6 | 7 | let log message a sexp_of_a = 8 | eprintf "%s\n%!" 9 | (Sexp.to_string_hum 10 | ([%sexp_of: Sexp.t * Time_ns.t * string * a] 11 | (!Async_kernel_config.task_id (), Time_ns.now (), message, a))) 12 | ;; 13 | 14 | let log_string message = log message () [%sexp_of: unit] 15 | -------------------------------------------------------------------------------- /src/async_condition.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | type 'a t = 4 | { waits : 'a Ivar.t Queue.t } 5 | [@@deriving sexp_of] 6 | 7 | let create () = 8 | { waits = Queue.create () } 9 | ;; 10 | 11 | let wait t = Deferred.create (fun ivar -> Queue.enqueue t.waits ivar) 12 | 13 | let signal t a = 14 | Option.iter (Queue.dequeue t.waits) ~f:(fun ivar -> Ivar.fill ivar a); 15 | ;; 16 | 17 | let broadcast t a = 18 | Queue.iter t.waits ~f:(fun ivar -> Ivar.fill ivar a); 19 | Queue.clear t.waits; 20 | ;; 21 | -------------------------------------------------------------------------------- /src/deferred_result.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | 3 | include Monad.S2 with type ('a, 'b) t = ('a, 'b) Result.t Deferred1.t (** @open *) 4 | 5 | val ignore : (_, 'err) t -> (unit, 'err) t 6 | 7 | val map_error : ('ok, 'error1) t -> f:('error1 -> 'error2) -> ('ok, 'error2) t 8 | 9 | (** [combine] waits on both inputs and combines their results using [Result.combine]. *) 10 | val combine 11 | : ('ok1, 'err) t 12 | -> ('ok2, 'err) t 13 | -> ok : ('ok1 -> 'ok2 -> 'ok3) 14 | -> err : ('err -> 'err -> 'err) 15 | -> ('ok3, 'err) t 16 | -------------------------------------------------------------------------------- /src/ivar_filler.mli: -------------------------------------------------------------------------------- 1 | (** [Ivar_filler] is a reference to an ivar that allows one to [fill] the ivar, but not to 2 | read it. This allows the implementation to drop the reference to the ivar once it is 3 | full, which can be useful to avoid holding onto unused memory. *) 4 | 5 | open! Core_kernel 6 | open! Import 7 | 8 | type 'a t [@@deriving sexp_of] 9 | 10 | include Invariant.S1 with type 'a t := 'a t 11 | 12 | val create : unit -> 'a t * 'a Deferred0.t 13 | 14 | val is_empty : 'a t -> bool 15 | 16 | val fill : 'a t -> 'a -> unit 17 | -------------------------------------------------------------------------------- /src/deferred_option.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | module Deferred = Deferred1 4 | 5 | module T = struct 6 | type 'a t = 'a Option.t Deferred.t 7 | end 8 | 9 | include T 10 | 11 | include Monad.Make (struct 12 | include T 13 | 14 | let return a = Deferred.return (Some a) 15 | 16 | let bind t ~f = 17 | Deferred.bind t ~f:(function 18 | | Some a -> f a 19 | | None -> Deferred.return None) 20 | ;; 21 | 22 | let map t ~f = Deferred.map t ~f:(fun r -> Option.map r ~f) 23 | let map = `Custom map 24 | end) 25 | -------------------------------------------------------------------------------- /src/job_pool.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | open Pool 5 | module Pointer = Pointer 6 | module Slot = Slot 7 | 8 | let dummy_e = Execution_context.main 9 | let dummy_f : Obj.t -> unit = ignore 10 | let dummy_a : Obj.t = Obj.repr () 11 | 12 | type slots = (Execution_context.t, Obj.t -> unit, Obj.t sexp_opaque) Slots.t3 13 | [@@deriving sexp_of] 14 | 15 | type t = slots Pool.t [@@deriving sexp_of] 16 | 17 | let invariant t = Pool.invariant ignore t 18 | 19 | let create () = create Slots.t3 ~capacity:1 ~dummy:(dummy_e, dummy_f, dummy_a) 20 | -------------------------------------------------------------------------------- /src/job_queue.mli: -------------------------------------------------------------------------------- 1 | (** Internal to Async -- a queue of jobs to run. *) 2 | 3 | open! Core_kernel 4 | open! Import 5 | 6 | module Scheduler = Scheduler0 7 | 8 | type t = Types.Job_queue.t [@@deriving sexp_of] 9 | 10 | include Invariant.S with type t := t 11 | 12 | val create : unit -> t 13 | val enqueue : t -> Execution_context.t -> ('a -> unit) -> 'a -> unit 14 | val clear : t -> unit 15 | val set_jobs_left_this_cycle : t -> int -> unit 16 | val can_run_a_job : t -> bool 17 | val length : t -> int 18 | val run_jobs : t -> Scheduler.t -> (unit, exn * Backtrace.t) Result.t 19 | val num_jobs_run : t -> int 20 | -------------------------------------------------------------------------------- /src/time_ns.ml: -------------------------------------------------------------------------------- 1 | include Core_kernel.Core_kernel_private.Time_ns_alternate_sexp 2 | 3 | (* [after] is like [add], but deals nicely with the case of overflow by instead returning 4 | [max_value]. Time-source functions use [after] to avoid immediately firing events that 5 | should never fire, due to the overflow leading to a negative time that appears to be in 6 | the past. We don't check underflow because that is very unlikely, requiring both a 7 | negative time and a negative span. *) 8 | let after t span = 9 | let result = add t span in 10 | if Span.( > ) span Span.zero && result < t 11 | then max_value 12 | else result 13 | ;; 14 | -------------------------------------------------------------------------------- /src/deferred_memo.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | 4 | module Deferred = Deferred1 5 | 6 | let reraise = function 7 | | Ok x -> x 8 | | Error exn -> Exn.reraise exn "caught exception in memoized function" 9 | ;; 10 | 11 | let general (type a) (hashable : (module Hashable with type t = a)) f = 12 | let module Hashable = (val hashable) in 13 | let f = 14 | Memo.general ~hashable:Hashable.hashable (fun a -> 15 | Monitor.try_with ~run:`Now (fun () -> f a)) 16 | in 17 | fun a -> f a >>| reraise 18 | ;; 19 | 20 | let unit f = 21 | let f = Memo.unit (fun () -> Monitor.try_with ~run:`Now f) in 22 | fun () -> f () >>| reraise 23 | ;; 24 | -------------------------------------------------------------------------------- /src/async_condition.mli: -------------------------------------------------------------------------------- 1 | (** Async's implementation of the standard notion of a "condition" variable. 2 | 3 | This is analogous to OCaml's [Condition] module. The main guarantee that a condition 4 | variable provides is that a call to [signal] (or [broadcast]) after a call to [wait] 5 | will be seen by the waiter. 6 | 7 | Unlike the use of condition variables in ordinary threaded programs, Async condition 8 | variables do not require a mutex, since Async programs are cooperatively threaded. *) 9 | 10 | open! Core_kernel 11 | 12 | type 'a t [@@deriving sexp_of] 13 | 14 | val create : unit -> _ t 15 | val signal : 'a t -> 'a -> unit 16 | val broadcast : 'a t -> 'a -> unit 17 | val wait : 'a t -> 'a Deferred.t 18 | -------------------------------------------------------------------------------- /src/execution_context.mli: -------------------------------------------------------------------------------- 1 | (** The context in which an Async job runs. *) 2 | 3 | open! Core_kernel 4 | open! Import 5 | 6 | type t = Types.Execution_context.t = 7 | { monitor : Monitor0.t 8 | ; priority : Priority.t 9 | ; local_storage : Univ_map.t 10 | ; backtrace_history : Backtrace.t list } 11 | [@@deriving fields, sexp_of] 12 | 13 | include Invariant.S with type t := t 14 | 15 | val main : t 16 | 17 | val create_like 18 | : ?monitor : Monitor0.t 19 | -> ?priority : Priority.t 20 | -> ?local_storage : Univ_map.t 21 | -> t 22 | -> t 23 | 24 | val find_local : t -> 'a Univ_map.Key.t -> 'a option 25 | val with_local : t -> 'a Univ_map.Key.t -> 'a option -> t 26 | 27 | val record_backtrace : t -> t 28 | 29 | -------------------------------------------------------------------------------- /src/deferred0.mli: -------------------------------------------------------------------------------- 1 | (** Internal to Async -- see {!Deferred} for the public API. *) 2 | 3 | open! Core_kernel 4 | open! Import 5 | 6 | type +'a t = 'a Types.Deferred.t [@@deriving sexp_of] 7 | type 'a deferred = 'a t 8 | 9 | include Invariant.S1 with type 'a t := 'a t 10 | 11 | val of_ivar : 'a Ivar0.t -> 'a t 12 | 13 | val create : ('a Ivar0.t -> unit) -> 'a t 14 | val peek : 'a t -> 'a option 15 | val value_exn : 'a t -> 'a 16 | val is_determined : _ t -> bool 17 | val return : 'a -> 'a t 18 | val upon : 'a t -> ('a -> unit) -> unit 19 | val bind : 'a t -> f:('a -> 'b t) -> 'b t 20 | 21 | module Handler : sig type 'a t [@@deriving sexp_of] end 22 | val add_handler : 'a t -> ('a -> unit) -> Execution_context.t -> 'a Handler.t 23 | val remove_handler : 'a t -> 'a Handler.t -> unit 24 | 25 | -------------------------------------------------------------------------------- /src/ivar_filler.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | type 'a u = 5 | | Empty of 'a Ivar.t 6 | | Full 7 | [@@deriving sexp_of] 8 | 9 | type 'a t = 'a u ref 10 | [@@deriving sexp_of] 11 | 12 | let invariant _ t = 13 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 14 | match !t with 15 | | Full -> () 16 | | Empty ivar -> assert (Ivar.is_empty ivar)) 17 | ;; 18 | 19 | let create () = 20 | let ivar = Ivar.create () in 21 | let t = ref (Empty ivar) in 22 | t, Ivar.read ivar 23 | ;; 24 | 25 | let is_empty t = 26 | match !t with 27 | | Empty _ -> true 28 | | Full -> false 29 | ;; 30 | 31 | let fill t a = 32 | match !t with 33 | | Empty i -> t := Full; Ivar.fill i a 34 | | Full -> raise_s [%message "attempt to fill full ivar"] 35 | ;; 36 | -------------------------------------------------------------------------------- /src/deferred_result.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | 4 | module Deferred = Deferred1 5 | 6 | module T = struct 7 | type ('a, 'error) t = ('a, 'error) Result.t Deferred.t 8 | end 9 | 10 | include T 11 | 12 | let combine t1 t2 ~ok ~err = 13 | let%map t1 = t1 and t2 = t2 in 14 | Result.combine t1 t2 ~ok ~err 15 | ;; 16 | 17 | include Monad.Make2 (struct 18 | include T 19 | 20 | let return a = Deferred.return (Ok a) 21 | 22 | let bind t ~f = 23 | Deferred.bind t ~f:(function 24 | | Ok a -> f a 25 | | Error _ as error -> Deferred.return error) 26 | ;; 27 | 28 | let map t ~f = Deferred.map t ~f:(fun r -> Result.map r ~f) 29 | let map = `Custom map 30 | end) 31 | 32 | let ignore = ignore_m 33 | 34 | let map_error t ~f = Deferred.map t ~f:(fun r -> Result.map_error r ~f) 35 | -------------------------------------------------------------------------------- /src/async_invariant.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Deferred.Let_syntax 3 | open! Import 4 | 5 | include Core_kernel.Invariant 6 | 7 | module Async = struct 8 | include Async_invariant_intf.Async 9 | 10 | let invariant here t sexp_of_t f = 11 | match%map Monitor.try_with f ~extract_exn:true with 12 | | Ok () -> () 13 | | Error exn -> 14 | raise_s [%message 15 | "invariant failed" 16 | ~_:(here : Source_code_position.t) 17 | (exn : exn) 18 | ~_:(t : t)] 19 | ;; 20 | 21 | let check_field t f wait_for_previous field = 22 | let%bind () = wait_for_previous in 23 | match%map Monitor.try_with ~extract_exn:true (fun () -> f (Field.get field t)) with 24 | | Ok () -> () 25 | | Error exn -> 26 | raise_s [%message 27 | "problem with field" 28 | ~field:(Field.name field : string) 29 | (exn : exn)] 30 | ;; 31 | end 32 | -------------------------------------------------------------------------------- /src/eager_deferred_result.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | module Deferred = Eager_deferred0 4 | open Deferred.Let_syntax 5 | 6 | (* Copied from [deferred_result.ml]. There should be no diffs below this line. *) 7 | 8 | module T = struct 9 | type ('a, 'error) t = ('a, 'error) Result.t Deferred.t 10 | end 11 | 12 | include T 13 | 14 | let combine t1 t2 ~ok ~err = 15 | let%map t1 = t1 and t2 = t2 in 16 | Result.combine t1 t2 ~ok ~err 17 | ;; 18 | 19 | include Monad.Make2 (struct 20 | include T 21 | 22 | let return a = Deferred.return (Ok a) 23 | 24 | let bind t ~f = 25 | Deferred.bind t ~f:(function 26 | | Ok a -> f a 27 | | Error _ as error -> Deferred.return error) 28 | ;; 29 | 30 | let map t ~f = Deferred.map t ~f:(fun r -> Result.map r ~f) 31 | let map = `Custom map 32 | end) 33 | 34 | let ignore = ignore_m 35 | 36 | let map_error t ~f = Deferred.map t ~f:(fun r -> Result.map_error r ~f) 37 | -------------------------------------------------------------------------------- /async_kernel.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "opensource@janestreet.com" 3 | authors: ["Jane Street Group, LLC "] 4 | homepage: "https://github.com/janestreet/async_kernel" 5 | bug-reports: "https://github.com/janestreet/async_kernel/issues" 6 | dev-repo: "git+https://github.com/janestreet/async_kernel.git" 7 | license: "MIT" 8 | build: [ 9 | ["jbuilder" "build" "-p" name "-j" jobs] 10 | ] 11 | depends: [ 12 | "core_kernel" 13 | "ppx_jane" 14 | "jbuilder" {build & >= "1.0+beta18.1"} 15 | "ocaml-migrate-parsetree" {>= "1.0"} 16 | "ppxlib" {>= "0.1.0"} 17 | ] 18 | available: [ ocaml-version >= "4.04.2" ] 19 | descr: " 20 | Monadic concurrency library 21 | 22 | Part of Jane Street's Core library 23 | The Core suite of libraries is an industrial strength alternative to 24 | OCaml's standard library that was developed by Jane Street, the 25 | largest industrial user of OCaml. 26 | " 27 | -------------------------------------------------------------------------------- /src/async_gc.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | include Gc 4 | 5 | (** [add_finalizer f x] is like [Gc.finalise f x], except that the finalizer is guaranteed 6 | to run as an Async job (i.e. without interrupting other Async jobs). Unprotected use 7 | of [Caml.Gc.finalise] or [Core.Gc.add_finalizer] in Async programs is wrong, because 8 | the finalizers won't hold the async lock, and thus could interleave arbitrarily with 9 | async jobs. *) 10 | let add_finalizer heap_block f = Scheduler.(add_finalizer (t ())) heap_block f 11 | let add_finalizer_exn heap_block f = Scheduler.(add_finalizer_exn (t ())) heap_block f 12 | 13 | let add_finalizer_last heap_block f = 14 | Scheduler.(add_finalizer_last (t ())) heap_block f 15 | let add_finalizer_last_exn heap_block f = 16 | Scheduler.(add_finalizer_last_exn (t ())) heap_block f 17 | 18 | module Alarm = struct 19 | module Alarm = Gc.Expert.Alarm 20 | 21 | type t = Alarm.t [@@deriving sexp_of] 22 | 23 | let create f = Scheduler.(create_alarm (t ())) f 24 | 25 | let delete = Alarm.delete 26 | end 27 | -------------------------------------------------------------------------------- /src/async_quickcheck.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | open Deferred.Infix 4 | 5 | module Generator = Quickcheck.Generator 6 | module Observer = Quickcheck.Observer 7 | module Shrinker = Quickcheck.Shrinker 8 | 9 | module Configure (Config : Quickcheck.Quickcheck_config) = struct 10 | 11 | include Quickcheck.Configure (Config) 12 | 13 | let async_test ?seed ?(trials = default_trial_count) ?sexp_of quickcheck_generator ~f = 14 | let f_with_sexp = 15 | match sexp_of with 16 | | None -> f 17 | | Some sexp_of_arg -> 18 | (fun x -> 19 | Deferred.Or_error.try_with (fun () -> f x) 20 | >>| function 21 | | Ok () -> () 22 | | Error e -> 23 | Error.raise 24 | (Error.tag_arg e "random input" x sexp_of_arg)) 25 | in 26 | Sequence.delayed_fold 27 | (Sequence.take (random_sequence ?seed quickcheck_generator) trials) 28 | ~init:() 29 | ~f:(fun () x ~k -> f_with_sexp x >>= k) 30 | ~finish:Deferred.return 31 | 32 | end 33 | 34 | include Configure (Quickcheck) 35 | -------------------------------------------------------------------------------- /src/deferred_memo.mli: -------------------------------------------------------------------------------- 1 | (** Memoization functions like in [Core_kernel.Memo], with re-raising of exceptions 2 | thrown asynchronously. *) 3 | 4 | open! Core_kernel 5 | open! Import 6 | 7 | module Deferred = Deferred1 8 | 9 | (** [general hashable f] returns a memoized version of [f], where the results are stored 10 | in a hash table indexed according to [hashable]. If [f a] asynchronously raises, then 11 | the error is stored in the hash table and is reraised when [a] is demanded. 12 | 13 | Unlike [Core_kernel.Memo.general], this [general] does not support 14 | [cache_size_bound] due to complexities of asynchrony -- even when one has a deferred 15 | return by the memoized function, there still may be asynchronous jobs working to 16 | determine it. 17 | 18 | Unlike [Core_kernel.Memo.general], this [general] takes a required [Hashable] 19 | module argument, to avoid unintentional use of polymorphic comparison. *) 20 | val general 21 | : (module Hashable with type t = 'a) 22 | -> ('a -> 'b Deferred.t) 23 | -> ('a -> 'b Deferred.t) 24 | 25 | val unit 26 | : (unit -> 'a Deferred.t) 27 | -> (unit -> 'a Deferred.t) 28 | -------------------------------------------------------------------------------- /src/import.ml: -------------------------------------------------------------------------------- 1 | module Debug_in_this_directory = Debug 2 | module Time_ns_in_this_directory = Time_ns 3 | 4 | open! Core_kernel 5 | 6 | module Debug = Debug_in_this_directory 7 | module Time_ns = Time_ns_in_this_directory 8 | 9 | module Epoll_max_ready_events = Async_kernel_config.Epoll_max_ready_events 10 | module Max_inter_cycle_timeout = Async_kernel_config.Max_inter_cycle_timeout 11 | module Max_num_open_file_descrs = Async_kernel_config.Max_num_open_file_descrs 12 | module Max_num_threads = Async_kernel_config.Max_num_threads 13 | module Max_num_jobs_per_priority_per_cycle = Async_kernel_config.Max_num_jobs_per_priority_per_cycle 14 | 15 | let concat = String.concat 16 | 17 | let eprint = Core_kernel.Debug.eprint 18 | let eprint_s = Core_kernel.Debug.eprint_s 19 | let eprints = Core_kernel.Debug.eprints 20 | 21 | let print_s sexp = printf "%s\n%!" (sexp |> Sexp.to_string_hum) 22 | 23 | let sec = Time_ns.Span.of_sec 24 | 25 | (* We don't want to use these modules in Async_kernel, to avoid difficulties with 26 | using it on js_of_ocaml. *) 27 | module Thread = struct end 28 | module Unix = struct end 29 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2008--2018 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 | -------------------------------------------------------------------------------- /src/job_or_event_intf.ml: -------------------------------------------------------------------------------- 1 | (** [Job_or_event] is a custom zero-alloc sum type that is like: 2 | 3 | {[ 4 | | Event of Event.t 5 | | Job of Job.t 6 | ]} 7 | 8 | except that it uses the fact that [Event.t] is a pointer and [Job.t] is an 9 | int to be zero alloc. *) 10 | 11 | open! Core_kernel 12 | open! Import 13 | 14 | module Event = Types.Event 15 | 16 | module type Job_or_event = sig 17 | type t = Types.Job_or_event.t 18 | 19 | val of_event : Event.t -> t 20 | val of_job : Job.t -> t 21 | 22 | val is_event : t -> bool 23 | val is_job : t -> bool 24 | 25 | (** Idiomatic usage of [Match] is: 26 | 27 | {[ 28 | let job_or_event = ... in 29 | let open Job_or_event.Match in 30 | let K k = kind job_or_event in 31 | match k, project k job_or_event with 32 | | Event , event -> ... use event ... 33 | | Job , job -> ... use job ... 34 | ]} *) 35 | module Match : sig 36 | type _ kind = 37 | | Event : Event.t kind 38 | | Job : Job.t kind 39 | 40 | type packed = K : _ kind -> packed 41 | 42 | val kind : t -> packed 43 | val project : 'a kind -> t -> 'a 44 | end 45 | end 46 | -------------------------------------------------------------------------------- /weak_hashtbl_async/test/test_weak_hashtbl.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Import 4 | open! Weak_hashtbl_async 5 | 6 | let%test_unit _ = (* automatic reclamation, multiple times *) 7 | Thread_safe.block_on_async_exn (fun () -> 8 | let t = create (module Int) in 9 | let heap_block i = Heap_block.create_exn (ref i) in 10 | let b1 = heap_block 1 in 11 | let key1 = 13 in 12 | let key2 = 14 in 13 | ignore (find_or_add t key1 ~default:(fun () -> b1) : _ Heap_block.t); 14 | ignore (find_or_add t key2 ~default:(fun () -> heap_block 2) : _ Heap_block.t); 15 | Gc.full_major (); 16 | after (sec 0.) (* let a cycle happen, to do the reclamation *) 17 | >>= fun () -> 18 | assert (phys_equal (Option.value_exn (find t key1)) b1); 19 | assert (Option.is_none (find t key2)); 20 | assert (not (key_is_using_space t key2)); 21 | let key3 = 15 in 22 | ignore (find_or_add t key3 ~default:(fun () -> heap_block 3) : _ Heap_block.t); 23 | Gc.full_major (); 24 | after (sec 0.) (* let a cycle happen, to do the reclamation *) 25 | >>= fun () -> 26 | assert (Option.is_none (find t key3)); 27 | assert (not (key_is_using_space t key3)); 28 | return ()) 29 | ;; 30 | -------------------------------------------------------------------------------- /src/tail.mli: -------------------------------------------------------------------------------- 1 | (** A pointer to the end of an {!Async_stream} that can be used to extend the stream. *) 2 | 3 | open! Import 4 | 5 | module Deferred = Deferred1 6 | 7 | type 'a t = 'a Types.Tail.t [@@deriving sexp_of] 8 | 9 | (** [create ()] returns a new tail. *) 10 | val create : unit -> _ t 11 | 12 | (** [extend t v] extends the stream, and will raise an exception if [t] has been 13 | closed. *) 14 | val extend : 'a t -> 'a -> unit 15 | 16 | (** [close_exn t] closes [t]. Subsequent calls to [close_exn] or [extend] 17 | will raise an exception. *) 18 | val close_exn : _ t -> unit 19 | 20 | (** [close_if_open t] closes [t], if it's not already closed. If [t] is already 21 | closed, then this is a no-op. *) 22 | val close_if_open : _ t -> unit 23 | 24 | (** [is_closed t] returns true iff the stream [t] is closed. *) 25 | val is_closed : _ t -> bool 26 | 27 | module Stream : sig 28 | type 'a t [@@deriving sexp_of] 29 | type 'a next = Nil | Cons of 'a * 'a t 30 | 31 | val next : 'a t -> 'a next Deferred.t 32 | end 33 | 34 | (** [collect t] returns the stream starting at the current position of the tail, i.e. the 35 | stream consisting of all subsequent [extend]s. *) 36 | val collect : 'a t -> 'a Stream.t 37 | -------------------------------------------------------------------------------- /src/execution_context.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Monitor = Monitor0 5 | 6 | type t = Types.Execution_context.t = 7 | { monitor : Monitor.t 8 | ; priority : Priority.t 9 | ; local_storage : Univ_map.t 10 | ; backtrace_history : Backtrace.t list } 11 | [@@deriving fields, sexp_of] 12 | 13 | let invariant (_ : t) = () 14 | 15 | let main = 16 | { monitor = Monitor.main 17 | ; priority = Priority.normal 18 | ; local_storage = Univ_map.empty 19 | ; backtrace_history = [] } 20 | ;; 21 | 22 | let create_like ?monitor ?priority ?local_storage t = 23 | let monitor = Option.value monitor ~default:t.monitor in 24 | { monitor 25 | ; priority = Option.value priority ~default:t.priority 26 | ; local_storage = Option.value local_storage ~default:t.local_storage 27 | ; backtrace_history = t.backtrace_history } 28 | ;; 29 | 30 | let find_local t key = Univ_map.find t.local_storage key 31 | 32 | let with_local t key data = 33 | { t with local_storage = Univ_map.change t.local_storage key ~f:(fun _ -> data) } 34 | ;; 35 | 36 | let record_backtrace t = 37 | { t with backtrace_history = Backtrace.get () :: t.backtrace_history } 38 | ;; 39 | -------------------------------------------------------------------------------- /src/lazy_deferred.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | 4 | module T = struct 5 | 6 | type 'a t = 7 | { start : unit Ivar.t 8 | ; result : 'a Or_error.t Deferred.t } 9 | 10 | let create f = 11 | let start = Ivar.create () in 12 | { start 13 | ; result = 14 | let%bind () = Ivar.read start in 15 | Monitor.try_with_or_error f } 16 | ;; 17 | 18 | let wait t = t.result 19 | 20 | let wait_exn t = wait t >>| ok_exn 21 | 22 | let start t = Ivar.fill_if_empty t.start () 23 | 24 | let force t = start t; wait t 25 | 26 | let force_exn t = force t >>| ok_exn 27 | 28 | let return a = create (fun () -> return a) 29 | 30 | let bind t ~f = 31 | create (fun () -> 32 | let%bind a = force_exn t in 33 | force_exn (f a)) 34 | ;; 35 | 36 | let map t ~f = create (fun () -> force_exn t >>| f) 37 | let map = `Custom map 38 | 39 | end 40 | 41 | include T 42 | 43 | include Monad.Make (T) 44 | 45 | let bind' t f = bind t ~f:(fun a -> create (fun () -> f a)) 46 | 47 | let is_forced t = Ivar.is_full t.start 48 | 49 | let is_determined t = Deferred.is_determined t.result 50 | 51 | let peek t = Deferred.peek t.result 52 | 53 | let peek_exn t = Option.map (peek t) ~f:ok_exn 54 | -------------------------------------------------------------------------------- /src/bvar.mli: -------------------------------------------------------------------------------- 1 | (** A [Bvar] is a synchronization point that allows one to [broadcast] a value to clients 2 | [wait]ing on the broadcast. With a [Bvar], one can efficiently notify multiple 3 | clients of edge-triggered conditions, repeating as each edge trigger occurs. 4 | 5 | [Bvar] is like an ivar/deferred, except that it is always "empty" and can be 6 | repeatedly "filled" (via [broadcast]). 7 | 8 | Another way to view [Bvar] is as a restriction of [Condition] that supports only 9 | broadcast, not [signal]ing a single waiter. Dropping [signal] simplifies the 10 | implementation significantly. 11 | 12 | The ['permissions] parameter is used for read/write permissions. Also see [Perms]. *) 13 | 14 | open! Core_kernel 15 | open! Import 16 | 17 | type ('a, -'permissions) t = ('a, 'permissions) Types.Bvar.t [@@deriving sexp_of] 18 | 19 | include Invariant.S2 with type ('a, 'permissions) t := ('a, 'permissions) t 20 | 21 | val create : unit -> ('a, read_write) t 22 | 23 | (** [wait t] becomes determined by the next call to [broadcast t a]. *) 24 | val wait : ('a, [> read]) t -> 'a Deferred0.t 25 | 26 | val broadcast : ('a, [> write]) t -> 'a -> unit 27 | 28 | (** [has_any_waiters t] returns [true] iff there has been a call to [wait t] since the 29 | most recent call to [broadcast t]. *) 30 | val has_any_waiters : ('a, _) t -> bool 31 | -------------------------------------------------------------------------------- /weak_hashtbl_async/src/weak_hashtbl_async.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | include Weak_hashtbl 5 | 6 | let create ?growth_allowed ?size hashable = 7 | let t = create ?growth_allowed ?size hashable in 8 | (* To avoid having keys around that should be cleaned, we must ensure that after any 9 | call to [thread_safe_f], there is a call to 10 | [reclaim_space_for_keys_with_unused_data]. We do this via [reclaim_will_happen], 11 | which, if [true], guarantees that a call to [reclaim_space_for_keys_with_unused_data] 12 | will happen in the future. It is OK if we have multiple reclaims extant 13 | simultaneously, since they are async jobs. *) 14 | let reclaim_will_happen = ref false in 15 | let reclaim () = 16 | reclaim_will_happen := false; 17 | reclaim_space_for_keys_with_unused_data t; 18 | in 19 | set_run_when_unused_data t ~thread_safe_f:(fun () -> 20 | if not !reclaim_will_happen then begin 21 | reclaim_will_happen := true; 22 | let module Scheduler = Async_kernel.Async_kernel_scheduler in 23 | let scheduler = Scheduler.t () in 24 | Scheduler.thread_safe_enqueue_external_job scheduler 25 | Scheduler.main_execution_context reclaim (); 26 | end); 27 | t 28 | ;; 29 | 30 | let reclaim_space_for_keys_with_unused_data `Do_not_use = assert false 31 | let set_run_when_unused_data `Do_not_use = assert false 32 | -------------------------------------------------------------------------------- /src/tail.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Deferred = Deferred1 5 | 6 | module Stream = struct 7 | type 'a t = 'a next Deferred.t 8 | and 'a next = 'a Types.Stream.next = Nil | Cons of 'a * 'a t 9 | 10 | let sexp_of_t sexp_of_a t = 11 | let rec loop d ac : Sexp.t = 12 | match Deferred.peek d with 13 | | None -> List (List.rev (Sexp.Atom "..." :: ac)) 14 | | Some Nil -> List (List.rev ac) 15 | | Some (Cons (a, t)) -> loop t (sexp_of_a a :: ac) 16 | in 17 | loop t [] 18 | ;; 19 | 20 | let next t = t 21 | end 22 | 23 | type 'a t = 'a Types.Tail.t = 24 | { (* [next] points at the tail of the stream *) 25 | mutable next: 'a Stream.next Ivar.t } 26 | [@@deriving fields] 27 | 28 | let sexp_of_t _ t : Sexp.t = 29 | Atom (if Ivar.is_empty t.next then "" else "") 30 | ;; 31 | 32 | let create () = { next = Ivar.create () } 33 | 34 | let collect t = Ivar.read (next t) 35 | 36 | let is_closed t = Ivar.is_full (next t) 37 | 38 | let fill_exn t v = 39 | if is_closed t 40 | then (raise_s [%message "stream is closed"]) 41 | else (Ivar.fill (next t) v) 42 | ;; 43 | 44 | let close_exn t = fill_exn t Nil 45 | 46 | let close_if_open t = if not (is_closed t) then (Ivar.fill (next t) Nil) 47 | 48 | let extend t v = 49 | let next = Ivar.create () in 50 | fill_exn t (Cons (v, Ivar.read next)); 51 | t.next <- next; 52 | ;; 53 | -------------------------------------------------------------------------------- /src/eager_deferred_or_error.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | type 'a t = 'a Or_error.t Deferred.t 5 | 6 | include Monad.S with type 'a t := 'a t 7 | 8 | val fail : Error.t -> _ t 9 | val ok_unit : unit t 10 | val ignore : _ t -> unit t 11 | val ok_exn : 'a t -> 'a Deferred.t 12 | val of_exn : exn -> _ t 13 | val of_exn_result : ('a, exn) Result.t Deferred.t -> 'a t 14 | val error : string -> 'a -> ('a -> Sexp.t) -> _ t 15 | val error_s : Sexp.t -> _ t 16 | val error_string : string -> _ t 17 | val errorf : ('a, unit, string, _ t) format4 -> 'a 18 | val tag : 'a t -> tag:string -> 'a t 19 | val tag_arg : 'a t -> string -> 'b -> ('b -> Sexp.t) -> 'a t 20 | val unimplemented : string -> _ t 21 | 22 | val find_map_ok : 'a list -> f:('a -> 'b t) -> 'b t 23 | 24 | (** Note that [try_with f] is eager only in the [Ok] case. *) 25 | val try_with 26 | : ?extract_exn:bool 27 | -> ?here:Lexing.position 28 | -> ?name:string 29 | -> (unit -> 'a Deferred.t) 30 | -> 'a t 31 | 32 | (** Note that [try_with_join f] is eager only when no exception is raised by [f]. *) 33 | val try_with_join 34 | : ?extract_exn:bool 35 | -> ?here:Lexing.position 36 | -> ?name:string 37 | -> (unit -> 'a t) 38 | -> 'a t 39 | 40 | val combine_errors : 'a t list -> 'a list t 41 | val combine_errors_unit : unit t list -> unit t 42 | 43 | module List : Monad_sequence.S 44 | with type 'a monad := 'a t 45 | with type 'a t := 'a list 46 | -------------------------------------------------------------------------------- /src/bvar.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | type ('a, 'permission) t = ('a, 'permission) Types.Bvar.t 5 | 6 | type 'a repr = 'a Types.Bvar.repr = 7 | { mutable has_any_waiters : bool 8 | ; mutable ivar : 'a Ivar.t } 9 | [@@deriving fields, sexp_of] 10 | 11 | let invariant invariant_a _ t = 12 | let repr = Types.Bvar.to_repr t in 13 | Invariant.invariant [%here] repr [%sexp_of: _ repr] (fun () -> 14 | let check f = Invariant.check_field repr f in 15 | Fields_of_repr.iter 16 | ~has_any_waiters:(check (fun has_any_waiters -> 17 | if Ivar.has_handlers repr.ivar 18 | then (assert has_any_waiters))) 19 | ~ivar:(check (fun ivar -> 20 | Ivar.invariant invariant_a ivar; 21 | assert (Ivar.is_empty ivar)))) 22 | ;; 23 | 24 | let sexp_of_t _ _ t = 25 | let { has_any_waiters; ivar = _ } = Types.Bvar.to_repr t in 26 | (* We don't show [ivar] because it's always empty. *) 27 | [%message (has_any_waiters : bool)] 28 | ;; 29 | 30 | include Scheduler1.Bvar 31 | 32 | let broadcast t a = 33 | let repr = Types.Bvar.to_repr t in 34 | if repr.has_any_waiters 35 | then ( 36 | repr.has_any_waiters <- false; 37 | Ivar.fill repr.ivar a; 38 | repr.ivar <- Ivar.create ()) 39 | ;; 40 | 41 | let wait t = 42 | let repr = Types.Bvar.to_repr t in 43 | repr.has_any_waiters <- true; 44 | Ivar.read repr.ivar; 45 | ;; 46 | 47 | let has_any_waiters t = 48 | let repr = Types.Bvar.to_repr t in 49 | repr.has_any_waiters 50 | ;; 51 | -------------------------------------------------------------------------------- /src/job_or_event.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Event = Types.Event 5 | module Job = Types.Job 6 | 7 | include Types.Job_or_event 8 | 9 | (* This redefinition of [Event] is here so the type checks are right next to 10 | [Obj.magic]s. *) 11 | module Event_is_block : sig end = struct 12 | open Types 13 | open Event 14 | type _t = t = (* must never be immediate *) 15 | { mutable alarm : Job_or_event.t Timing_wheel_ns.Alarm.t 16 | ; mutable at : Time_ns.t 17 | ; callback : (unit -> unit) 18 | ; execution_context : Execution_context.t 19 | ; mutable interval : Time_ns.Span.t option 20 | ; mutable next_fired : t 21 | ; mutable status : Status.t } 22 | end 23 | 24 | module Job_is_not_block : sig end = struct 25 | module Ensure_private_int (M : sig type t = private int end) = struct type _t = M.t end 26 | include Ensure_private_int (Job) 27 | end 28 | 29 | let of_event event = (Obj.magic (event : Event.t) : t) 30 | let of_job job = (Obj.magic (job : Job.t) : t) 31 | 32 | let is_event (t : t) = Obj.is_block (Obj.repr t) 33 | let is_job (t : t) = Obj.is_int (Obj.repr t) 34 | 35 | module Match = struct 36 | type _ kind = 37 | | Event : Event.t kind 38 | | Job : Job.t kind 39 | 40 | type packed = K : _ kind -> packed 41 | 42 | let kind t = if is_event t then (K Event) else (K Job) 43 | 44 | let project (type a) (_ : a kind) job_or_event = 45 | (Obj.magic (job_or_event : t) : a) 46 | ;; 47 | end 48 | -------------------------------------------------------------------------------- /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 | or, in an import.ml: 10 | 11 | {[ 12 | include Require_explicit_time_source ]} *) 13 | 14 | open! Core_kernel 15 | open! Import 16 | 17 | module Clock_ns : Clock_intf.Clock_deprecated with module Time := Time_ns 18 | 19 | module Time_ns : sig 20 | include module type of struct include Time_ns end 21 | 22 | val now : unit -> t 23 | [@@deprecated "[since 2016-02] Use [Time_source]"] 24 | end 25 | 26 | module Scheduler : sig 27 | include module type of struct include Scheduler end 28 | 29 | val cycle_start : t -> Time_ns.t 30 | [@@deprecated "[since 2016-02] Use [Time_source]"] 31 | end 32 | 33 | val at : Time_ns.t -> unit Deferred.t 34 | [@@deprecated "[since 2016-02] Use [Time_source]"] 35 | 36 | val after : Time_ns.Span.t -> unit Deferred.t 37 | [@@deprecated "[since 2016-02] Use [Time_source]"] 38 | 39 | val every 40 | : ?start : unit Deferred.t 41 | -> ?stop : unit Deferred.t 42 | -> ?continue_on_error : bool 43 | -> Time_ns.Span.t 44 | -> (unit -> unit) -> unit 45 | [@@deprecated "[since 2016-02] Use [Time_source]"] 46 | 47 | val with_timeout 48 | : Time_ns.Span.t 49 | -> 'a Deferred.t 50 | -> [ `Timeout 51 | | `Result of 'a 52 | ] Deferred.t 53 | [@@deprecated "[since 2016-02] Use [Time_source]"] 54 | -------------------------------------------------------------------------------- /src/ivar0.mli: -------------------------------------------------------------------------------- 1 | (** Internal to Async -- see {!Ivar} for the public API. *) 2 | 3 | open! Core_kernel 4 | open! Import 5 | 6 | module Cell = Types.Cell 7 | 8 | type 'a t 9 | = 'a Types.Ivar.t 10 | = { mutable cell : ('a, Cell.any) Cell.t } 11 | [@@deriving sexp_of] 12 | 13 | type 'a ivar = 'a t 14 | 15 | include Invariant.S1 with type 'a t := 'a t 16 | 17 | val create : unit -> _ t 18 | val create_full : 'a -> 'a t 19 | 20 | val create_with_cell : ('a, Cell.any) Cell.t -> 'a t 21 | 22 | val peek : 'a t -> 'a option 23 | val value_exn : 'a t -> 'a 24 | val value : 'a t -> if_empty_then_failwith:string -> 'a 25 | 26 | val is_empty : _ t -> bool 27 | val is_full : _ t -> bool 28 | 29 | val equal : 'a t -> 'a t -> bool 30 | 31 | val connect : bind_result:'a t -> bind_rhs:'a t -> unit 32 | val fill : 'a t -> 'a -> unit 33 | 34 | module Handler : sig 35 | type 'a t = ('a, [ `Empty_one_or_more_handlers ]) Cell.t 36 | [@@deriving sexp_of] 37 | 38 | val length : _ t -> int 39 | val of_list : (('a -> unit) * Execution_context.t) list -> 'a t option 40 | val to_list : 'a t -> (('a -> unit) * Execution_context.t) list 41 | end 42 | 43 | val cell_of_handler : 'a Handler.t -> ('a, Cell.any) Cell.t 44 | 45 | val add_handler : 'a t -> ('a -> unit) -> Execution_context.t -> 'a Handler.t 46 | val remove_handler : 'a t -> 'a Handler.t -> unit 47 | val has_handlers : _ t -> bool 48 | 49 | val upon : 'a t -> ('a -> unit) -> unit 50 | val upon' : 'a t -> ('a -> unit) -> 'a Handler.t 51 | 52 | val indir : 'a t -> 'a t 53 | 54 | val squash : 'a t -> 'a t 55 | -------------------------------------------------------------------------------- /src/ivar.mli: -------------------------------------------------------------------------------- 1 | (** A write-once cell that can be empty or full (i.e., hold a single value). 2 | 3 | One can [read] an ivar to obtain a deferred that becomes determined when the ivar is 4 | filled. An ivar is similar to an ['a option ref], except it is an error to fill an 5 | already full ivar. *) 6 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | type 'a t = 'a Types.Ivar.t [@@deriving bin_io, sexp_of] 11 | type 'a ivar = 'a t 12 | 13 | include Invariant.S1 with type 'a t := 'a t 14 | 15 | (** [equal t t'] is physical equality of [t] and [t']. *) 16 | val equal : 'a t -> 'a t -> bool 17 | 18 | (** [create ()] returns an empty ivar. *) 19 | val create : unit -> 'a t 20 | 21 | (** [create_full v] returns an ivar filled with [v]. *) 22 | val create_full : 'a -> 'a t 23 | 24 | (** [fill t v] fills [t] with value [v] if [t] was empty. If [t] was full, [fill] raises 25 | an exception. It is guaranteed that immediately after calling [fill t], [is_some 26 | (Deferred.peek (read t))]. *) 27 | val fill : 'a t -> 'a -> unit 28 | 29 | (** [fill_if_empty t v] fills [t] with [v] if [t] is currently empty. If [t] is full, 30 | then [fill_if_empty] does nothing. *) 31 | val fill_if_empty : 'a t -> 'a -> unit 32 | 33 | (** [is_empty t] returns true if [t] is empty. *) 34 | val is_empty : 'a t -> bool 35 | 36 | (** [is_full t] returns true if [t] is full. *) 37 | val is_full : 'a t -> bool 38 | 39 | (** [read t] returns a deferred that becomes enabled with value [v] after the ivar is 40 | filled with [v]. *) 41 | val read : 'a t -> 'a Deferred0.t 42 | 43 | (** [peek t] returns [Some v] iff [t] is full with value [v]. *) 44 | val peek : 'a t -> 'a option 45 | 46 | (** [value_exn t] returns [v] if [t] is full with value [v], and raises otherwise. *) 47 | val value_exn : 'a t -> 'a 48 | 49 | (** [has_handlers t] returns [true] if [t] has handlers waiting on [read t]. *) 50 | val has_handlers : _ t -> bool 51 | -------------------------------------------------------------------------------- /src/clock_ns.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module type Clock = Clock_intf.Clock 5 | module type Clock_deprecated = Clock_intf.Clock_deprecated 6 | 7 | module Scheduler = Scheduler1 8 | 9 | let time_source () = (Scheduler.t ()).time_source |> Time_source.of_synchronous 10 | 11 | let after span = Time_source.after (time_source ()) span 12 | 13 | let at time = Time_source.at (time_source ()) time 14 | 15 | let at_varying_intervals ?stop compute_span = 16 | Time_source.at_varying_intervals ?stop (time_source ()) compute_span; 17 | ;; 18 | 19 | let at_intervals ?start ?stop interval = 20 | Time_source.at_intervals ?start ?stop (time_source ()) interval; 21 | ;; 22 | 23 | let every' ?start ?stop ?continue_on_error ?finished span f = 24 | Time_source.every' ?start ?stop ?continue_on_error ?finished (time_source ()) span f; 25 | ;; 26 | 27 | let every ?start ?stop ?continue_on_error span f = 28 | Time_source.every ?start ?stop ?continue_on_error (time_source ()) span f; 29 | ;; 30 | 31 | let run_after span f a = Time_source.run_after (time_source ()) span f a 32 | 33 | let run_at time f a = Time_source.run_at (time_source ()) time f a 34 | 35 | let run_at_intervals ?start ?stop ?continue_on_error interval f = 36 | Time_source.run_at_intervals ?start ?stop ?continue_on_error 37 | (time_source ()) interval f; 38 | ;; 39 | 40 | let run_at_intervals' ?start ?stop ?continue_on_error interval f = 41 | Time_source.run_at_intervals' ?start ?stop ?continue_on_error 42 | (time_source ()) interval f; 43 | ;; 44 | 45 | let with_timeout span d = Time_source.with_timeout (time_source ()) span d 46 | 47 | module Event = struct 48 | include Time_source.Event 49 | 50 | let after span = after (time_source ()) span 51 | let run_after span f a = run_after (time_source ()) span f a 52 | 53 | let at time = at (time_source ()) time 54 | let run_at time f z = run_at (time_source ()) time f z 55 | end 56 | -------------------------------------------------------------------------------- /src/eager_deferred.mli: -------------------------------------------------------------------------------- 1 | (** [Eager_deferred] partially implements the [Deferred] interface, with a type ['a t] 2 | equal to ['a Deferred.t], but where the operations are "eager", that is built upon a 3 | world where [bind], [map], and [upon] eagerly apply their closure without preemption 4 | in the case the deferred they are working with is already determined. 5 | 6 | The goal with that approach is that one can locally write the following to switch to 7 | such a world. 8 | 9 | {[ open Use_eager_deferred ]} 10 | 11 | We do not intend at first for this to implement the entire [Deferred] interface, 12 | because some of this will require more experimentation and discussions. We can 13 | proceed incrementally to enrich this interface. 14 | 15 | [test/test_eager_deferred] verifies that this interface is a sub interface of the 16 | [Deferred] interface. For documentation, refer to 17 | {{!Async_kernel.Deferred}[Deferred]}. *) 18 | 19 | open! Core_kernel 20 | open! Import 21 | 22 | include sig 23 | type +'a t 24 | 25 | include Invariant.S1 with type 'a t := 'a t 26 | 27 | include Monad with type 'a t := 'a t 28 | 29 | module Infix : sig 30 | include Monad.Infix with type 'a t := 'a t 31 | val (>>>) : 'a t -> ('a -> unit) -> unit 32 | end 33 | 34 | val any : 'a t list -> 'a t 35 | val any_unit : 'a t list -> unit t 36 | val both : 'a t -> 'b t -> ('a * 'b) t 37 | val create : ('a Ivar.t -> unit) -> 'a t 38 | val don't_wait_for : unit t -> unit 39 | val ignore : _ t -> unit t 40 | val is_determined : 'a t -> bool 41 | val never : unit -> _ t 42 | val ok : 'a t -> ('a, _) Core_kernel.Result.t t 43 | val peek : 'a t -> 'a option 44 | val unit : unit t 45 | val upon : 'a t -> ('a -> unit) -> unit 46 | val value_exn : 'a t -> 'a 47 | 48 | val repeat_until_finished 49 | : 'state 50 | -> ('state -> [ `Repeat of 'state 51 | | `Finished of 'result 52 | ] t) 53 | -> 'result t 54 | 55 | module List : Deferred1.Monad_sequence with type 'a t := 'a list 56 | module Or_error : module type of Eager_deferred_or_error 57 | end 58 | (*_ We do not expose [Eager_deferred.t] so that type-error messages refer to 59 | [Deferred.t], not [Eager_deferred.t]. *) 60 | with type 'a t := 'a Deferred1.t 61 | -------------------------------------------------------------------------------- /src/deferred_queue.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | module List = Deferred_list 4 | 5 | (* We implement all of the [Queue] operations by converting the queue to a list and then 6 | using the corresponding [List] operation. We use lists rather than arrays because 7 | arrays longer than a certain length are allocated in the major heap, which can cause 8 | unnecessary promotion of the elements in the queue. Also, when one is folding or 9 | iterating over an array, the entire array must be kept alive. When folding or 10 | iterating over a list, only the remaining tail of the list is kept alive. So, using 11 | arrays rather than lists would increase the live-space needed by the program. *) 12 | 13 | let foldi t ~init ~f = List.foldi (Queue.to_list t) ~init ~f 14 | let fold t ~init ~f = List.fold (Queue.to_list t) ~init ~f 15 | 16 | let all t = List.all (Queue.to_list t) >>| Queue.of_list 17 | let all_unit t = List.all_unit (Queue.to_list t) 18 | 19 | let iter ?how t ~f = List.iter ?how (Queue.to_list t) ~f 20 | let iteri ?how t ~f = List.iteri ?how (Queue.to_list t) ~f 21 | 22 | let map ?how t ~f = List.map ?how (Queue.to_list t) ~f >>| Queue.of_list 23 | let mapi ?how t ~f = List.mapi ?how (Queue.to_list t) ~f >>| Queue.of_list 24 | 25 | let init ?how n ~f = List.init ?how n ~f >>| Queue.of_list 26 | 27 | let filter ?how t ~f = List.filter ?how (Queue.to_list t) ~f >>| Queue.of_list 28 | let filteri ?how t ~f = List.filteri ?how (Queue.to_list t) ~f >>| Queue.of_list 29 | 30 | let filter_map ?how t ~f = List.filter_map ?how (Queue.to_list t) ~f >>| Queue.of_list 31 | let filter_mapi ?how t ~f = List.filter_mapi ?how (Queue.to_list t) ~f >>| Queue.of_list 32 | 33 | let concat_map ?how t ~f = 34 | List.concat_map ?how (Queue.to_list t) ~f:(fun x -> f x >>| Queue.to_list) 35 | >>| Queue.of_list 36 | let concat_mapi ?how t ~f = 37 | List.concat_mapi ?how (Queue.to_list t) ~f:(fun i x -> f i x >>| Queue.to_list) 38 | >>| Queue.of_list 39 | 40 | let find_map t ~f = List.find_map (Queue.to_list t) ~f 41 | let find_mapi t ~f = List.find_mapi (Queue.to_list t) ~f 42 | 43 | let find t ~f = List.find (Queue.to_list t) ~f 44 | let findi t ~f = List.findi (Queue.to_list t) ~f 45 | 46 | let for_all t ~f = List.for_all (Queue.to_list t) ~f 47 | let for_alli t ~f = List.for_alli (Queue.to_list t) ~f 48 | 49 | let exists t ~f = List.exists (Queue.to_list t) ~f 50 | let existsi t ~f = List.existsi (Queue.to_list t) ~f 51 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/monitor0.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Import 3 | 4 | let debug = Debug.monitor 5 | 6 | type t = Types.Monitor.t = 7 | { name : Info.t 8 | ; here : Source_code_position.t option 9 | ; id : int 10 | ; parent : t option 11 | ; mutable next_error : exn Types.Ivar.t 12 | (* [Monitor.send_exn] schedules a job for each element of [handlers_for_all_errors]. *) 13 | ; mutable handlers_for_all_errors : (Types.Execution_context.t * (exn -> unit)) Bag.t 14 | (* [Monitor.send_exn] extends each tail in [tails_for_all_errors]. *) 15 | ; mutable tails_for_all_errors : exn Types.Tail.t list 16 | ; mutable has_seen_error : bool 17 | ; mutable is_detached : bool } 18 | [@@deriving fields] 19 | 20 | module Pretty = struct 21 | type one = 22 | { name : Info.t 23 | ; here : Source_code_position.t option 24 | ; id : int 25 | ; has_seen_error : bool 26 | ; is_detached : bool } 27 | [@@deriving sexp_of] 28 | 29 | type t = one list 30 | [@@deriving sexp_of] 31 | end 32 | 33 | let to_pretty = 34 | let rec loop 35 | { name; here; id; parent; has_seen_error; is_detached 36 | ; next_error = _ 37 | ; handlers_for_all_errors = _ 38 | ; tails_for_all_errors = _ } 39 | ac = 40 | let ac = 41 | { Pretty. name; here; id; has_seen_error; is_detached } :: ac 42 | in 43 | match parent with 44 | | None -> List.rev ac 45 | | Some t -> loop t ac 46 | in 47 | fun t -> loop t []; 48 | ;; 49 | 50 | let sexp_of_t t = Pretty.sexp_of_t (to_pretty t) 51 | 52 | let next_id = 53 | let r = ref 0 in 54 | fun () -> incr r; !r 55 | ;; 56 | 57 | let create_with_parent ?here ?info ?name parent = 58 | let id = next_id () in 59 | let name = 60 | match info, name with 61 | | Some i, None -> i 62 | | Some i, Some s -> Info.tag i ~tag:s 63 | | None , Some s -> Info.of_string s 64 | | None , None -> Info.create "id" id [%sexp_of: int] 65 | in 66 | let t = 67 | { name; here; parent 68 | ; id 69 | ; next_error = { cell = Empty } 70 | ; handlers_for_all_errors = Bag.create () 71 | ; tails_for_all_errors = [] 72 | ; has_seen_error = false 73 | ; is_detached = false } 74 | in 75 | if debug then (Debug.log "created monitor" t [%sexp_of: t]); 76 | t 77 | ;; 78 | 79 | let main = create_with_parent ~name:"main" None 80 | -------------------------------------------------------------------------------- /src/deferred0.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Ivar = Ivar0 5 | 6 | module Handler = Ivar.Handler 7 | 8 | (* Deferreds present a covariant view of ivars. We could actually implement deferreds 9 | using a record of closures, as in the [essence_of_deferred] record below, for which the 10 | OCaml type checker can infer covariance. However, doing so would make [Ivar.read] very 11 | costly, because it would have to allocate lots of closures and a record. Instead of 12 | doing this, we make deferreds an abstract covariant type, which concretely is just the 13 | ivar, and use [Obj.magic] to convert back and forth between a deferred and its concrete 14 | representation as an ivar. This [Obj.magic] is safe because the representation is 15 | always just an ivar, and the covariance follows from the fact that all the deferred 16 | operations are equivalent to those implemented directly on top of the 17 | [essence_of_deferred]. 18 | 19 | {[ 20 | type (+'a, 'execution_context) essence_of_deferred = 21 | { peek : unit -> 'a option 22 | ; is_determined : unit -> bool 23 | ; upon : ('a -> unit) -> unit 24 | ; upon' : ('a -> unit) -> Unregister.t 25 | ; install_removable_handler : ('a, 'execution_context) Raw_handler.t -> Unregister.t; } ]} *) 26 | 27 | type +'a t = 'a Types.Deferred.t (* the abstract covariant type, equivalent to ivar *) 28 | 29 | type 'a deferred = 'a t 30 | 31 | let of_ivar (type a) (ivar : a Ivar.t) = (Obj.magic ivar : a t) 32 | 33 | let to_ivar (type a) t = (Obj.magic (t : a t) : a Ivar.t) 34 | 35 | let invariant invariant_a t = Ivar.invariant invariant_a (to_ivar t) 36 | 37 | let sexp_of_t sexp_of_a t = Ivar.sexp_of_t sexp_of_a (to_ivar t) 38 | 39 | let peek t = Ivar.peek (to_ivar t) 40 | 41 | let return a = of_ivar (Ivar.create_full a) 42 | 43 | let is_determined t = Ivar.is_full (to_ivar t) 44 | 45 | let value_exn t = 46 | Ivar.value (to_ivar t) 47 | ~if_empty_then_failwith:"Deferred.value_exn called on undetermined deferred" 48 | ;; 49 | 50 | let upon t f = Ivar.upon (to_ivar t) f 51 | 52 | let create f = 53 | let result = Ivar.create () in 54 | f result; 55 | of_ivar result; 56 | ;; 57 | 58 | (* don't use [create] here as it would allocate one more closure *) 59 | let bind t ~f = 60 | let bind_result = Ivar.create () in 61 | upon t (fun a -> Ivar.connect ~bind_result ~bind_rhs:(to_ivar (f a))); 62 | of_ivar bind_result 63 | ;; 64 | 65 | let add_handler t f execution_context = 66 | Ivar.add_handler (to_ivar t) f execution_context 67 | ;; 68 | 69 | let remove_handler t h = Ivar.remove_handler (to_ivar t) h 70 | -------------------------------------------------------------------------------- /src/async_invariant_intf.ml: -------------------------------------------------------------------------------- 1 | (** This module defines signatures that extend [Core_kernel.Invariant] with an [Async] 2 | submodule for invariants that use async computation and return [unit Deferred.t]. *) 3 | 4 | open! Core_kernel 5 | open! Import 6 | 7 | module Async = struct 8 | type 'a t = 'a -> unit Deferred.t 9 | 10 | type 'a inv = 'a t 11 | 12 | module type S = sig 13 | type t 14 | val invariant : t inv 15 | end 16 | 17 | module type S1 = sig 18 | type 'a t 19 | val invariant : 'a inv -> 'a t inv 20 | end 21 | 22 | module type S2 = sig 23 | type ('a, 'b) t 24 | val invariant : 'a inv -> 'b inv -> ('a, 'b) t inv 25 | end 26 | 27 | module type S3 = sig 28 | type ('a, 'b, 'c) t 29 | val invariant : 'a inv -> 'b inv -> 'c inv -> ('a, 'b, 'c) t inv 30 | end 31 | end 32 | 33 | module type Async_invariant = sig 34 | 35 | include module type of Core_kernel.Invariant 36 | 37 | module Async : sig 38 | open Async 39 | 40 | type nonrec 'a t = 'a Async.t 41 | 42 | module type S = S 43 | module type S1 = S1 44 | module type S2 = S2 45 | module type S3 = S3 46 | 47 | val invariant 48 | : Source_code_position.t 49 | -> 'a 50 | -> ('a -> Sexp.t) 51 | -> (unit -> unit Deferred.t) 52 | -> unit Deferred.t 53 | 54 | (** [check_field] can be used to check record fields when using [[@@deriving fields]]. 55 | Idiomatic usage looks like: 56 | 57 | {[ 58 | type t = { foo : Foo.t ; bar : Bar.t } 59 | [@@deriving fields] 60 | 61 | let invariant t = 62 | Invariant.Async.invariant [%here] t [%sexp_of: t] (fun () -> 63 | let check inv = Invariant.Async.check_field t inv in 64 | Fields.fold ~init:(return ()) 65 | ~foo: (check Foo.invariant) 66 | ~bar: (check Bar.invariant) ]} 67 | 68 | When some fields have synchronous invariants, or do not need to be checked, it 69 | may be useful to define a second wrapper around [check_field]: 70 | 71 | {[ 72 | type t = { foo : Foo.t ; bar : Bar.t ; quux : Quux.t } 73 | [@@deriving fields] 74 | 75 | let invariant t = 76 | Invariant.Async.invariant [%here] t [%sexp_of: t] (fun () -> 77 | let check' inv = Invariant.Async.check_field t inv in 78 | let check inv = check' (fun x -> inv x; return ()) in 79 | Fields.fold ~init:(return ()) 80 | ~foo: (check' Foo.invariant) 81 | ~bar: (check Bar.invariant) 82 | ~quux: (check ignore) ]} *) 83 | val check_field : 'a -> 'b t -> unit Deferred.t -> ('a, 'b) Field.t -> unit Deferred.t 84 | end 85 | end 86 | -------------------------------------------------------------------------------- /src/monad_sequence.ml: -------------------------------------------------------------------------------- 1 | (** [Monad_sequence.S] is a generic interface specifying functions that deal with a 2 | container and a monad. It is specialized to the [Deferred] monad and used with 3 | various containers in modules [Deferred.Array], [Deferred.List], [Deferred.Queue], and 4 | [Deferred.Sequence]. The [Monad_sequence.how] type specifies the parallelism of 5 | container iterators. *) 6 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | type how = 11 | [ `Parallel (** like [`Max_concurrent_jobs Int.max_value] *) 12 | | `Sequential (** like [`Max_concurrent_jobs 1] *) 13 | | `Max_concurrent_jobs of int ] 14 | [@@deriving sexp_of] 15 | 16 | module type S = sig 17 | type 'a monad 18 | type 'a t 19 | 20 | val foldi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b monad) -> 'b monad 21 | val fold : 'a t -> init:'b -> f:( 'b -> 'a -> 'b monad) -> 'b monad 22 | 23 | val find : 'a t -> f:( 'a -> bool monad) -> 'a option monad 24 | val findi : 'a t -> f:(int -> 'a -> bool monad) -> (int * 'a) option monad 25 | val find_map : 'a t -> f:( 'a -> 'b option monad) -> 'b option monad 26 | val find_mapi: 'a t -> f:(int -> 'a -> 'b option monad) -> 'b option monad 27 | 28 | val exists : 'a t -> f:( 'a -> bool monad) -> bool monad 29 | val existsi : 'a t -> f:(int -> 'a -> bool monad) -> bool monad 30 | val for_all : 'a t -> f:( 'a -> bool monad) -> bool monad 31 | val for_alli: 'a t -> f:(int -> 'a -> bool monad) -> bool monad 32 | 33 | val all : 'a monad t -> 'a t monad 34 | val all_unit : unit monad t -> unit monad 35 | 36 | (** {2 Deferred iterators} 37 | 38 | In the following, the default [how] is [`Sequential] *) 39 | 40 | val init : ?how:how -> int -> f:(int -> 'a monad) -> 'a t monad 41 | val iter : ?how:how -> 'a t -> f:( 'a -> unit monad) -> unit monad 42 | val iteri : ?how:how -> 'a t -> f:(int -> 'a -> unit monad) -> unit monad 43 | val map : ?how:how -> 'a t -> f:( 'a -> 'b monad) -> 'b t monad 44 | val mapi : ?how:how -> 'a t -> f:(int -> 'a -> 'b monad) -> 'b t monad 45 | val filter : ?how:how -> 'a t -> f:( 'a -> bool monad) -> 'a t monad 46 | val filteri : ?how:how -> 'a t -> f:(int -> 'a -> bool monad) -> 'a t monad 47 | val filter_map : ?how:how -> 'a t -> f:( 'a -> 'b option monad) -> 'b t monad 48 | val filter_mapi: ?how:how -> 'a t -> f:(int -> 'a -> 'b option monad) -> 'b t monad 49 | val concat_map : ?how:how -> 'a t -> f:( 'a -> 'b t monad) -> 'b t monad 50 | val concat_mapi: ?how:how -> 'a t -> f:(int -> 'a -> 'b t monad) -> 'b t monad 51 | end 52 | -------------------------------------------------------------------------------- /src/lazy_deferred.mli: -------------------------------------------------------------------------------- 1 | (** A delayed computation that can produce a deferred. 2 | 3 | Nothing happens with a lazy deferred unless one [force]s it. Forcing a lazy deferred 4 | starts the computation, which will eventually cause the deferred to become determined. 5 | As usual with laziness, multiply forcing a lazy deferred is no different than forcing 6 | it a single time. 7 | 8 | Exceptions (both synchronous and asynchronous) raised by a delayed computation are 9 | returned by [force] ([wait], [peek], etc.), or will be raised to the monitor in effect 10 | when [force_exn] ([wait_exn], [peek_exn], etc.) was called. 11 | 12 | The type is not exposed nor defined as ['a Deferred.t Lazy.t] or ['a Or_error.t 13 | Deferred.t Lazy.t], because there is a difference in power with these types. Any 14 | value of type ['a Deferred.t Lazy.t] would mishandle asynchronous exceptions in the 15 | computation of ['a]. For instance, the following code blocks forever regardless of 16 | how [v] is defined: 17 | 18 | {[ 19 | let v : Nothing.t Deferred.t Lazy.t = lazy (return "" >>| failwith) in 20 | let%bind _ = try_with (fun () -> force v) in 21 | let%bind _ = try_with (fun () -> force v) in 22 | ]} 23 | 24 | There is no [val of_lazy : 'a Deferred.t Lazy.t -> 'a t] because of the difference 25 | in power. 26 | 27 | See also [Deferred.Memo.unit], if you only are interested in [create] and [force]. *) 28 | 29 | open! Core_kernel 30 | 31 | type 'a t 32 | 33 | (** [create f] creates a new lazy deferred that will call [f] when it is forced. *) 34 | val create : (unit -> 'a Deferred.t) -> 'a t 35 | 36 | (** [force t] forces evaluation of [t] and returns a deferred that becomes determined 37 | when the deferred computation becomes determined or raises. *) 38 | val force : 'a t -> 'a Or_error.t Deferred.t 39 | val force_exn : 'a t -> 'a Deferred.t 40 | 41 | (** [wait t] and [wait_exn t] waits for [t] to be forced. If no one ever calls 42 | [force t], they will wait forever. *) 43 | val wait : 'a t -> 'a Or_error.t Deferred.t 44 | val wait_exn : 'a t -> 'a Deferred.t 45 | 46 | (** [bind t f] in the lazy-deferred monad creates a computation that, when forced, will 47 | force [t], apply [f] to the result, and then force the result of that. *) 48 | include Monad with type 'a t := 'a t 49 | 50 | (** [bind'] differs from [bind] in that the supplied function produces an ['a Deferred.t] 51 | rather than an ['a t]. *) 52 | val bind' : 'a t -> ('a -> 'b Deferred.t) -> 'b t 53 | 54 | (** Read-only operations. *) 55 | 56 | (** [peek t = Deferred.peek (wait t)] *) 57 | val peek : 'a t -> 'a Or_error.t option 58 | val peek_exn : 'a t -> 'a option 59 | 60 | val is_determined : _ t -> bool 61 | 62 | val is_forced : _ t -> bool 63 | -------------------------------------------------------------------------------- /src/deferred_map.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | 4 | module Deferred = Deferred1 5 | module List = Deferred_list 6 | 7 | type ('a, 'b, 'c) t = ('a, 'b, 'c) Map.t 8 | 9 | let change t k ~f = 10 | let%map opt = f (Map.find t k) in 11 | Map.change t k ~f:(fun _ -> opt) 12 | ;; 13 | 14 | let update t k ~f = 15 | let%map data = f (Map.find t k) in 16 | Map.set t ~key:k ~data 17 | ;; 18 | 19 | let iter_keys ?how t ~f = 20 | List.iter ?how (Map.keys t) ~f 21 | ;; 22 | 23 | let iter ?how t ~f = 24 | List.iter ?how (Map.data t) ~f 25 | ;; 26 | 27 | let iteri ?how t ~f = 28 | List.iter ?how (Map.to_alist t) ~f:(fun (key, data) -> f ~key ~data) 29 | ;; 30 | 31 | let fold t ~init ~f = 32 | let alist_in_increasing_key_order = 33 | Map.fold_right t ~init:[] ~f:(fun ~key ~data alist -> (key, data) :: alist) 34 | in 35 | List.fold alist_in_increasing_key_order ~init 36 | ~f:(fun ac (key, data) -> f ~key ~data ac) 37 | ;; 38 | 39 | let fold_right t ~init ~f = 40 | let alist_in_decreasing_key_order = 41 | Map.fold t ~init:[] ~f:(fun ~key ~data alist -> (key, data) :: alist) 42 | in 43 | List.fold alist_in_decreasing_key_order ~init 44 | ~f:(fun ac (key, data) -> f ~key ~data ac) 45 | ;; 46 | 47 | module Job = struct 48 | type ('a, 'b, 'c) t = 49 | { key : 'a 50 | ; data : 'b 51 | ; mutable result : 'c option } 52 | [@@deriving fields] 53 | end 54 | 55 | let filter_mapi ?how t ~f = 56 | let jobs = ref [] in 57 | let job_map = 58 | Map.mapi t ~f:(fun ~key ~data -> 59 | let job = { Job. key; data; result = None } in 60 | jobs := job :: !jobs; 61 | job) 62 | in 63 | let%map () = 64 | List.iter ?how !jobs ~f:(function { Job. key; data; result=_ } as job -> 65 | let%map x = f ~key ~data in 66 | job.result <- x) 67 | in 68 | Map.filter_map job_map ~f:Job.result 69 | ;; 70 | 71 | let filter_map ?how t ~f = filter_mapi ?how t ~f:(fun ~key:_ ~data -> f data) 72 | 73 | let filter_keys ?how t ~f = 74 | filter_mapi ?how t ~f:(fun ~key ~data -> 75 | let%map b = f key in 76 | if b then (Some data) else None) 77 | ;; 78 | 79 | let filter ?how t ~f = 80 | filter_mapi ?how t ~f:(fun ~key:_ ~data -> 81 | let%map b = f data in 82 | if b then (Some data) else None) 83 | ;; 84 | 85 | let filteri ?how t ~f = 86 | filter_mapi ?how t ~f:(fun ~key ~data -> 87 | let%map b = f ~key ~data in 88 | if b then (Some data) else None) 89 | ;; 90 | 91 | let mapi ?how t ~f = 92 | filter_mapi ?how t ~f:(fun ~key ~data -> let%map z = f ~key ~data in Some z) 93 | ;; 94 | 95 | let map ?how t ~f = mapi ?how t ~f:(fun ~key:_ ~data -> f data) 96 | 97 | let merge ?how t1 t2 ~f = 98 | filter_map ?how (Map.merge t1 t2 ~f:(fun ~key z -> Some (fun () -> f ~key z))) 99 | ~f:(fun thunk -> thunk ()) 100 | ;; 101 | 102 | let all t = map t ~f:Fn.id 103 | -------------------------------------------------------------------------------- /src/deferred_list.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | 4 | module Deferred = Deferred1 5 | 6 | let foldi t ~init ~f = 7 | Deferred.create 8 | (fun result -> 9 | let rec loop t i b = 10 | match t with 11 | | [] -> Ivar.fill result b 12 | | x :: xs -> f i b x >>> fun b -> loop xs (i + 1) b 13 | in 14 | loop t 0 init) 15 | ;; 16 | 17 | let fold t ~init ~f = foldi t ~init ~f:(fun _ a x -> f a x) 18 | 19 | let seqmapi t ~f = 20 | foldi t ~init:[] ~f:(fun i bs a -> let%map b = f i a in b :: bs) 21 | >>| List.rev 22 | ;; 23 | 24 | let all ds = seqmapi ds ~f:(fun _ x -> x) 25 | 26 | let all_unit ds = Deferred.ignore (fold ds ~init:() ~f:(fun () d -> d)) 27 | 28 | let iteri ?(how = `Sequential) t ~f = 29 | match how with 30 | | `Parallel | `Max_concurrent_jobs _ as how -> 31 | all_unit (List.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 32 | | `Sequential -> foldi t ~init:() ~f:(fun i () x -> f i x) 33 | ;; 34 | 35 | let mapi ?(how = `Sequential) t ~f = 36 | match how with 37 | | `Parallel | `Max_concurrent_jobs _ as how -> 38 | all (List.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 39 | | `Sequential -> seqmapi t ~f 40 | ;; 41 | 42 | let filteri ?how t ~f = 43 | let%map bools = mapi t ?how ~f in 44 | List.rev (List.fold2_exn t bools ~init:[] 45 | ~f:(fun ac x b -> if b then (x :: ac) else ac)) 46 | ;; 47 | 48 | let filter_mapi ?how t ~f = mapi t ?how ~f >>| List.filter_opt 49 | let concat_mapi ?how t ~f = mapi t ?how ~f >>| List.concat 50 | 51 | let find_mapi t ~f = 52 | let rec find_mapi t ~f i = 53 | match t with 54 | | [] -> return None 55 | | hd :: tl -> 56 | match%bind f i hd with 57 | | None -> find_mapi tl ~f (i+1) 58 | | Some _ as some -> return some 59 | in 60 | find_mapi t ~f 0 61 | ;; 62 | 63 | let findi t ~f = 64 | find_mapi t ~f:(fun i elt -> 65 | let%map b = f i elt in 66 | if b 67 | then (Some (i,elt)) 68 | else None) 69 | ;; 70 | 71 | let find t ~f = 72 | find_mapi t ~f:(fun _ elt -> 73 | let%map b = f elt in 74 | if b 75 | then (Some elt) 76 | else None) 77 | ;; 78 | 79 | let existsi t ~f = 80 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if b then (Some ()) else None) with 81 | | Some () -> true 82 | | None -> false 83 | 84 | let for_alli t ~f = 85 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if not b then (Some ()) else None) with 86 | | Some () -> false 87 | | None -> true 88 | 89 | let iter ?how t ~f = iteri ?how t ~f:(fun _ a -> f a) 90 | let map ?how t ~f = mapi ?how t ~f:(fun _ a -> f a) 91 | let filter ?how t ~f = filteri ?how t ~f:(fun _ a -> f a) 92 | let filter_map ?how t ~f = filter_mapi ?how t ~f:(fun _ a -> f a) 93 | let concat_map ?how t ~f = concat_mapi ?how t ~f:(fun _ a -> f a) 94 | let find_map t ~f = find_mapi t ~f:(fun _ a -> f a) 95 | let exists t ~f = existsi t ~f:(fun _ a -> f a) 96 | let for_all t ~f = for_alli t ~f:(fun _ a -> f a) 97 | 98 | let init ?how n ~f = map ?how (List.init n ~f:Fn.id) ~f 99 | -------------------------------------------------------------------------------- /src/deferred_array.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | 4 | module Deferred = Deferred1 5 | 6 | let foldi t ~init ~f = 7 | Deferred.create 8 | (fun result -> 9 | let rec loop i b = 10 | if i = Array.length t 11 | then (Ivar.fill result b) 12 | else (f i b t.(i) >>> fun b -> loop (i + 1) b) 13 | in 14 | loop 0 init) 15 | ;; 16 | 17 | let fold t ~init ~f = foldi t ~init ~f:(fun _ a x -> f a x) 18 | 19 | let seqmapi t ~f = 20 | let%map bs = foldi t ~init:[] ~f:(fun i bs a -> f i a >>| fun b -> b :: bs) in 21 | Array.of_list (Core_kernel.List.rev bs) 22 | ;; 23 | 24 | let all ds = seqmapi ds ~f:(fun _ x -> x) 25 | let all_unit ds = Deferred.ignore (fold ds ~init:() ~f:(fun () d -> d)) 26 | 27 | let iteri ?(how = `Sequential) t ~f = 28 | match how with 29 | | `Parallel | `Max_concurrent_jobs _ as how -> 30 | all_unit (Array.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 31 | | `Sequential -> foldi t ~init:() ~f:(fun i () x -> f i x) 32 | ;; 33 | 34 | let mapi ?(how = `Sequential) t ~f = 35 | match how with 36 | | `Parallel | `Max_concurrent_jobs _ as how -> 37 | all (Array.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 38 | | `Sequential -> seqmapi t ~f 39 | ;; 40 | 41 | let filteri ?how t ~f = 42 | let%map bools = mapi t ?how ~f in 43 | Array.of_list_rev 44 | (Array.fold2_exn t bools ~init:[] ~f:(fun ac x b -> 45 | if b then (x :: ac) else ac)) 46 | ;; 47 | 48 | let filter_mapi ?how t ~f = mapi t ?how ~f >>| Array.filter_opt 49 | ;; 50 | 51 | let concat_mapi ?how t ~f = 52 | let%map t = mapi t ?how ~f in 53 | Array.concat (Array.to_list t) 54 | ;; 55 | 56 | let find_mapi t ~f = 57 | let rec aux i = 58 | if i = Array.length t 59 | then (return None) 60 | else ( 61 | match%bind f i t.(i) with 62 | | None -> aux (i + 1) 63 | | Some _ as some -> return some) 64 | in 65 | aux 0 66 | ;; 67 | 68 | let findi t ~f = 69 | find_mapi t ~f:(fun i elt -> 70 | let%map b = f i elt in 71 | if b 72 | then (Some (i,elt)) 73 | else None) 74 | ;; 75 | 76 | let find t ~f = 77 | find_mapi t ~f:(fun _ elt -> 78 | let%map b = f elt in 79 | if b 80 | then (Some elt) 81 | else None) 82 | ;; 83 | 84 | let existsi t ~f = 85 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if b then (Some ()) else None) with 86 | | Some () -> true 87 | | None -> false 88 | 89 | let for_alli t ~f = 90 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if not b then (Some ()) else None) with 91 | | Some () -> false 92 | | None -> true 93 | 94 | let iter ?how t ~f = iteri ?how t ~f:(fun _ a -> f a) 95 | let map ?how t ~f = mapi ?how t ~f:(fun _ a -> f a) 96 | let filter_map ?how t ~f = filter_mapi ?how t ~f:(fun _ a -> f a) 97 | let filter ?how t ~f = filteri ?how t ~f:(fun _ a -> f a) 98 | let concat_map ?how t ~f = concat_mapi ?how t ~f:(fun _ a -> f a) 99 | let find_map t ~f = find_mapi t ~f:(fun _ a -> f a) 100 | let exists t ~f = existsi t ~f:(fun _ a -> f a) 101 | let for_all t ~f = for_alli t ~f:(fun _ a -> f a) 102 | 103 | let init ?how n ~f = map ?how (Array.init n ~f:Fn.id) ~f 104 | -------------------------------------------------------------------------------- /src/async_gc.mli: -------------------------------------------------------------------------------- 1 | (** Async's analog of [Core_kernel.Gc]. *) 2 | 3 | open! Core_kernel 4 | 5 | (** We remove the [Expert] module, which has functions that are superseded by 6 | Async-friendly functions below. *) 7 | include module type of Core_kernel.Gc 8 | with module Expert := Core_kernel.Gc.Expert 9 | 10 | (** [add_finalizer b f] ensures that [f] runs after [b] becomes unreachable. [f b] will 11 | run in its own Async job. If [f] raises, the unhandled exception will be raised to 12 | the monitor that called [add_finalizer b f]. 13 | 14 | The OCaml runtime only supports finalizers on heap blocks, hence [add_finalizer] 15 | requires [b : _ Heap_block.t]. 16 | 17 | The runtime essentially maintains a set of finalizer pairs: 18 | 19 | {[ 20 | 'a Heap_block.t * ('a Heap_block.t -> unit) 21 | ]} 22 | 23 | Each call to [add_finalizer] adds a new pair to the set. It is allowed for many pairs 24 | to have the same heap block, the same function, or both. Each pair is a distinct 25 | element of the set. 26 | 27 | After a garbage collection determines that a heap block [b] is unreachable, it removes 28 | from the set of finalizers all finalizer pairs [(b, f)] whose block is [b], and then 29 | and runs [f b] for all such pairs. Thus, a finalizer registered with [add_finalizer] 30 | will run at most once. 31 | 32 | In a finalizer pair [(b, f)], it is a mistake for the closure of [f] to reference 33 | (directly or indirectly) [b] -- [f] should only access [b] via its argument. 34 | Referring to [b] in any other way will cause [b] to be kept alive forever, since [f] 35 | itself is a root of garbage collection, and can itself only be collected after the 36 | pair [(b, f)] is removed from the set of finalizers. 37 | 38 | The [f] function can use all features of OCaml and Async, since it runs as an ordinary 39 | Async job. [f] can even make [b] reachable again. It can even call [add_finalizer] 40 | on [b] or other values to register other finalizer functions. *) 41 | val add_finalizer : 'a Heap_block.t -> ('a Heap_block.t -> unit) -> unit 42 | 43 | (** [add_finalizer_exn b f] is like {{!add_finalizer}[add_finalizer]}, but will raise if 44 | [b] is not a heap block. *) 45 | val add_finalizer_exn : 'a -> ('a -> unit) -> unit 46 | 47 | (** Same as {{!add_finalizer}[add_finalizer]} except that the function is not called until 48 | the value has become unreachable for the last time. This means that the finalization 49 | function does not receive the value as an argument. Every weak pointer and ephemeron 50 | that contained this value as key or data is unset before running the finalization 51 | function. *) 52 | val add_finalizer_last : 'a Heap_block.t -> (unit -> unit) -> unit 53 | val add_finalizer_last_exn : 'a -> (unit -> unit) -> unit 54 | 55 | (** A GC alarm calls a user function after the end of each major GC cycle. *) 56 | module Alarm : sig 57 | 58 | type t [@@deriving sexp_of] 59 | 60 | (** [create f] arranges for [f] to be called after the end of each major GC cycle, 61 | starting with the current cycle or the next one. [f] will be run in the monitor 62 | that [create] was called in. *) 63 | val create : (unit -> unit) -> t 64 | 65 | (** [delete t] will stop the calls to the function associated with [t]. Calling [delete 66 | t] again has no effect. *) 67 | val delete : t -> unit 68 | end 69 | -------------------------------------------------------------------------------- /src/mvar.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | open! Deferred_std 4 | 5 | type ('a, 'phantom) t = 6 | { current_value : 'a Moption.t 7 | ; taken : (unit, read_write) Bvar.t 8 | ; mutable value_available : unit Ivar.t } 9 | [@@deriving fields, sexp_of] 10 | 11 | let value_available t = Ivar.read t.value_available 12 | 13 | let is_empty t = Moption.is_none t.current_value 14 | 15 | let invariant invariant_a _ (t : _ t) = 16 | Invariant.invariant [%here] t [%sexp_of: (_, _) t] (fun () -> 17 | let check f = Invariant.check_field t f in 18 | Fields.iter 19 | ~current_value:(check (Moption.invariant invariant_a)) 20 | ~taken:(check (Bvar.invariant Unit.invariant ignore)) 21 | ~value_available:(check (fun value_available -> 22 | [%test_result: bool] (Ivar.is_full value_available) 23 | ~expect:(Moption.is_some t.current_value)))) 24 | ;; 25 | 26 | let peek t = Moption.get t.current_value 27 | 28 | let peek_exn t = 29 | if is_empty t then (raise_s [%message "Mvar.peek_exn called on empty mvar"]); 30 | Moption.get_some_exn t.current_value 31 | ;; 32 | 33 | let sexp_of_t sexp_of_a _ t = [%sexp (peek t : a option)] 34 | 35 | module Read_write = struct 36 | type nonrec 'a t = ('a, read_write) t [@@deriving sexp_of] 37 | 38 | let invariant invariant_a t = invariant invariant_a ignore t 39 | end 40 | 41 | module Read_only = struct 42 | type nonrec 'a t = ('a, read) t [@@deriving sexp_of] 43 | 44 | let invariant invariant_a t = invariant invariant_a ignore t 45 | end 46 | 47 | let read_only (t : ('a, [> read] ) t) = (t :> ('a, read) t) 48 | let write_only (t : ('a, [> write]) t) = (t :> ('a, write) t) 49 | 50 | let create () = 51 | { current_value = Moption.create () 52 | ; taken = Bvar.create () 53 | ; value_available = Ivar.create () } 54 | ;; 55 | 56 | let take_nonempty t = 57 | assert (not (is_empty t)); 58 | let r = Moption.get_some_exn t.current_value in 59 | Moption.set_none t.current_value; 60 | Bvar.broadcast t.taken (); 61 | t.value_available <- Ivar.create (); 62 | r 63 | ;; 64 | 65 | let take_now_exn t = 66 | if is_empty t then (raise_s [%message "Mvar.take_exn called on empty mvar"]); 67 | take_nonempty t; 68 | ;; 69 | 70 | let take_now t = 71 | if not (is_empty t) 72 | then (Some (take_nonempty t)) 73 | else None 74 | ;; 75 | 76 | let rec take t = 77 | if not (is_empty t) 78 | then (return (take_nonempty t)) 79 | else ( 80 | let%bind () = value_available t in 81 | take t) 82 | ;; 83 | 84 | let set t v = 85 | Moption.set_some t.current_value v; 86 | Ivar.fill_if_empty t.value_available (); 87 | ;; 88 | 89 | let update t ~f = set t (f (peek t)) 90 | let update_exn t ~f = set t (f (peek_exn t)) 91 | 92 | let taken t = Bvar.wait t.taken 93 | 94 | let rec put t v = 95 | if is_empty t 96 | then ( 97 | set t v; 98 | return ()) 99 | else ( 100 | let%bind () = taken t in 101 | put t v) 102 | ;; 103 | 104 | let pipe_when_ready t = 105 | let (r, w) = Pipe.create () in 106 | let rec loop () = 107 | let%bind () = value_available t in 108 | if not (Pipe.is_closed w) 109 | then ( 110 | match take_now t with 111 | | None -> loop () 112 | | Some x -> 113 | let%bind () = Pipe.write w x in 114 | loop ()) 115 | else (return ()) 116 | in 117 | don't_wait_for(loop ()); 118 | r 119 | ;; 120 | -------------------------------------------------------------------------------- /src/async_kernel_config.mli: -------------------------------------------------------------------------------- 1 | (** Settings that globally affect the behavior of Async. 2 | 3 | These can be set by setting an environment variable, [ASYNC_CONFIG], to a sexp 4 | representation of the config. Also, setting [ASYNC_CONFIG] to an invalid sexp 5 | (e.g. the empty string), will cause your program to print to stderr a usage message 6 | describing how to configure [ASYNC_CONFIG], and exit nonzero. For example, the 7 | following shell command should print the usage message: 8 | 9 | {v 10 | ASYNC_CONFIG= foo.exe 11 | v} *) 12 | 13 | open! Core_kernel 14 | 15 | module Epoll_max_ready_events : Validated.S with type raw := int 16 | module Max_inter_cycle_timeout : Validated.S with type raw := Time_ns.Span.t 17 | module Min_inter_cycle_timeout : Validated.S with type raw := Time_ns.Span.t 18 | module Max_num_threads : Validated.S with type raw := int 19 | module Max_num_jobs_per_priority_per_cycle : Validated.S with type raw := int 20 | 21 | module Max_num_open_file_descrs : sig 22 | include Validated.S with type raw := int 23 | include Equal.S with type t := t 24 | 25 | val default : t 26 | end 27 | 28 | module Dump_core_on_job_delay : sig 29 | module How_to_dump : sig 30 | type t = Default | Call_abort | Call_gcore 31 | [@@deriving sexp] 32 | end 33 | 34 | type watch = 35 | { dump_if_delayed_by : Time_ns.Span.t 36 | ; how_to_dump : How_to_dump.t } 37 | [@@deriving sexp] 38 | 39 | type t = 40 | | Watch of watch 41 | | Do_not_watch 42 | [@@deriving sexp] 43 | end 44 | 45 | type t [@@deriving sexp_of] 46 | 47 | val t : t 48 | 49 | val environment_variable : string 50 | 51 | module Print_debug_messages_for : sig 52 | val clock : bool 53 | val fd : bool 54 | val file_descr_watcher : bool 55 | val finalizers : bool 56 | val interruptor : bool 57 | val monitor : bool 58 | val monitor_send_exn : bool 59 | val parallel : bool 60 | val reader : bool 61 | val scheduler : bool 62 | val shutdown : bool 63 | val thread_pool : bool 64 | val thread_safe : bool 65 | val writer : bool 66 | end 67 | 68 | module File_descr_watcher : sig 69 | type t = Epoll_if_timerfd | Epoll | Select [@@deriving sexp_of] 70 | end 71 | 72 | (** Documentation on these is in strings in config.ml, so it can be output in the 73 | help message. *) 74 | val abort_after_thread_pool_stuck_for : Time_ns.Span.t 75 | val check_invariants : bool 76 | val detect_invalid_access_from_thread : bool 77 | val dump_core_on_job_delay : Dump_core_on_job_delay.t 78 | val epoll_max_ready_events : Epoll_max_ready_events.t 79 | val file_descr_watcher : File_descr_watcher.t 80 | val max_inter_cycle_timeout : Max_inter_cycle_timeout.t 81 | val max_num_jobs_per_priority_per_cycle : Max_num_jobs_per_priority_per_cycle.t 82 | val max_num_open_file_descrs : Max_num_open_file_descrs.t 83 | val max_num_threads : Max_num_threads.t 84 | val min_inter_cycle_timeout : Min_inter_cycle_timeout.t 85 | val record_backtraces : bool 86 | val report_thread_pool_stuck_for : Time_ns.Span.t 87 | val timing_wheel_config : Timing_wheel_ns.Config.t 88 | 89 | val default_timing_wheel_config_for_word_size : Word_size.t -> Timing_wheel_ns.Config.t 90 | 91 | (** [!task_id] is used in debug messages. It is is set in [Async_unix] to include 92 | the thread and pid. *) 93 | val task_id : (unit -> Sexp.t) ref 94 | -------------------------------------------------------------------------------- /src/deferred_map.mli: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | 3 | module Deferred = Deferred1 4 | 5 | type ('a, 'b, 'c) t = ('a, 'b, 'c) Map.t 6 | 7 | val change 8 | : ('k, 'v, 'comparator) t 9 | -> 'k 10 | -> f:('v option -> 'v option Deferred.t) 11 | -> ('k, 'v, 'comparator) t Deferred.t 12 | 13 | val update 14 | : ('k, 'v, 'comparator) t 15 | -> 'k 16 | -> f:('v option -> 'v Deferred.t) 17 | -> ('k, 'v, 'comparator) t Deferred.t 18 | 19 | val iter_keys 20 | : ?how : Monad_sequence.how 21 | -> ('k, _, _) t 22 | -> f:('k -> unit Deferred.t) 23 | -> unit Deferred.t 24 | 25 | val iter 26 | : ?how : Monad_sequence.how 27 | -> (_, 'v, _) t 28 | -> f:('v -> unit Deferred.t) 29 | -> unit Deferred.t 30 | 31 | val iteri 32 | : ?how : Monad_sequence.how 33 | -> ('k, 'v, _) t 34 | -> f:(key:'k -> data:'v -> unit Deferred.t) 35 | -> unit Deferred.t 36 | 37 | val map 38 | : ?how : Monad_sequence.how 39 | -> ('k, 'v1, 'comparator) t 40 | -> f:('v1 -> 'v2 Deferred.t) 41 | -> ('k, 'v2, 'comparator) t Deferred.t 42 | 43 | val mapi 44 | : ?how : Monad_sequence.how 45 | -> ('k, 'v1, 'comparator) t 46 | -> f:(key:'k -> data:'v1 -> 'v2 Deferred.t) 47 | -> ('k, 'v2, 'comparator) t Deferred.t 48 | 49 | val fold 50 | : ('k, 'v, _) t 51 | -> init:'a 52 | -> f:(key:'k -> data:'v -> 'a -> 'a Deferred.t) 53 | -> 'a Deferred.t 54 | 55 | val fold_right 56 | : ('k, 'v, _) t 57 | -> init:'a 58 | -> f:(key:'k -> data:'v -> 'a -> 'a Deferred.t) 59 | -> 'a Deferred.t 60 | 61 | val filter_keys 62 | : ?how : Monad_sequence.how 63 | -> ('k, 'v, 'comparable) t 64 | -> f:('k -> bool Deferred.t) 65 | -> ('k, 'v, 'comparable) t Deferred.t 66 | 67 | val filter 68 | : ?how : Monad_sequence.how 69 | -> ('k, 'v, 'comparable) t 70 | -> f:('v -> bool Deferred.t) 71 | -> ('k, 'v, 'comparable) t Deferred.t 72 | 73 | val filteri 74 | : ?how : Monad_sequence.how 75 | -> ('k, 'v, 'comparable) t 76 | -> f:(key:'k -> data:'v -> bool Deferred.t) 77 | -> ('k, 'v, 'comparable) t Deferred.t 78 | 79 | val filter_map 80 | : ?how : Monad_sequence.how 81 | -> ('k, 'v1, 'comparable) t 82 | -> f:('v1 -> 'v2 option Deferred.t) 83 | -> ('k, 'v2, 'comparable) t Deferred.t 84 | 85 | val filter_mapi 86 | : ?how : Monad_sequence.how 87 | -> ('k, 'v1, 'comparable) t 88 | -> f:(key:'k -> data:'v1 -> 'v2 option Deferred.t) 89 | -> ('k, 'v2, 'comparable) t Deferred.t 90 | 91 | (*_ {[ 92 | val compare 93 | : ('v -> 'v -> int Deferred.t) 94 | -> ('k, 'v, 'comparator) t 95 | -> ('k, 'v, 'comparator) t 96 | -> int Deferred.t 97 | 98 | val equal 99 | : ('v -> 'v -> bool Deferred.t) 100 | -> ('k, 'v, 'comparator) t 101 | -> ('k, 'v, 'comparator) t 102 | -> bool Deferred.t ]} *) 103 | 104 | val merge 105 | : ?how : Monad_sequence.how 106 | -> ('k, 'v1, 'comparator) t 107 | -> ('k, 'v2, 'comparator) t 108 | -> f:(key:'k 109 | -> [ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] 110 | -> 'v3 option Deferred.t) 111 | -> ('k, 'v3, 'comparator) t Deferred.t 112 | 113 | val all 114 | : ('k, 'v Deferred.t, 'comparator) t 115 | -> ('k, 'v , 'comparator) t Deferred.t 116 | 117 | 118 | (*_ {[ 119 | val fold_range_inclusive 120 | : ('k, 'v, 'comparator) t 121 | -> min:'k 122 | -> max:'k 123 | -> init:'a 124 | -> f:(key:'k -> data:'v -> 'a -> 'a Deferred.t) 125 | -> 'a Deferred.t 126 | 127 | val of_alist_fold 128 | : ('k * 'v1) list 129 | -> init:'v2 130 | -> f:('v2 -> 'v1 -> 'v2 Deferred.t) 131 | -> ('k, 'v2, 'comparator) t 132 | 133 | val of_alist_reduce 134 | : ('k * 'v) list 135 | -> f:('v -> 'v -> 'v Deferred.t) 136 | -> ('k, 'v, 'comparator) t ]} *) 137 | -------------------------------------------------------------------------------- /src/mvar.mli: -------------------------------------------------------------------------------- 1 | (** An [Mvar] is a mutable location that is either empty or contains a value. One can 2 | [put] or [set] the value, and wait on [value_available] for the location to be filled 3 | in either way. 4 | 5 | Having an [Mvar.Writer.t] gives the capability to mutate the mvar. 6 | 7 | The key difference between an [Mvar] and an {{!Async_kernel.Ivar}[Ivar]} is that an 8 | [Mvar] may be filled multiple times. 9 | 10 | This implementation of [Mvar] also allows one to replace the value without any 11 | guarantee that the reading side has seen it. This is useful in situations where 12 | last-value semantics are desired (e.g., you want to signal whenever a config file is 13 | updated, but only care about the most recent contents). 14 | 15 | An [Mvar] can also be used as a baton-passing mechanism between a producer and 16 | consumer. For instance, a producer reading from a socket and producing a set of 17 | deserialized messages can [put] the batch from a single read into an [Mvar] and can 18 | wait for [taken] to return as a pushback mechanism. The consumer meanwhile waits on 19 | [value_available]. This way the natural batch size is passed between the two 20 | sub-systems with minimal overhead. *) 21 | 22 | open! Core_kernel 23 | open! Import 24 | 25 | type ('a, -'phantom) t [@@deriving sexp_of] 26 | 27 | module Read_write : sig 28 | type nonrec 'a t = ('a, read_write) t [@@deriving sexp_of] 29 | 30 | include Invariant.S1 with type 'a t := 'a t 31 | end 32 | 33 | module Read_only : sig 34 | type nonrec 'a t = ('a, read) t [@@deriving sexp_of] 35 | 36 | include Invariant.S1 with type 'a t := 'a t 37 | end 38 | 39 | val create : unit -> 'a Read_write.t 40 | 41 | val is_empty : (_, _) t -> bool 42 | 43 | (** [put t a] waits until [is_empty t], and then does [set t a]. If there are multiple 44 | concurrent [put]s, there is no fairness guarantee (i.e., [put]s may happen out of 45 | order or may be starved). *) 46 | val put : ('a, [> write]) t -> 'a -> unit Deferred.t 47 | 48 | (** [set t a] sets the value in [t] to [a], even if [not (is_empty t)]. This is useful if 49 | you want takers to have last-value semantics. *) 50 | val set : ('a, [> write]) t -> 'a -> unit 51 | 52 | (** [update t ~f] applies [f] to the value in [t] and [set]s [t] to the result. This is 53 | useful if you want takers to have accumulated-value semantics. *) 54 | val update : ('a, read_write) t -> f:('a option -> 'a) -> unit 55 | 56 | (** [update_exn] is like [update], except it raises if [is_empty t]. *) 57 | val update_exn : ('a, read_write) t -> f:('a -> 'a) -> unit 58 | 59 | val read_only : ('a, [> read] ) t -> ('a, read) t 60 | val write_only : ('a, [> write]) t -> ('a, write) t 61 | 62 | (** [value_available t] returns a deferred [d] that becomes determined when a value is in 63 | [t]. [d] does not include the value in [t] because that value may change after [d] 64 | becomes determined and before a deferred bind on [d] gets to run. 65 | 66 | Repeated calls to [value_available t] will always return the same deferred until 67 | the [t] is filled. *) 68 | val value_available : (_, [> read]) t -> unit Deferred.t 69 | 70 | (** [take t] returns a deferred that, when [t] is filled, becomes determined with the 71 | value of [t] and and clears [t]. If there are multiple concurrent calls to [take] 72 | then only one of them will be fulfilled and the others will continue waiting on future 73 | values. There is no ordering guarantee for which [take] call will be filled first. *) 74 | val take : ('a, [> read]) t -> 'a Deferred.t 75 | 76 | (** [take_now] is an immediate form of [take]. *) 77 | val take_now : ('a, [> read]) t -> 'a option 78 | val take_now_exn : ('a, [> read]) t -> 'a 79 | 80 | (** [taken t] returns a deferred that is filled the next time [take] clears [t]. *) 81 | val taken : (_, [> write]) t -> unit Deferred.t 82 | 83 | (** [peek t] returns the value in [t] without clearing [t], or returns [None] is [is_empty 84 | t]. *) 85 | val peek : ('a, [> read]) t -> 'a option 86 | 87 | (** [peek_exn t] is like [peek], except it raises if [is_empty t]. *) 88 | val peek_exn : ('a, [> read]) t -> 'a 89 | 90 | (** [pipe_when_ready t] returns a pipe, then repeatedly takes a value from [t] and writes 91 | it to the pipe. After each write, [pipe_when_ready] waits for the pipe to be ready to 92 | accept another value before taking the next value. Once the pipe is closed, 93 | [pipe_when_ready] will no longer take values from [t]. *) 94 | val pipe_when_ready : ('a, [> read]) t -> 'a Pipe.Reader.t 95 | -------------------------------------------------------------------------------- /src/scheduler.mli: -------------------------------------------------------------------------------- 1 | (** Internal to Async -- see {!Async_unix.Scheduler} for the public API. *) 2 | 3 | open! Core_kernel 4 | open! Import 5 | 6 | module Deferred = Deferred1 7 | 8 | type t = Types.Scheduler.t [@@deriving sexp_of] 9 | 10 | val t : unit -> t 11 | 12 | include Invariant.S with type t := t 13 | 14 | val current_execution_context : t -> Execution_context.t 15 | val with_execution_context : t -> Execution_context.t -> f:(unit -> 'a) -> 'a 16 | val set_execution_context : t -> Execution_context.t -> unit 17 | 18 | val enqueue : t -> Execution_context.t -> ('a -> unit) -> 'a -> unit 19 | val create_job : t -> Execution_context.t -> ('a -> unit) -> 'a -> Job.t 20 | val enqueue_job : t -> Job.t -> free_job:bool -> unit 21 | 22 | val free_job : t -> Job.t -> unit 23 | 24 | val main_execution_context : Execution_context.t 25 | val cycle_start : t -> Time_ns.t 26 | val run_cycle : t -> unit 27 | val run_cycles_until_no_jobs_remain : unit -> unit 28 | val has_upcoming_event : t -> bool 29 | val next_upcoming_event : t -> Time_ns.t option 30 | val next_upcoming_event_exn : t -> Time_ns.t 31 | val event_precision : t -> Time_ns.Span.t 32 | val uncaught_exn : t -> Error.t option 33 | val uncaught_exn_unwrapped : t -> (Exn.t * Sexp.t) option 34 | val num_pending_jobs : t -> int 35 | val num_jobs_run : t -> int 36 | val map_cycle_times : t -> f:(Time_ns.Span.t -> 'a) -> 'a Async_stream.t 37 | val cycle_num_jobs : t -> int Async_stream.t 38 | val cycle_count : t -> int 39 | val max_num_jobs_per_priority_per_cycle : t -> int 40 | val set_max_num_jobs_per_priority_per_cycle : t -> int -> unit 41 | val set_check_access : t -> (unit -> unit) option -> unit 42 | val check_access : t -> unit 43 | val check_invariants : t -> bool 44 | val set_check_invariants : t -> bool -> unit 45 | val set_record_backtraces : t -> bool -> unit 46 | 47 | val run_every_cycle_start : t -> f:(unit -> unit) -> unit 48 | 49 | val long_cycles : t -> at_least : Time_ns.Span.t -> Time_ns.Span.t Async_stream.t 50 | 51 | val can_run_a_job : t -> bool 52 | 53 | val create_alarm : t -> (unit -> unit) -> Gc.Expert.Alarm.t 54 | 55 | val add_finalizer : t -> 'a Heap_block.t -> ('a Heap_block.t -> unit) -> unit 56 | val add_finalizer_exn : t -> 'a -> ('a -> unit) -> unit 57 | 58 | val add_finalizer_last : t -> 'a Heap_block.t -> (unit -> unit) -> unit 59 | val add_finalizer_last_exn : t -> 'a -> (unit -> unit) -> unit 60 | 61 | val set_thread_safe_external_job_hook : t -> (unit -> unit) -> unit 62 | 63 | val set_job_queued_hook : t -> (Priority.t -> unit) -> unit 64 | val set_event_added_hook : t -> (Time_ns.t -> unit) -> unit 65 | 66 | val set_on_start_of_cycle : t -> (unit -> unit) -> unit 67 | val set_on_end_of_cycle : t -> (unit -> unit) -> unit 68 | 69 | val thread_safe_enqueue_external_job 70 | : t -> Execution_context.t -> ('a -> unit) -> 'a -> unit 71 | 72 | val force_current_cycle_to_end : t -> unit 73 | 74 | type 'a with_options 75 | = ?monitor:Monitor.t 76 | -> ?priority:Priority.t 77 | -> 'a 78 | val within' : ((unit -> 'a Deferred.t) -> 'a Deferred.t) with_options 79 | val within : ((unit -> unit ) -> unit ) with_options 80 | val within_v : ((unit -> 'a ) -> 'a option ) with_options 81 | val schedule' : ((unit -> 'a Deferred.t) -> 'a Deferred.t) with_options 82 | val schedule : ((unit -> unit ) -> unit ) with_options 83 | 84 | val preserve_execution_context : ('a -> unit) -> ('a -> unit) Staged.t 85 | val preserve_execution_context' : ('a -> 'b Deferred.t) -> ('a -> 'b Deferred.t) Staged.t 86 | 87 | val within_context : Execution_context.t -> (unit -> 'a) -> ('a, unit) Result.t 88 | 89 | val find_local : 'a Univ_map.Key.t -> 'a option 90 | val with_local : 'a Univ_map.Key.t -> 'a option -> f:(unit -> 'b) -> 'b 91 | 92 | val make_async_unusable : unit -> unit 93 | 94 | val reset_in_forked_process : unit -> unit 95 | 96 | val yield : t -> unit Deferred.t 97 | val yield_every : n:int -> (t -> unit Deferred.t) Staged.t 98 | val yield_until_no_jobs_remain : t -> unit Deferred.t 99 | 100 | module Very_low_priority_work : sig 101 | module Worker_result : sig 102 | type t = 103 | | Finished 104 | | Not_finished 105 | [@@deriving sexp_of] 106 | end 107 | 108 | (** Enqueue some low-priority work to be done. The work will happen at some point, but 109 | Async will choose when is the best time to do it. [f] will be called until it 110 | returns [Finished]. *) 111 | val enqueue : f:(unit -> Worker_result.t) -> unit 112 | end 113 | 114 | (**/**) 115 | 116 | module For_bench : sig 117 | val advance_clock : t -> now : Time_ns.t -> unit 118 | end 119 | -------------------------------------------------------------------------------- /src/deferred_or_error.mli: -------------------------------------------------------------------------------- 1 | (** The deferred analog of [Core.Or_error]. It is exposed in std.ml as 2 | [Deferred.Or_error]. 3 | 4 | The mental model for a function returning an ['a Deferred.Or_error.t] is that the 5 | function never raises. All error cases are caught and expressed as an [Error _] 6 | result. This module preserves that property. 7 | 8 | Unfortunately, there is no way to enforce this property using the type system, so it 9 | is more like a convention, or idiom. A function whose type ends with [... -> 'a 10 | Deferred.Or_error.t] and still raises should be considered broken, and be fixed. With 11 | that property in mind, [Deferred.Or_error.List.iter], for example, does not wrap the 12 | execution of the given iter function [f] inside a monitor. If one of these 13 | application raises, the whole function [Deferred.Or_error.List.iter] will raise as a 14 | way to try to alert the developer that one the function is broken and needs attention 15 | and fixing, rather than silently catching the error and converting it to 16 | [Or_error.Error]. 17 | 18 | This behavior is consistent with [Core.Or_error]'s treatment of user-supplied 19 | functions. 20 | 21 | If you have to deal with a function that does not respect this idiom, you can use 22 | [Deferred.Or_error.try_with_join] to wrap its execution and enforce this property. *) 23 | 24 | open! Core_kernel 25 | open! Import 26 | 27 | module Deferred = Deferred1 28 | 29 | type 'a t = 'a Or_error.t Deferred.t 30 | 31 | (** The applicative operations match the behavior of the applicative operations in 32 | [Or_error]. This means that [all] and [all_unit] are equivalent to [combine_errors] 33 | and [combine_errors_unit] respectively. *) 34 | include Applicative.S with type 'a t := 'a t 35 | 36 | (** [return x = Deferred.return (Ok x)] **) 37 | include Monad.S with type 'a t := 'a t 38 | 39 | (** [fail error = Deferred.return (Error error)] **) 40 | val fail : Error.t -> _ t 41 | 42 | val ignore : _ t -> unit t 43 | 44 | (** These functions are direct analogs of the corresponding [Core.Or_error] functions. *) 45 | val ok_exn : 'a t -> 'a Deferred.t 46 | val of_exn : exn -> _ t 47 | val of_exn_result : ('a, exn) Result.t Deferred.t -> 'a t 48 | val error : string -> 'a -> ('a -> Sexp.t) -> _ t 49 | val error_s : Sexp.t -> _ t 50 | val error_string : string -> _ t 51 | val errorf : ('a, unit, string, _ t) format4 -> 'a 52 | val tag : 'a t -> tag:string -> 'a t 53 | val tag_arg : 'a t -> string -> 'b -> ('b -> Sexp.t) -> 'a t 54 | val unimplemented : string -> _ t 55 | val combine_errors : 'a t list -> 'a list t 56 | val combine_errors_unit : unit t list -> unit t 57 | 58 | (** [find_map_ok l ~f] returns the first value in [l] for which [f] returns [Ok], 59 | otherwise it returns the same error as [combine_errors (Deferred.List.map l ~f)]. *) 60 | val find_map_ok : 'a list -> f:('a -> 'b t) -> 'b t 61 | 62 | (** [ok_unit = return ()] *) 63 | val ok_unit : unit t 64 | 65 | (** [try_with f] catches exceptions thrown by [f] and returns them in the Result.t as an 66 | Error.t. [try_with_join] is like [try_with], except that [f] can throw exceptions or 67 | return an [Error] directly, without ending up with a nested error; it is equivalent to 68 | [try_with f >>| Result.join]. 69 | 70 | The option [extract_exn] is passed along to [Monitor.try_with ?extract_exn] and 71 | specifies whether or not the monitor exn wrapper should be skipped ([extract_exn:true] 72 | or kept ([extract_exn:false]). *) 73 | val try_with 74 | : ?extract_exn:bool (** default is [false] *) 75 | -> ?here:Lexing.position 76 | -> ?name:string 77 | -> (unit -> 'a Deferred.t) 78 | -> 'a t 79 | val try_with_join 80 | : ?extract_exn:bool (** default is [false] *) 81 | -> ?here:Lexing.position 82 | -> ?name:string 83 | -> (unit -> 'a t) 84 | -> 'a t 85 | 86 | (** All of the [List] functions that take a [how] argument treat it the following way: 87 | 88 | [`Sequential] indicates both sequential evaluation of the deferreds, and sequential 89 | combination of the results. 90 | 91 | [`Parallel] indicates parallel evaluation of the deferreds (in the sense that they are 92 | all in the scheduler at the same time), and parallel combination of the results. For 93 | example, [List.iter ~how:`Parallel l ~f] will call [f] on each element of [l], 94 | creating all of the deferreds, then wait for _all_ of them to finish, then combine any 95 | errors (as in [Or_error.combine_errors_unit]). 96 | 97 | [`Max_concurrent_jobs n] acts like [`Parallel] in the way it combines the results, but 98 | only evaluates [n] of the deferreds at a time. *) 99 | module List : Monad_sequence.S 100 | with type 'a monad := 'a t 101 | with type 'a t := 'a list 102 | -------------------------------------------------------------------------------- /src/async_kernel.ml: -------------------------------------------------------------------------------- 1 | (** Contains Async's core data structures, like {{!Async_kernel.Deferred}[Deferred]}, 2 | {{!Async_kernel.Ivar}[Ivar]}, and {{!Async_kernel.Clock_intf.Clock}[Clock]}. 3 | 4 | [Async_kernel] is designed to depend only on {{!Core_kernel}[Core_kernel]} (as opposed 5 | to {{!Core}[Core]}), and so is more platform-independent. *) 6 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | module Async_kernel_config = Async_kernel_config 11 | module Async_kernel_persistent_connection = Persistent_connection 12 | module Async_kernel_require_explicit_time_source = Require_explicit_time_source 13 | module Async_kernel_scheduler = Scheduler 14 | module Bvar = Bvar 15 | module Clock_ns = Clock_ns 16 | module Condition = Async_condition 17 | module Deferred = Deferred 18 | module Eager_deferred = Eager_deferred 19 | module Execution_context = Execution_context 20 | module Gc = Async_gc 21 | module Invariant = Async_invariant 22 | module Ivar = Ivar 23 | module Quickcheck = Async_quickcheck 24 | module Lazy_deferred = Lazy_deferred 25 | module Monad_sequence = Monad_sequence 26 | module Monitor = Monitor 27 | module Mvar = Mvar 28 | module Pipe = Pipe 29 | module Priority = Priority 30 | module Sequencer = Throttle.Sequencer 31 | module Stream = Async_stream 32 | module Synchronous_time_source = Synchronous_time_source 33 | module Tail = Tail 34 | module Throttle = Throttle 35 | module Time_source = Time_source 36 | 37 | (** Intended usage is to [open Use_eager_deferred] to shadow operations from the non-eager 38 | world and rebind them to their eager counterparts. *) 39 | module Use_eager_deferred = struct 40 | module Deferred = struct 41 | type 'a t = 'a Deferred.t 42 | include Eager_deferred 43 | end 44 | include (Eager_deferred : Monad.Infix with type 'a t := 'a Deferred1.t) 45 | include Eager_deferred.Let_syntax 46 | let upon = Eager_deferred.upon 47 | let ( >>> ) = Eager_deferred.Infix.( >>> ) 48 | end 49 | 50 | 51 | (** {2 Toplevel functions } 52 | 53 | The functions below are broadly useful when writing Async programs, and so are made 54 | available at the toplevel. *) 55 | 56 | let after = Clock_ns.after 57 | let at = Clock_ns.at 58 | let catch = Monitor.catch 59 | let choice = Deferred.choice 60 | let choose = Deferred.choose 61 | let don't_wait_for = Deferred.don't_wait_for 62 | let every = Clock_ns.every 63 | let never = Deferred.never 64 | let schedule = Scheduler.schedule 65 | let schedule' = Scheduler.schedule' 66 | let try_with = Monitor.try_with 67 | let upon = Deferred.upon 68 | let with_timeout = Clock_ns.with_timeout 69 | let within = Scheduler.within 70 | let within' = Scheduler.within' 71 | 72 | (** {2 Infix operators and [Let_syntax] support} *) 73 | 74 | include (Deferred : Monad.Infix with type 'a t := 'a Deferred.t) 75 | 76 | (** equivalent to {!Deferred.upon}. *) 77 | let ( >>> ) = Deferred.Infix. ( >>> ) 78 | 79 | (** equivalent to {!Deferred.Result.bind}. *) 80 | let ( >>=? ) = Deferred.Result.( >>= ) 81 | 82 | (** equivalent to {!Deferred.Result.map}. *) 83 | let ( >>|? ) = Deferred.Result.( >>| ) 84 | 85 | include Deferred.Let_syntax 86 | 87 | (**/**) 88 | (** The modules in [Async_kernel_private] are used for constructing and testing Async, and 89 | should not otherwise be used. *) 90 | module Async_kernel_private = struct 91 | module Debug = Debug 92 | module Ivar0 = Ivar0 93 | module Ivar_filler = Ivar_filler 94 | module Job = Job 95 | end 96 | (**/**) 97 | 98 | (* This test must be in this library, because it requires [return] to be inlined. Moving 99 | it to another library will cause it to break with [X_LIBRARY_INLINING=false]. *) 100 | let%test_unit "[return ()] does not allocate" = 101 | let w1 = Gc.minor_words () in 102 | ignore (return () : _ Deferred.t); 103 | ignore (Deferred.return () : _ Deferred.t); 104 | ignore (Deferred.Let_syntax.return () : _ Deferred.t); 105 | ignore (Deferred.Let_syntax.Let_syntax.return () : _ Deferred.t); 106 | let w2 = Gc.minor_words () in 107 | [%test_result: int] w2 ~expect:w1; 108 | ;; 109 | -------------------------------------------------------------------------------- /src/persistent_connection_intf.ml: -------------------------------------------------------------------------------- 1 | (** An actively maintained connection to some service that eagerly and repeatedly attempts 2 | to reconnect whenever the underlying connection is lost, until a new one can be 3 | established. *) 4 | 5 | open! Core_kernel 6 | 7 | 8 | module type Closable = sig 9 | (** a connection type *) 10 | type t 11 | 12 | (** [close t] closes the connection. The returned deferred becomes determined once any 13 | resources needed to maintain the connection have been released. *) 14 | val close : t -> unit Deferred.t 15 | 16 | (** [is_closed t] returns true if [close] has ever been called (even if the returned 17 | deferred has not yet been fulfilled). 18 | 19 | Note that some modules implementing [Closable] may call close internally upon 20 | noticing that the connection was closed by the other side. The interface of such a 21 | module ought to say that this is the case. *) 22 | val is_closed : t -> bool 23 | 24 | (** [close_finished t] becomes determined at the same time as the result of the first 25 | call to [close]. [close_finished] differs from [close] in that it does not have the 26 | side effect of initiating a close. *) 27 | val close_finished : t -> unit Deferred.t 28 | end 29 | 30 | module type S = sig 31 | type t 32 | 33 | (** The address of a service to which one can connect. E.g. [Host_and_port.t] is a 34 | reasonable choice when making a TCP connection. 35 | *) 36 | type address 37 | 38 | (** A connection, perhaps embellished with additional information upon connection. *) 39 | type conn 40 | 41 | module Event : sig 42 | type t = 43 | | Attempting_to_connect 44 | | Obtained_address of address 45 | | Failed_to_connect of Error.t 46 | | Connected of conn sexp_opaque 47 | | Disconnected 48 | [@@deriving sexp_of] 49 | 50 | val log_level : t -> [ `Info | `Debug | `Error ] 51 | end 52 | 53 | (** [create ~server_name ~on_event ~retry_delay get_address] returns a persistent 54 | connection to a server whose host and port are obtained via [get_address] every 55 | time we try to connect. For example, [get_address] might look up a server's host 56 | and port in catalog at a particular path to which multiple redundant copies of a 57 | service are publishing their location. If one copy dies, we get the address of the 58 | another one when looking up the address afterwards. 59 | 60 | All connection events (see the type above) are passed to the [on_event] callback, if 61 | given. When this callback becomes determined, we move on to the next step in our 62 | connection attempt (e.g. we won't actually attempt to connect until 63 | [on_event Attempting_to_connect] is finished). Note that [on_event Disconnected] 64 | will only be called once [on_event (Connected conn)] finishes even if the connection 65 | goes down during that callback. 66 | 67 | [`Failed_to_connect error] and [`Obtained_address addr] events are only reported if 68 | they are distinct from the most recent event of the same type that has taken place 69 | since the most recent [`Attempting_to_connect] event. 70 | 71 | Connection is retried after [Time.Span.randomize ~percent:(Percent.of_mult 0.3) 72 | (retry_delay ())]. The default for [retry_delay] is [const (sec 10.)]. Note that 73 | what this retry delay actually throttles is the delay between two connection 74 | attempts, so when a long-lived connection dies, connection is usually immediately 75 | retried, and if that failed, wait for another retry delay and retry. *) 76 | val create 77 | : server_name : string 78 | -> ?on_event : (Event.t -> unit Deferred.t) 79 | -> ?retry_delay : (unit -> Time_ns.Span.t) 80 | -> connect : (address -> conn Or_error.t Deferred.t) 81 | -> (unit -> address Or_error.t Deferred.t) 82 | -> t 83 | 84 | (** [connected] returns the first available connection from the time it is called. When 85 | currently connected, the returned deferred is already determined. If [closed] has 86 | been called, then the returned deferred is never determined. *) 87 | val connected : t -> conn Deferred.t 88 | 89 | (** The current connection, if any. *) 90 | val current_connection : t -> conn option 91 | 92 | (** [close t] closes the current connection and stops it from trying to reconnect. 93 | After the deferred it returns becomes determined, the last connection has been 94 | closed and no others will be attempted. 95 | 96 | Note: no [close] calls are ever generated internally in response to the connection 97 | being closed by the other side. 98 | *) 99 | include Closable with type t := t 100 | end 101 | 102 | module type T = sig 103 | module Address : sig 104 | type t [@@deriving sexp_of] 105 | val equal : t -> t -> bool 106 | end 107 | 108 | type t 109 | include Closable with type t := t 110 | end 111 | 112 | module type Persistent_connection = sig 113 | module type S = S 114 | module type T = T 115 | 116 | module Make (Conn : T) : S 117 | with type conn = Conn.t 118 | and type address = Conn.Address.t 119 | end 120 | -------------------------------------------------------------------------------- /src/deferred_sequence.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | 4 | module Deferred = Deferred1 5 | 6 | (* [fold_mapi ?how t ~init ~mapi_f ~fold_f] is a more efficient version of: 7 | 8 | {[ 9 | fold ~init ~f:(fun b a -> return (fold_f b a)) (mapi t ?how ~f:mapi_f) ]} 10 | 11 | It avoids creating the intermediate sequence that would result from [mapi], and 12 | allows the [fold] to proceed concurrently with the [mapi], so that one can accumulate 13 | the result as soon as possible, possibly avoiding creating an intermediate structure 14 | (e.g. [iteri] and [filter_map] uses [fold_mapi] to do this). *) 15 | let fold_mapi 16 | (type a) (type b) (type c) 17 | ?(how = `Sequential) 18 | (t : a Sequence.t) 19 | ~(init : c) 20 | ~(mapi_f : int -> a -> b Deferred.t) 21 | ~(fold_f : c -> b -> c) 22 | : c Deferred.t 23 | = 24 | match how with 25 | | `Sequential -> 26 | let rec loop i t (c : c) = 27 | match Sequence.next t with 28 | | None -> return c 29 | | Some (a, t) -> 30 | let%bind b = mapi_f i a in 31 | loop (i + 1) t (fold_f c b) 32 | in 33 | loop 0 t init 34 | | `Parallel -> 35 | let rec loop i t (c : c Deferred.t) = 36 | match Sequence.next t with 37 | | None -> c 38 | | Some (a, t) -> 39 | loop (i + 1) t (let%bind b = mapi_f i a in 40 | let%map c = c in 41 | fold_f c b) 42 | in 43 | loop 0 t (return init) 44 | | `Max_concurrent_jobs max_concurrent_jobs -> 45 | let throttle = Throttle.create ~max_concurrent_jobs ~continue_on_error:false in 46 | (* [loop] forces the input sequence and enqueues a throttle job only if there is 47 | capacity available. *) 48 | let rec loop i t (c : c Deferred.t) = 49 | let%bind () = Throttle.capacity_available throttle in 50 | match Sequence.next t with 51 | | None -> c 52 | | Some (a, t) -> 53 | loop (i + 1) t (let%bind b = Throttle.enqueue throttle (fun () -> mapi_f i a) in 54 | let%map c = c in 55 | fold_f c b) 56 | in 57 | loop 0 t (return init) 58 | ;; 59 | 60 | let foldi t ~init ~f = 61 | Sequence.delayed_fold t ~init:(0, init) 62 | ~f:(fun (i, b) a ~k -> let%bind b = f i b a in k (i + 1, b)) 63 | ~finish:(fun (_, b) -> return b) 64 | ;; 65 | 66 | (* [fold] is not implemented in terms of [foldi] to save the intermediate closure 67 | allocation. *) 68 | let fold t ~init ~f = 69 | Sequence.delayed_fold t ~init 70 | ~f:(fun b a ~k -> f b a >>= k) 71 | ~finish:return 72 | ;; 73 | 74 | let all t = 75 | let%map res = fold t ~init:[] ~f:(fun accum d -> let%map a = d in a :: accum) in 76 | Sequence.of_list (List.rev res) 77 | ;; 78 | 79 | let all_unit t = fold t ~init:() ~f:(fun () v -> v) 80 | 81 | let find_mapi t ~f = 82 | let rec find_mapi t ~f i = 83 | match Sequence.next t with 84 | | None -> return None 85 | | Some (v, rest) -> 86 | match%bind f i v with 87 | | None -> find_mapi rest ~f (i+1) 88 | | Some _ as some -> return some 89 | in 90 | find_mapi t ~f 0 91 | ;; 92 | 93 | let findi t ~f = 94 | find_mapi t ~f:(fun i elt -> let%map b = f i elt in if b then (Some (i,elt)) else None) 95 | ;; 96 | let find t ~f = 97 | find_mapi t ~f:(fun _ elt -> let%map b = f elt in if b then (Some elt) else None) 98 | ;; 99 | 100 | let existsi t ~f = 101 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if b then (Some ()) else None) with 102 | | Some () -> true 103 | | None -> false 104 | 105 | let for_alli t ~f = 106 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if not b then (Some ()) else None) with 107 | | Some () -> false 108 | | None -> true 109 | 110 | 111 | let iteri ?how t ~f : unit Deferred.t = 112 | fold_mapi ?how t ~mapi_f:f ~init:() ~fold_f:(fun () () -> ()) 113 | ;; 114 | 115 | 116 | let mapi ?how t ~f = 117 | let%map bs = 118 | fold_mapi ?how t ~mapi_f:(fun i a -> f i a) ~init:[] ~fold_f:(fun bs b -> b :: bs) 119 | in 120 | Sequence.of_list (List.rev bs) 121 | ;; 122 | 123 | (* [filter_mapi] is implemented using [fold_mapi] rather than [map] so that we never need 124 | to keep a long stream of intermediate [None] results in the accumulator, only to later 125 | filter them all out. *) 126 | let filter_mapi ?how t ~f = 127 | let%map bs = 128 | fold_mapi t ?how ~mapi_f:(fun i a -> f i a) ~init:[] ~fold_f:(fun bs maybe_v -> 129 | match maybe_v with 130 | | None -> bs 131 | | Some b -> b :: bs) 132 | in 133 | Sequence.of_list (List.rev bs) 134 | ;; 135 | 136 | let concat_mapi ?how t ~f = mapi ?how t ~f >>| Sequence.concat 137 | 138 | let filteri ?how t ~f = 139 | filter_mapi ?how t ~f:(fun i a -> 140 | match%map f i a with 141 | | true -> Some a 142 | | false -> None) 143 | ;; 144 | 145 | let iter ?how t ~f = iteri ?how t ~f:(fun _ a -> f a) 146 | let map ?how t ~f = mapi ?how t ~f:(fun _ a -> f a) 147 | let filter ?how t ~f = filteri ?how t ~f:(fun _ a -> f a) 148 | let filter_map ?how t ~f = filter_mapi ?how t ~f:(fun _ a -> f a) 149 | let concat_map ?how t ~f = concat_mapi ?how t ~f:(fun _ a -> f a) 150 | let find_map t ~f = find_mapi t ~f:(fun _ a -> f a) 151 | let exists t ~f = existsi t ~f:(fun _ a -> f a) 152 | let for_all t ~f = for_alli t ~f:(fun _ a -> f a) 153 | 154 | let init ?how n ~f = map ?how (Sequence.init n ~f:Fn.id) ~f 155 | -------------------------------------------------------------------------------- /src/eager_deferred0.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module T = struct 5 | type +'a t = 'a Deferred.t [@@deriving sexp_of] 6 | 7 | let return = Deferred.return 8 | 9 | let bind t ~f = 10 | if Deferred.is_determined t 11 | then (f (Deferred.value_exn t)) 12 | else (Deferred.bind t ~f) 13 | ;; 14 | 15 | let map t ~f = 16 | if Deferred.is_determined t 17 | then (return (f (Deferred.value_exn t))) 18 | else (Deferred.map t ~f) 19 | ;; 20 | 21 | let map = `Custom map 22 | end 23 | 24 | include T 25 | 26 | include Monad.Make(T) 27 | 28 | let create = Deferred.create 29 | let don't_wait_for = Deferred.don't_wait_for 30 | let invariant = Deferred.invariant 31 | let is_determined = Deferred.is_determined 32 | let never = Deferred.never 33 | let peek = Deferred.peek 34 | let unit = Deferred.unit 35 | let value_exn = Deferred.value_exn 36 | 37 | let upon t f = 38 | if is_determined t 39 | then (f (value_exn t)) 40 | else (Deferred.upon t f) 41 | ;; 42 | 43 | let both t1 t2 = 44 | create (fun result -> 45 | upon t1 (fun a1 -> upon t2 (fun a2 -> Ivar.fill result (a1, a2)))) 46 | ;; 47 | 48 | let ok t = 49 | if is_determined t 50 | then (return (Ok (value_exn t))) 51 | else (Deferred.ok t) 52 | ;; 53 | 54 | let ignore t = 55 | if is_determined t 56 | then unit 57 | else (Deferred.ignore t) 58 | ;; 59 | 60 | let any ts = 61 | match List.find ts ~f:is_determined with 62 | | Some x -> return (value_exn x) 63 | | None -> Deferred.any ts 64 | ;; 65 | 66 | let any_unit ts = 67 | if List.exists ts ~f:is_determined 68 | then unit 69 | else (Deferred.any_unit ts) 70 | ;; 71 | 72 | module Infix = struct 73 | include Monad_infix 74 | let (>>>) = upon 75 | end 76 | 77 | let repeat_until_finished state f = 78 | let open Infix in 79 | create (fun finished -> 80 | let rec loop state = 81 | f state 82 | >>> function 83 | | `Repeat state -> loop state 84 | | `Finished result -> Ivar.fill finished result 85 | in 86 | loop state) 87 | ;; 88 | 89 | module List = struct 90 | open Infix 91 | open Let_syntax 92 | 93 | let foldi t ~init ~f = 94 | create 95 | (fun result -> 96 | let rec loop t i b = 97 | match t with 98 | | [] -> Ivar.fill result b 99 | | x :: xs -> f i b x >>> fun b -> loop xs (i + 1) b 100 | in 101 | loop t 0 init) 102 | ;; 103 | 104 | let fold t ~init ~f = foldi t ~init ~f:(fun _ a x -> f a x) 105 | 106 | let seqmapi t ~f = 107 | foldi t ~init:[] ~f:(fun i bs a -> let%map b = f i a in b :: bs) 108 | >>| List.rev 109 | ;; 110 | 111 | let all ds = seqmapi ds ~f:(fun _ x -> x) 112 | 113 | let all_unit ds = ignore (fold ds ~init:() ~f:(fun () d -> d) : unit T.t) 114 | 115 | let iteri ?(how = `Sequential) t ~f = 116 | match how with 117 | | `Parallel | `Max_concurrent_jobs _ as how -> 118 | all_unit (List.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 119 | | `Sequential -> foldi t ~init:() ~f:(fun i () x -> f i x) 120 | ;; 121 | 122 | let mapi ?(how = `Sequential) t ~f = 123 | match how with 124 | | `Parallel | `Max_concurrent_jobs _ as how -> 125 | all (List.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 126 | | `Sequential -> seqmapi t ~f 127 | ;; 128 | 129 | let filteri ?how t ~f = 130 | let%map bools = mapi t ?how ~f in 131 | List.rev (List.fold2_exn t bools ~init:[] 132 | ~f:(fun ac x b -> if b then (x :: ac) else ac)) 133 | ;; 134 | 135 | let filter_mapi ?how t ~f = mapi t ?how ~f >>| List.filter_opt 136 | let concat_mapi ?how t ~f = mapi t ?how ~f >>| List.concat 137 | 138 | let find_mapi t ~f = 139 | let rec find_mapi t ~f i = 140 | match t with 141 | | [] -> return None 142 | | hd :: tl -> 143 | match%bind f i hd with 144 | | None -> find_mapi tl ~f (i+1) 145 | | Some _ as some -> return some 146 | in 147 | find_mapi t ~f 0 148 | ;; 149 | 150 | let findi t ~f = 151 | find_mapi t ~f:(fun i elt -> 152 | let%map b = f i elt in 153 | if b 154 | then (Some (i,elt)) 155 | else None) 156 | ;; 157 | let find t ~f = 158 | find_mapi t ~f:(fun _ elt -> 159 | if%map f elt 160 | then (Some elt) 161 | else None) 162 | ;; 163 | 164 | let existsi t ~f = 165 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if b then (Some ()) else None) with 166 | | Some () -> true 167 | | None -> false 168 | 169 | let for_alli t ~f = 170 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if not b then (Some ()) else None) with 171 | | Some () -> false 172 | | None -> true 173 | ;; 174 | 175 | let iter ?how t ~f = iteri ?how t ~f:(fun _ a -> f a) 176 | let map ?how t ~f = mapi ?how t ~f:(fun _ a -> f a) 177 | let filter ?how t ~f = filteri ?how t ~f:(fun _ a -> f a) 178 | let filter_map ?how t ~f = filter_mapi ?how t ~f:(fun _ a -> f a) 179 | let concat_map ?how t ~f = concat_mapi ?how t ~f:(fun _ a -> f a) 180 | let find_map t ~f = find_mapi t ~f:(fun _ a -> f a) 181 | let exists t ~f = existsi t ~f:(fun _ a -> f a) 182 | let for_all t ~f = for_alli t ~f:(fun _ a -> f a) 183 | 184 | let init ?how n ~f = map ?how (List.init n ~f:Fn.id) ~f 185 | 186 | end 187 | 188 | let all_unit = List.all_unit 189 | let all_ignore = all_unit 190 | -------------------------------------------------------------------------------- /src/synchronous_time_source.mli: -------------------------------------------------------------------------------- 1 | (** A synchronous version of [Async_kernel.Time_source]. [advance_by_alarms] runs 2 | alarms immediately, rather than enqueueing Async jobs. *) 3 | 4 | open! Core_kernel 5 | open! Import 6 | 7 | module T1 : sig 8 | type -'rw t = 'rw Types.Time_source.t1 [@@deriving sexp_of] 9 | end 10 | 11 | module Read_write : sig 12 | type t = read_write T1.t [@@deriving sexp_of] 13 | include Invariant.S with type t := t 14 | end 15 | 16 | type t = read T1.t [@@deriving sexp_of] 17 | 18 | include Invariant.S with type t := t 19 | 20 | val read_only : [> read] T1.t -> t 21 | 22 | type callback = unit -> unit 23 | 24 | (** [create ~now ()] creates a new time source. The default [timing_wheel_config] has 100 25 | microsecond precision, with levels of >1s, >1m, >1h, >1d. *) 26 | val create 27 | : ?timing_wheel_config : Timing_wheel_ns.Config.t 28 | -> now : Time_ns.t 29 | -> unit 30 | -> read_write T1.t 31 | 32 | val alarm_precision : [> read] T1.t -> Time_ns.Span.t 33 | 34 | (** [is_wall_clock] reports whether this time source represents 'wall clock' time, or some 35 | alternate source of time. *) 36 | val is_wall_clock : [> read] T1.t -> bool 37 | 38 | (** The behavior of [now] is special for [wall_clock ()]; it always calls [Time_ns.now 39 | ()], so it can return times that the time source has not yet been advanced to. *) 40 | val now : [> read] T1.t -> Time_ns.t 41 | 42 | (** Removes the special behavior of [now] for [wall_clock ()]; it always returns the 43 | timing wheel's notion of now, which means that the following inequality always holds: 44 | [timing_wheel_now () <= now ()]. *) 45 | val timing_wheel_now : [> read] T1.t -> Time_ns.t 46 | 47 | (** [advance_by_alarms t ~to_] advances [t]'s time to [to_], running callbacks for all 48 | alarms in [t] whose [at <= to_]. Callbacks run in nondecreasing order of [at]. If 49 | [to_ <= now t], then [now t] does not change (and in particular does not go backward), 50 | but alarms with [at <= to_] may still may fire. *) 51 | val advance_by_alarms : [> write] T1.t -> to_:Time_ns.t -> unit Or_error.t 52 | 53 | (** [run_at t at f] schedules an alarm that will run [f] during the next subsequent 54 | [advance_by_alarms t ~to_] that causes [now t >= at]. If [at <= now t], then [f] will 55 | to run at the next call to [advance_by_alarms]. [f] is allowed to do all 56 | [Synchronous_time_source] operations except for [advance_by_alarms] (because [f] is 57 | already running during [advance_by_alarms]. Adding alarms is not zero-alloc and the 58 | underlying events live in the OCaml heap. *) 59 | val run_at : [> read] T1.t -> Time_ns.t -> callback -> unit 60 | 61 | (** [run_after t span f] is [run_at t (now t + span) f]. *) 62 | val run_after : [> read] T1.t -> Time_ns.Span.t -> callback -> unit 63 | 64 | (** [run_at_intervals t span f] causes [f] to run at intervals [now t + k * span], for 65 | k = 0, 1, 2, etc. [run_at_intervals] raises if [span < alarm_precision t]. *) 66 | val run_at_intervals : [> read] T1.t -> Time_ns.Span.t -> callback -> unit 67 | 68 | (** [alarm_upper_bound t] returns the upper bound on a [Time_ns.t] that can be 69 | supplied to [run_at]. [alarm_upper_bound t] is not constant; its value 70 | increases as [now t] increases. *) 71 | val alarm_upper_bound : [> read] T1.t -> Time_ns.t 72 | 73 | module Event : sig 74 | type t [@@deriving sexp_of] 75 | 76 | include Invariant.S with type t := t 77 | 78 | (** These are like the corresponding [run_*] functions, except they return an event that 79 | one can later [abort]. *) 80 | val at : [> read] T1.t -> Time_ns.t -> callback -> t 81 | val after : [> read] T1.t -> Time_ns.Span.t -> callback -> t 82 | val at_intervals : [> read] T1.t -> Time_ns.Span.t -> callback -> t 83 | 84 | module Abort_result : sig 85 | type t = 86 | | Ok 87 | | Currently_happening 88 | | Previously_unscheduled 89 | [@@deriving sexp_of] 90 | end 91 | 92 | (** [abort t] aborts the event [t], if possible, and returns [Ok] if the event was 93 | aborted, or the reason it could not be aborted. [abort] returns 94 | [Currently_happening] iff it is called on an event while running that event's 95 | callback. *) 96 | val abort : [> read] T1.t -> t -> Abort_result.t 97 | val abort_exn : [> read] T1.t -> t -> unit 98 | val abort_if_possible : [> read] T1.t -> t -> unit 99 | 100 | (** [create timesource callback] creates an event that is not scheduled in 101 | [timesource]'s timing wheel but is available to be scheduled using [schedule_at] and 102 | [schedule_after]. *) 103 | val create : [> read] T1.t -> callback -> t 104 | 105 | (** [schedule_at timesource t time] schedules [t] to fire at [time]. [schedule_at] 106 | returns [Error] if [t] is currently scheduled to run. *) 107 | val schedule_at : [> read] T1.t -> t -> Time_ns.t -> unit Or_error.t 108 | val schedule_after : [> read] T1.t -> t -> Time_ns.Span.t -> unit Or_error.t 109 | val schedule_at_intervals : [> read] T1.t -> t -> Time_ns.Span.t -> unit Or_error.t 110 | end 111 | 112 | val default_timing_wheel_config : Timing_wheel_ns.Config.t 113 | 114 | (** A time source with [now t] given by wall-clock time (i.e. [Time_ns.now]), and 115 | automatically advanced at the start of each Async cycle. The wall clock uses the same 116 | timing wheel as that used by the Async scheduler, and is hence similarly affected by 117 | the [ASYNC_CONFIG] environment variable. *) 118 | val wall_clock : unit -> t 119 | -------------------------------------------------------------------------------- /src/deferred_or_error.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Deferred = Deferred1 5 | 6 | module Monitor = struct 7 | let try_with = Monitor.try_with ?run:None 8 | end 9 | 10 | (* Copied to [eager_deferred_or_error.ml]. There should be no diffs below this line. *) 11 | 12 | include (Deferred_result : Monad.S2 13 | with type ('a, 'b) t := ('a, 'b) Deferred_result.t 14 | with module Let_syntax := Deferred_result.Let_syntax) 15 | 16 | type 'a t = 'a Or_error.t Deferred.t 17 | 18 | include Applicative.Make (struct 19 | type nonrec 'a t = 'a t 20 | let return = return 21 | let apply f x = 22 | Deferred_result.combine f x 23 | ~ok:(fun f x -> f x) 24 | ~err:(fun e1 e2 -> Error.of_list [e1; e2]) 25 | let map = `Custom map 26 | end) 27 | 28 | module Let_syntax = struct 29 | let return = return 30 | include Monad_infix 31 | module Let_syntax = struct 32 | let return = return 33 | let map = map 34 | let bind = bind 35 | let both = both (* from Applicative.Make *) 36 | module Open_on_rhs = struct end 37 | end 38 | end 39 | 40 | open Let_syntax 41 | 42 | let ignore = ignore_m 43 | 44 | let fail error = Deferred.return (Result.fail error) 45 | 46 | let ok_exn t = Deferred.map t ~f:Or_error.ok_exn 47 | 48 | let of_exn exn = Deferred.return (Or_error.of_exn exn) 49 | 50 | let of_exn_result t = Deferred.map t ~f:Or_error.of_exn_result 51 | 52 | let error msg v sexp_of = Deferred.return (Or_error.error msg v sexp_of) 53 | 54 | let error_s sexp = Deferred.return (Or_error.error_s sexp) 55 | 56 | let error_string msg = Deferred.return (Or_error.error_string msg) 57 | 58 | let errorf format = ksprintf error_string format 59 | 60 | let tag t ~tag = Deferred.map t ~f:(Or_error.tag ~tag) 61 | 62 | let tag_arg t message a sexp_of_a = 63 | Deferred.map t ~f:(fun t -> Or_error.tag_arg t message a sexp_of_a) 64 | ;; 65 | 66 | let unimplemented msg = Deferred.return (Or_error.unimplemented msg) 67 | 68 | let combine_errors l = 69 | Deferred.map (Deferred.all l) ~f:Or_error.combine_errors 70 | ;; 71 | 72 | let combine_errors_unit l = 73 | Deferred.map (Deferred.all l) ~f:Or_error.combine_errors_unit 74 | ;; 75 | 76 | let find_map_ok l ~f = 77 | Deferred.repeat_until_finished (l, []) (fun (l, errors) -> 78 | match l with 79 | | [] -> 80 | let errors = Error.of_list (List.rev errors) in 81 | Deferred.return (`Finished (Error errors)) 82 | | hd :: tl -> 83 | Deferred.map (f hd) ~f:(function 84 | | Error current_error -> `Repeat (tl, current_error :: errors) 85 | | Ok result -> `Finished (Ok result))) 86 | ;; 87 | 88 | let ok_unit = return () 89 | 90 | let try_with ?extract_exn ?here ?name f = 91 | Deferred.map (Monitor.try_with ?extract_exn ?here ?name f) ~f:(function 92 | | Error exn -> Error (Error.of_exn exn) 93 | | Ok _ as ok -> ok) 94 | ;; 95 | 96 | let try_with_join ?extract_exn ?here ?name f = 97 | Deferred.map (try_with ?here ?extract_exn ?name f) ~f:Or_error.join 98 | ;; 99 | 100 | module List = struct 101 | 102 | let foldi list ~init:acc ~f = 103 | let rec loop i acc = function 104 | | [] -> return acc 105 | | hd :: tl -> 106 | let%bind acc = f i acc hd in 107 | loop (i + 1) acc tl 108 | in 109 | loop 0 acc list 110 | ;; 111 | 112 | let fold t ~init ~f = foldi t ~init ~f:(fun _ a x -> f a x) 113 | 114 | let seqmapi t ~f = 115 | foldi t ~init:[] ~f:(fun i bs a -> let%map b = f i a in b :: bs) 116 | >>| List.rev 117 | ;; 118 | 119 | let all = all 120 | let all_unit = all_unit 121 | 122 | let iteri ?(how = `Sequential) t ~f = 123 | match how with 124 | | `Parallel | `Max_concurrent_jobs _ as how -> 125 | all_unit (List.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 126 | | `Sequential -> 127 | foldi t ~init:() ~f:(fun i () x -> f i x) 128 | ;; 129 | 130 | let mapi ?(how=`Sequential) t ~f = 131 | match how with 132 | | `Parallel | `Max_concurrent_jobs _ as how -> 133 | all (List.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 134 | | `Sequential -> seqmapi t ~f 135 | ;; 136 | 137 | let filter_mapi ?how t ~f = mapi t ?how ~f >>| List.filter_opt 138 | let concat_mapi ?how t ~f = mapi t ?how ~f >>| List.concat 139 | 140 | let filteri ?how t ~f = 141 | filter_mapi ?how t ~f:(fun i x -> 142 | let%map b = f i x in 143 | if b then (Some x) else None) 144 | ;; 145 | 146 | let find_mapi t ~f = 147 | let rec find_mapi t ~f i = 148 | match t with 149 | | [] -> return None 150 | | hd :: tl -> 151 | match%bind f i hd with 152 | | None -> find_mapi tl ~f (i+1) 153 | | Some _ as some -> return some 154 | in 155 | find_mapi t ~f 0 156 | ;; 157 | let find_map t ~f = 158 | find_mapi t ~f:(fun _ a -> f a) 159 | ;; 160 | 161 | let findi t ~f = 162 | find_mapi t ~f:(fun i elt -> let%map b = f i elt in if b then (Some (i,elt)) else None) 163 | ;; 164 | let find t ~f = 165 | find_map t ~f:(fun elt -> let%map b = f elt in if b then (Some elt) else None) 166 | ;; 167 | 168 | let existsi t ~f = 169 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if b then (Some ()) else None) with 170 | | Some () -> true 171 | | None -> false 172 | 173 | let for_alli t ~f = 174 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if not b then (Some ()) else None) with 175 | | Some () -> false 176 | | None -> true 177 | 178 | let iter ?how t ~f = iteri ?how t ~f:(fun _ a -> f a) 179 | let map ?how t ~f = mapi ?how t ~f:(fun _ a -> f a) 180 | let filter ?how t ~f = filteri ?how t ~f:(fun _ a -> f a) 181 | let filter_map ?how t ~f = filter_mapi ?how t ~f:(fun _ a -> f a) 182 | let concat_map ?how t ~f = concat_mapi ?how t ~f:(fun _ a -> f a) 183 | let find_map t ~f = find_mapi t ~f:(fun _ a -> f a) 184 | let exists t ~f = existsi t ~f:(fun _ a -> f a) 185 | let for_all t ~f = for_alli t ~f:(fun _ a -> f a) 186 | 187 | let init ?how n ~f = map ?how (List.init n ~f:Fn.id) ~f 188 | 189 | end 190 | -------------------------------------------------------------------------------- /src/eager_deferred_or_error.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Deferred = Eager_deferred0 5 | 6 | module Deferred_result = Eager_deferred_result 7 | 8 | module Monitor = struct 9 | let try_with = Monitor.try_with ~run:`Now 10 | end 11 | 12 | (* Copied from [deferred_or_error.ml]. There should be no diffs below this line. *) 13 | 14 | include (Deferred_result : Monad.S2 15 | with type ('a, 'b) t := ('a, 'b) Deferred_result.t 16 | with module Let_syntax := Deferred_result.Let_syntax) 17 | 18 | type 'a t = 'a Or_error.t Deferred.t 19 | 20 | include Applicative.Make (struct 21 | type nonrec 'a t = 'a t 22 | let return = return 23 | let apply f x = 24 | Deferred_result.combine f x 25 | ~ok:(fun f x -> f x) 26 | ~err:(fun e1 e2 -> Error.of_list [e1; e2]) 27 | let map = `Custom map 28 | end) 29 | 30 | module Let_syntax = struct 31 | let return = return 32 | include Monad_infix 33 | module Let_syntax = struct 34 | let return = return 35 | let map = map 36 | let bind = bind 37 | let both = both (* from Applicative.Make *) 38 | module Open_on_rhs = struct end 39 | end 40 | end 41 | 42 | open Let_syntax 43 | 44 | let ignore = ignore_m 45 | 46 | let fail error = Deferred.return (Result.fail error) 47 | 48 | let ok_exn t = Deferred.map t ~f:Or_error.ok_exn 49 | 50 | let of_exn exn = Deferred.return (Or_error.of_exn exn) 51 | 52 | let of_exn_result t = Deferred.map t ~f:Or_error.of_exn_result 53 | 54 | let error msg v sexp_of = Deferred.return (Or_error.error msg v sexp_of) 55 | 56 | let error_s sexp = Deferred.return (Or_error.error_s sexp) 57 | 58 | let error_string msg = Deferred.return (Or_error.error_string msg) 59 | 60 | let errorf format = ksprintf error_string format 61 | 62 | let tag t ~tag = Deferred.map t ~f:(Or_error.tag ~tag) 63 | 64 | let tag_arg t message a sexp_of_a = 65 | Deferred.map t ~f:(fun t -> Or_error.tag_arg t message a sexp_of_a) 66 | ;; 67 | 68 | let unimplemented msg = Deferred.return (Or_error.unimplemented msg) 69 | 70 | let combine_errors l = 71 | Deferred.map (Deferred.all l) ~f:Or_error.combine_errors 72 | ;; 73 | 74 | let combine_errors_unit l = 75 | Deferred.map (Deferred.all l) ~f:Or_error.combine_errors_unit 76 | ;; 77 | 78 | let find_map_ok l ~f = 79 | Deferred.repeat_until_finished (l, []) (fun (l, errors) -> 80 | match l with 81 | | [] -> 82 | let errors = Error.of_list (List.rev errors) in 83 | Deferred.return (`Finished (Error errors)) 84 | | hd :: tl -> 85 | Deferred.map (f hd) ~f:(function 86 | | Error current_error -> `Repeat (tl, current_error :: errors) 87 | | Ok result -> `Finished (Ok result))) 88 | ;; 89 | 90 | let ok_unit = return () 91 | 92 | let try_with ?extract_exn ?here ?name f = 93 | Deferred.map (Monitor.try_with ?extract_exn ?here ?name f) ~f:(function 94 | | Error exn -> Error (Error.of_exn exn) 95 | | Ok _ as ok -> ok) 96 | ;; 97 | 98 | let try_with_join ?extract_exn ?here ?name f = 99 | Deferred.map (try_with ?here ?extract_exn ?name f) ~f:Or_error.join 100 | ;; 101 | 102 | module List = struct 103 | 104 | let foldi list ~init:acc ~f = 105 | let rec loop i acc = function 106 | | [] -> return acc 107 | | hd :: tl -> 108 | let%bind acc = f i acc hd in 109 | loop (i + 1) acc tl 110 | in 111 | loop 0 acc list 112 | ;; 113 | 114 | let fold t ~init ~f = foldi t ~init ~f:(fun _ a x -> f a x) 115 | 116 | let seqmapi t ~f = 117 | foldi t ~init:[] ~f:(fun i bs a -> let%map b = f i a in b :: bs) 118 | >>| List.rev 119 | ;; 120 | 121 | let all = all 122 | let all_unit = all_unit 123 | 124 | let iteri ?(how = `Sequential) t ~f = 125 | match how with 126 | | `Parallel | `Max_concurrent_jobs _ as how -> 127 | all_unit (List.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 128 | | `Sequential -> 129 | foldi t ~init:() ~f:(fun i () x -> f i x) 130 | ;; 131 | 132 | let mapi ?(how=`Sequential) t ~f = 133 | match how with 134 | | `Parallel | `Max_concurrent_jobs _ as how -> 135 | all (List.mapi t ~f:(unstage (Throttle.monad_sequence_how2 ~how ~f))) 136 | | `Sequential -> seqmapi t ~f 137 | ;; 138 | 139 | let filter_mapi ?how t ~f = mapi t ?how ~f >>| List.filter_opt 140 | let concat_mapi ?how t ~f = mapi t ?how ~f >>| List.concat 141 | 142 | let filteri ?how t ~f = 143 | filter_mapi ?how t ~f:(fun i x -> 144 | let%map b = f i x in 145 | if b then (Some x) else None) 146 | ;; 147 | 148 | let find_mapi t ~f = 149 | let rec find_mapi t ~f i = 150 | match t with 151 | | [] -> return None 152 | | hd :: tl -> 153 | match%bind f i hd with 154 | | None -> find_mapi tl ~f (i+1) 155 | | Some _ as some -> return some 156 | in 157 | find_mapi t ~f 0 158 | ;; 159 | let find_map t ~f = 160 | find_mapi t ~f:(fun _ a -> f a) 161 | ;; 162 | 163 | let findi t ~f = 164 | find_mapi t ~f:(fun i elt -> let%map b = f i elt in if b then (Some (i,elt)) else None) 165 | ;; 166 | let find t ~f = 167 | find_map t ~f:(fun elt -> let%map b = f elt in if b then (Some elt) else None) 168 | ;; 169 | 170 | let existsi t ~f = 171 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if b then (Some ()) else None) with 172 | | Some () -> true 173 | | None -> false 174 | 175 | let for_alli t ~f = 176 | match%map find_mapi t ~f:(fun i elt -> let%map b = f i elt in if not b then (Some ()) else None) with 177 | | Some () -> false 178 | | None -> true 179 | 180 | let iter ?how t ~f = iteri ?how t ~f:(fun _ a -> f a) 181 | let map ?how t ~f = mapi ?how t ~f:(fun _ a -> f a) 182 | let filter ?how t ~f = filteri ?how t ~f:(fun _ a -> f a) 183 | let filter_map ?how t ~f = filter_mapi ?how t ~f:(fun _ a -> f a) 184 | let concat_map ?how t ~f = concat_mapi ?how t ~f:(fun _ a -> f a) 185 | let find_map t ~f = find_mapi t ~f:(fun _ a -> f a) 186 | let exists t ~f = existsi t ~f:(fun _ a -> f a) 187 | let for_all t ~f = for_alli t ~f:(fun _ a -> f a) 188 | 189 | let init ?how n ~f = map ?how (List.init n ~f:Fn.id) ~f 190 | 191 | end 192 | -------------------------------------------------------------------------------- /src/throttle.mli: -------------------------------------------------------------------------------- 1 | (** A way to limit the number of concurrent computations. 2 | 3 | A throttle is essentially a pipe to which one can feed jobs. 4 | 5 | A throttle schedules asynchronous jobs so that at any point in time no more than 6 | [max_concurrent_jobs] jobs are running. A job [f] is considered to be running from 7 | the time [f ()] is executed until the deferred returned by [f ()] becomes determined, 8 | or [f ()] raises. The throttle initiates jobs on a first-come first-served basis. 9 | 10 | One can use [create_with] to create a throttle with "resources" that one would 11 | like to make available to concurrent jobs and to guarantee that different jobs 12 | access different resources. 13 | 14 | A throttle is killed if one of its jobs throws an exception, and the throttle has 15 | [continue_on_error = false]. A throttle can also be explicitly [kill]ed. If a 16 | throttle is killed, then all jobs in it that haven't yet started are aborted, i.e., 17 | they will not start and will become determined with [`Aborted]. Jobs that had already 18 | started will continue, and return [`Ok] or [`Raised] as usual when they finish. Jobs 19 | enqueued into a killed throttle will be immediately aborted. *) 20 | 21 | open! Core_kernel 22 | 23 | module Deferred = Deferred1 24 | 25 | (** We use a phantom type to distinguish between throttles, which have 26 | [max_concurrent_jobs >= 1], and sequencers, which have [max_concurrent_jobs = 1]. All 27 | operations are available on both. We make the distinction because it is sometimes 28 | useful to know from the type of a throttle that it is a sequencer and that at most one 29 | job can be running at a time. *) 30 | module T2 : sig 31 | type ('a, 'kind) t [@@deriving sexp_of] 32 | include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t 33 | end 34 | 35 | type 'a t = ('a, [`throttle]) T2.t [@@deriving sexp_of] 36 | 37 | include Invariant.S1 with type 'a t := 'a t 38 | 39 | (** [create ~continue_on_error ~max_concurrent_jobs] returns a throttle that will run up 40 | to [max_concurrent_jobs] concurrently. 41 | 42 | If some job raises an exception, then the throttle will be killed, unless 43 | [continue_on_error] is true. *) 44 | val create 45 | : continue_on_error : bool 46 | -> max_concurrent_jobs : int 47 | -> unit t 48 | 49 | (** [create_with ~continue_on_error job_resources] returns a throttle that will run up to 50 | [List.length job_resources] concurrently, and will ensure that all running jobs are 51 | supplied distinct elements of [job_resources]. *) 52 | val create_with 53 | : continue_on_error : bool 54 | -> 'a list 55 | -> 'a t 56 | 57 | type 'a outcome = [ `Ok of 'a | `Aborted | `Raised of exn ] [@@deriving sexp_of] 58 | 59 | (** [enqueue t job] schedules [job] to be run as soon as possible. Jobs are guaranteed to 60 | be started in the order they are [enqueue]d and to not be started during the call to 61 | [enqueue]. If [t] is dead, then [job] will be immediately aborted (for [enqueue], 62 | this will send an exception to the monitor in effect). *) 63 | val enqueue' : ('a, _) T2.t -> ('a -> 'b Deferred.t) -> 'b outcome Deferred.t 64 | val enqueue : ('a, _) T2.t -> ('a -> 'b Deferred.t) -> 'b Deferred.t 65 | 66 | (** [monad_sequence_how ~how ~f] returns a function that behaves like [f], except that it 67 | uses a throttle to limit the number of concurrent invocations that can be running 68 | simultaneously. The throttle has [continue_on_error = false]. *) 69 | val monad_sequence_how 70 | : ?how : Monad_sequence.how 71 | -> f : ('a -> 'b Deferred.t) 72 | -> ('a -> 'b Deferred.t) Staged.t 73 | 74 | val monad_sequence_how2 75 | : ?how : Monad_sequence.how 76 | -> f : ('a1 -> 'a2 -> 'b Deferred.t) 77 | -> ('a1 -> 'a2 -> 'b Deferred.t) Staged.t 78 | 79 | (** [prior_jobs_done t] becomes determined when all of the jobs that were previously 80 | enqueued in [t] have completed. *) 81 | val prior_jobs_done : (_, _) T2.t -> unit Deferred.t 82 | 83 | (** [max_concurrent_jobs t] returns the maximum number of jobs that [t] will run 84 | concurrently. *) 85 | val max_concurrent_jobs : (_, _) T2.t -> int 86 | 87 | (** [num_jobs_running t] returns the number of jobs that [t] is currently running. It 88 | is guaranteed that if [num_jobs_running t < max_concurrent_jobs t] then 89 | [num_jobs_waiting_to_start t = 0]. That is, the throttle always uses its maximum 90 | concurrency if possible. *) 91 | val num_jobs_running : (_, _) T2.t -> int 92 | 93 | (** [num_jobs_waiting_to_start t] returns the number of jobs that have been [enqueue]d but 94 | have not yet started. *) 95 | val num_jobs_waiting_to_start : (_, _) T2.t -> int 96 | 97 | (** [capacity_available t] becomes determined the next time that [t] has fewer than 98 | [max_concurrent_jobs t] running, and hence an [enqueue]d job would start 99 | immediately. *) 100 | val capacity_available : (_, _) T2.t -> unit Deferred.t 101 | 102 | (** [kill t] kills [t], which aborts all enqueued jobs that haven't started and all jobs 103 | enqueued in the future. [kill] also initiates the [at_kill] clean functions. 104 | 105 | If [t] has already been killed, then calling [kill t] has no effect. *) 106 | val kill : (_, _) T2.t -> unit 107 | 108 | (** [is_dead t] returns [true] if [t] was killed, either by [kill] or by an unhandled 109 | exception in a job. *) 110 | val is_dead : (_, _) T2.t -> bool 111 | 112 | (** [at_kill t clean] runs [clean] on each resource when [t] is killed, either by [kill] 113 | or by an unhandled exception. [clean] is called on each resource as it becomes 114 | available, i.e., immediately if the resource isn't currently in use, otherwise when 115 | the job currently using the resource finishes. If a call to [clean] fails, the 116 | exception is raised to the monitor in effect when [at_kill] was called. *) 117 | val at_kill : ('a, _) T2.t -> ('a -> unit Deferred.t) -> unit 118 | 119 | (** [cleaned t] becomes determined after [t] is killed, all its running jobs have 120 | completed, and all [at_kill] clean functions have completed. *) 121 | val cleaned : (_, _) T2.t -> unit Deferred.t 122 | 123 | (** A sequencer is a throttle that is specialized to only allow one job at a time and to, 124 | by default, not continue on error. *) 125 | module Sequencer : sig 126 | type 'a t = ('a, [`sequencer]) T2.t [@@deriving sexp_of] 127 | 128 | val create : ?continue_on_error:bool (** default is [false] *) -> 'a -> 'a t 129 | end 130 | -------------------------------------------------------------------------------- /src/deferred1.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | module Scheduler = Scheduler1 4 | 5 | include Deferred0 6 | 7 | (* To avoid a space leak, it is necessary that [never] allocates a new ivar whenever it is 8 | called. Code can bind on [never ()], so if we re-used the ivar, we could endlessly 9 | accumulate handlers. *) 10 | let never () = Ivar.read (Ivar.create ()) 11 | 12 | module M = 13 | Monad.Make (struct 14 | include Deferred0 15 | 16 | let map t ~f = 17 | (* We manually inline [Deferred.create] here, because the non-flambda compiler isn't 18 | able to optimize away the closure that would be be created. *) 19 | let result = Ivar.create () in 20 | upon t (fun a -> Ivar.fill result (f a)); 21 | of_ivar result 22 | ;; 23 | 24 | let map = `Custom map 25 | end) 26 | 27 | include (M : (module type of struct include M end 28 | with module Let_syntax := M.Let_syntax)) 29 | 30 | (* We rebind all the various [return]s because the use of the [Monad.Make] functor 31 | causes the compiler to not inline [return], and hence makes it impossible to 32 | statically allocate constants like [return ()]. By rebinding [return] as 33 | [Deferred0.return], the compiler can see that: 34 | 35 | {[ 36 | return a = { Ivar.Immutable. cell = Full a } ]} 37 | 38 | And hence, if [a] is constant, then the return is constant and can be statically 39 | allocated. When compiling with flambda, the compiler inlines [return] and this manual 40 | rebinding would not help; we've decided to do it anyway so that non-flambda builds 41 | get the optimization. *) 42 | let return = Deferred0.return 43 | module Let_syntax 44 | : module type of struct 45 | include M.Let_syntax 46 | end [@ocaml.remove_aliases] = struct 47 | include (M.Let_syntax : (module type of struct include M.Let_syntax end 48 | with module Let_syntax := M.Let_syntax.Let_syntax)) 49 | let return = Deferred0.return 50 | module Let_syntax = struct 51 | include M.Let_syntax.Let_syntax 52 | let return = Deferred0.return 53 | end 54 | end 55 | 56 | open Let_syntax 57 | 58 | (* We shadow [all] on-purpose here, since the default definition introduces a chain of 59 | binds as long as the list. *) 60 | let all = `Make_sure_to_define_all_elsewhere 61 | let _ = all 62 | 63 | let unit = return () 64 | 65 | let ignore = ignore_m 66 | 67 | let both t1 t2 = 68 | create (fun result -> 69 | upon t1 (fun a1 -> upon t2 (fun a2 -> Ivar.fill result (a1, a2)))) 70 | ;; 71 | 72 | module Infix = struct 73 | include Monad_infix 74 | 75 | let (>>>) = upon 76 | let ppx_both = both 77 | end 78 | 79 | open Infix 80 | 81 | let don't_wait_for (_ : unit t) = () 82 | 83 | module Choice = struct 84 | type +'a t = T : 'b Deferred0.t * ('b -> 'a) -> 'a t 85 | 86 | let map (T (t, f1)) ~f:f2 = T (t, fun x -> f2 (f1 x)) 87 | end 88 | 89 | type 'a choice = 'a Choice.t 90 | 91 | module Unregister = struct 92 | (* This representation saves 2n words for a list of n choices. *) 93 | type t = 94 | | Nil : t 95 | | Cons : 'a Deferred0.t * 'a Deferred0.Handler.t * t -> t 96 | 97 | let rec process = function 98 | | Nil -> () 99 | | Cons (t, handler, rest) -> 100 | remove_handler t handler; 101 | process rest 102 | ;; 103 | end 104 | 105 | let choice t f = Choice.T (t, f) 106 | 107 | let enabled choices = 108 | let result = Ivar.create () in 109 | let unregisters = ref Unregister.Nil in 110 | let ready _ = 111 | if Ivar.is_empty result 112 | then ( 113 | Unregister.process !unregisters; 114 | Ivar.fill result (fun () -> 115 | List.rev 116 | (List.fold choices ~init:[] ~f:(fun ac (Choice.T (t, f)) -> 117 | match peek t with 118 | | None -> ac 119 | | Some v -> f v :: ac)))); 120 | in 121 | let execution_context = Scheduler.(current_execution_context (t ())) in 122 | unregisters := 123 | List.fold choices ~init:Unregister.Nil ~f:(fun acc (Choice.T (t, _)) -> 124 | Cons (t, 125 | Deferred0.add_handler t ready execution_context, 126 | acc)); 127 | Ivar.read result 128 | ;; 129 | 130 | let rec choose_result choices = 131 | match choices with 132 | | [] -> assert false 133 | | Choice.T (t, f) :: choices -> 134 | match peek t with 135 | | None -> choose_result choices 136 | | Some v -> f v 137 | ;; 138 | 139 | let choose choices = 140 | let result = Ivar.create () in 141 | let unregisters = ref Unregister.Nil in 142 | let ready _ = 143 | if Ivar.is_empty result 144 | then ( 145 | Unregister.process !unregisters; 146 | Ivar.fill result (choose_result choices)); 147 | in 148 | let execution_context = Scheduler.(current_execution_context (t ())) in 149 | unregisters := 150 | List.fold choices ~init:Unregister.Nil ~f:(fun acc (Choice.T (t, _)) -> 151 | Cons (t, 152 | Deferred0.add_handler t ready execution_context, 153 | acc)); 154 | Ivar.read result 155 | ;; 156 | 157 | let any_f ts f = choose (List.map ts ~f:(fun t -> choice t f)) 158 | let any ts = any_f ts Fn.id 159 | let any_unit ts = any_f ts Fn.ignore 160 | 161 | let for_ start ~to_ ~do_ = 162 | let rec loop i = 163 | if i > to_ 164 | then (return ()) 165 | else ( 166 | let%bind () = do_ i in 167 | loop (i + 1)) 168 | in 169 | loop start 170 | ;; 171 | 172 | let repeat_until_finished state f = 173 | create (fun finished -> 174 | let rec loop state = 175 | f state 176 | >>> function 177 | | `Repeat state -> loop state 178 | | `Finished result -> Ivar.fill finished result 179 | in 180 | loop state) 181 | ;; 182 | 183 | let forever state f = 184 | repeat_until_finished state (fun state -> let%map state = f state in `Repeat state) 185 | >>> never_returns 186 | ;; 187 | 188 | type how = Monad_sequence.how [@@deriving sexp_of] 189 | 190 | module type Monad_sequence = Monad_sequence.S 191 | with type 'a monad := 'a t 192 | 193 | 194 | let fold t ~init ~f = 195 | create 196 | (fun result -> 197 | let rec loop t b = 198 | match t with 199 | | [] -> Ivar.fill result b 200 | | x :: xs -> f b x >>> fun b -> loop xs b 201 | in 202 | loop t init) 203 | ;; 204 | 205 | let seqmap t ~f = 206 | fold t ~init:[] ~f:(fun bs a -> f a >>| fun b -> b :: bs) 207 | >>| List.rev 208 | ;; 209 | 210 | let all ds = seqmap ds ~f:Fn.id 211 | 212 | let all_unit ds = fold ds ~init:() ~f:(fun () d -> d) 213 | let all_ignore = all_unit 214 | 215 | let ok x = x >>| fun x -> Ok x 216 | -------------------------------------------------------------------------------- /src/job_queue.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Scheduler = Scheduler0 5 | 6 | let dummy_e = Execution_context.main 7 | let dummy_f : Obj.t -> unit = ignore 8 | let dummy_a : Obj.t = Obj.repr () 9 | 10 | module A = Core_kernel.Obj_array 11 | 12 | let slots_per_elt = 3 13 | 14 | (* This is essentially a specialized [Flat_queue], done for reasons of speed. *) 15 | type t = Types.Job_queue.t = 16 | { mutable num_jobs_run : int 17 | ; mutable jobs_left_this_cycle : int 18 | (* [jobs] is an array of length [capacity t * slots_per_elt], where each elt has the 19 | three components of a job ([execution_context], [f], [a]) in consecutive spots in 20 | [jobs]. [enqueue] doubles the length of [jobs] if [jobs] is full. [jobs] never 21 | shrinks. *) 22 | ; mutable jobs : A.t 23 | (* [mask] is [capacity t - 1], and is used for quickly computing [i mod (capacity 24 | t)] *) 25 | ; mutable mask : int 26 | (* [front] is the index of the first job in the queue. The array index of that job's 27 | execution context is [front * slots_per_elt]. *) 28 | ; mutable front : int 29 | ; mutable length : int } 30 | [@@deriving fields, sexp_of] 31 | 32 | let offset t i = ((t.front + i) land t.mask) * slots_per_elt 33 | 34 | let capacity t = t.mask + 1 35 | 36 | let invariant t : unit = 37 | Invariant.invariant [%here] t [%sexp_of: t] (fun () -> 38 | let check f = Invariant.check_field t f in 39 | Fields.iter 40 | ~num_jobs_run:(check (fun num_jobs_run -> 41 | assert (num_jobs_run >= 0))) 42 | ~jobs_left_this_cycle:(check (fun jobs_left_this_cycle -> 43 | assert (jobs_left_this_cycle >= 0))) 44 | ~jobs:(check (fun jobs -> 45 | for i = 0 to t.length - 1 do 46 | Execution_context.invariant (Obj.obj (A.get jobs (offset t i)) 47 | : Execution_context.t); 48 | done)) 49 | ~mask:(check (fun mask -> 50 | let capacity = mask + 1 in 51 | assert (Int.is_pow2 capacity); 52 | assert (capacity * slots_per_elt = A.length t.jobs))) 53 | ~front:(check (fun front -> 54 | assert (front >= 0); 55 | assert (front < capacity t))) 56 | ~length:(check (fun length -> 57 | assert (length >= 0); 58 | assert (length <= capacity t)))) 59 | ;; 60 | 61 | let create_array ~capacity = A.create_zero ~len:(capacity * slots_per_elt) 62 | 63 | let create () = 64 | let capacity = 1 in 65 | { num_jobs_run = 0 66 | ; jobs_left_this_cycle = 0 67 | ; jobs = create_array ~capacity 68 | ; mask = capacity - 1 69 | ; front = 0 70 | ; length = 0 } 71 | ;; 72 | 73 | let clear t = t.front <- 0; t.length <- 0; t.jobs_left_this_cycle <- 0 74 | 75 | let grow t = 76 | let old_capacity = capacity t in 77 | let new_capacity = old_capacity * 2 in 78 | let old_jobs = t.jobs in 79 | let old_front = t.front in 80 | let len1 = (Int.min t.length (old_capacity - old_front)) * slots_per_elt in 81 | let len2 = t.length * slots_per_elt - len1 in 82 | let new_jobs = create_array ~capacity:new_capacity in 83 | A.blit ~len:len1 84 | ~src:old_jobs ~src_pos:(old_front * slots_per_elt) 85 | ~dst:new_jobs ~dst_pos:0; 86 | A.blit ~len:len2 87 | ~src:old_jobs ~src_pos:0 88 | ~dst:new_jobs ~dst_pos:len1; 89 | t.mask <- new_capacity - 1; 90 | t.jobs <- new_jobs; 91 | t.front <- 0; 92 | ;; 93 | 94 | let set (type a) t i execution_context f a = 95 | let offset = offset t i in 96 | A.unsafe_set t.jobs offset (Obj.repr (execution_context : Execution_context.t)); 97 | A.unsafe_set t.jobs (offset + 1) (Obj.repr (f : a -> unit)); 98 | A.unsafe_set t.jobs (offset + 2) (Obj.repr (a : a)); 99 | ;; 100 | 101 | let enqueue t execution_context f a = 102 | if t.length = capacity t then (grow t); 103 | set t t.length execution_context f a; 104 | t.length <- t.length + 1; 105 | ;; 106 | 107 | let set_jobs_left_this_cycle t n = 108 | if n < 0 109 | then ( 110 | raise_s [%message 111 | "Jobs.set_jobs_left_this_cycle got negative number" (n : int) (t : t)]); 112 | t.jobs_left_this_cycle <- n; 113 | ;; 114 | 115 | let can_run_a_job t = t.length > 0 && t.jobs_left_this_cycle > 0 116 | 117 | let run_job t (scheduler : Scheduler.t) execution_context f a = 118 | t.num_jobs_run <- t.num_jobs_run + 1; 119 | Scheduler.set_execution_context scheduler execution_context; 120 | f a; 121 | ;; 122 | 123 | let run_external_jobs t (scheduler : Scheduler.t) = 124 | let external_jobs = scheduler.external_jobs in 125 | while Thread_safe_queue.length external_jobs > 0 do 126 | let External_job.T (execution_context, f, a) = 127 | Thread_safe_queue.dequeue_exn external_jobs 128 | in 129 | run_job t scheduler execution_context f a; 130 | done; 131 | ;; 132 | 133 | let run_jobs (type a) t scheduler = 134 | (* We do the [try-with] outside of the [while] because it is cheaper than doing a 135 | [try-with] for each job. *) 136 | try 137 | (* [run_external_jobs] before entering the loop, since it might enqueue a job, 138 | changing [t.length]. *) 139 | run_external_jobs t scheduler; 140 | while can_run_a_job t do 141 | let this_job = offset t 0 in 142 | let execution_context = 143 | (Obj.obj (A.unsafe_get t.jobs this_job) : Execution_context.t) 144 | in 145 | let f = (Obj.obj (A.unsafe_get t.jobs (this_job + 1)) : a -> unit) in 146 | let a = (Obj.obj (A.unsafe_get t.jobs (this_job + 2)) : a ) in 147 | (* We clear out the job right now so that it isn't live at the next minor 148 | collection. We tried not doing this and saw significant (15% or so) performance 149 | hits due to spurious promotion. *) 150 | set t 0 dummy_e dummy_f dummy_a; 151 | t.front <- (t.front + 1) land t.mask; 152 | t.length <- t.length - 1; 153 | t.jobs_left_this_cycle <- t.jobs_left_this_cycle - 1; 154 | (* It is OK if [run_job] or [run_external_jobs] raises, in which case the exn is 155 | handled by the outer try-with. The only side effects we have done are to take 156 | the job out of the queue and decrement [jobs_left_this_cycle]. [run_job] or 157 | [run_external_jobs] may side effect [t], either by enqueueing jobs, or by 158 | clearing [t]. *) 159 | run_job t scheduler execution_context f a; 160 | (* [run_external_jobs] at each iteration of the [while] loop, for fairness. *) 161 | run_external_jobs t scheduler; 162 | done; 163 | Result.ok_unit 164 | with exn -> 165 | (* We call [Exn.backtrace] immediately after catching an unhandled exception, to 166 | ensure there is no intervening code that interferes with the global backtrace 167 | state. *) 168 | let backtrace = Backtrace.Exn.most_recent () in 169 | Error (exn, backtrace) 170 | ;; 171 | -------------------------------------------------------------------------------- /src/async_stream.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | 4 | module Deferred = Deferred1 5 | 6 | include Tail.Stream 7 | 8 | let first_exn t = 9 | match%map next t with 10 | | Nil -> raise_s [%message "Stream.first of empty stream"] 11 | | Cons (x, _) -> x 12 | ;; 13 | 14 | let fold' t ~init ~f = 15 | Deferred.create 16 | (fun result -> 17 | let rec loop t b = 18 | upon (next t) (function 19 | | Nil -> Ivar.fill result b 20 | | Cons (v, t) -> upon (f b v) (loop t)) 21 | in 22 | loop t init) 23 | ;; 24 | 25 | (* [fold] is implemented to avoid per-stream-element deferred overhead in the case when 26 | multiple stream elements are available simultaneously. *) 27 | let fold t ~init ~f = 28 | Deferred.create 29 | (fun result -> 30 | let rec loop t b = 31 | match Deferred.peek (next t) with 32 | | None -> upon (next t) (fun next -> loop_next next b) 33 | | Some next -> loop_next next b 34 | and loop_next next b = 35 | match next with 36 | | Nil -> Ivar.fill result b 37 | | Cons (v, t) -> loop t (f b v) 38 | in 39 | loop t init) 40 | ;; 41 | 42 | let length t = fold t ~init:0 ~f:(fun n _ -> n + 1) 43 | 44 | let iter' t ~f = fold' t ~init:() ~f:(fun () v -> f v) 45 | 46 | let closed t = 47 | match Deferred.peek (next t) with 48 | | Some Nil -> return () 49 | | _ -> iter' t ~f:(fun _ -> return ()) 50 | ;; 51 | 52 | let iter t ~f = don't_wait_for (iter' t ~f:(fun a -> f a; return ())) 53 | 54 | let create f = 55 | let tail = Tail.create () in 56 | (* collect before calling [f], in case [f] immediately extends. *) 57 | let t = Tail.collect tail in 58 | f tail; 59 | t 60 | ;; 61 | 62 | let unfold b ~f = 63 | create (fun tail -> 64 | let rec loop b = 65 | upon (f b) (function 66 | | None -> Tail.close_exn tail 67 | | Some (a, b) -> Tail.extend tail a; loop b) 68 | in 69 | loop b) 70 | ;; 71 | 72 | let of_list l = 73 | create (fun tail -> 74 | List.iter l ~f:(fun x -> Tail.extend tail x); 75 | Tail.close_exn tail) 76 | ;; 77 | 78 | let to_list s = fold' s ~init:[] ~f:(fun b a -> return (a :: b)) >>| List.rev 79 | 80 | let copy_to_tail t tail = iter' t ~f:(fun a -> return (Tail.extend tail a)) 81 | 82 | let append t1 t2 = 83 | create (fun tail -> 84 | upon (copy_to_tail t1 tail) (fun () -> 85 | upon (copy_to_tail t2 tail) (fun () -> 86 | Tail.close_exn tail))) 87 | ;; 88 | 89 | let concat t = 90 | create (fun tail -> 91 | upon (iter' t ~f:(fun t -> copy_to_tail t tail)) 92 | (fun () -> Tail.close_exn tail)) 93 | ;; 94 | 95 | let filter' t ~f = 96 | create (fun tail -> 97 | upon 98 | (iter' t ~f:(fun v -> 99 | match%map f v with 100 | | false -> () 101 | | true -> Tail.extend tail v)) 102 | (fun () -> Tail.close_exn tail)) 103 | ;; 104 | 105 | let filter_deprecated t ~f = filter' t ~f:(fun a -> return (f a)) 106 | 107 | let filter_map' t ~f = 108 | create (fun tail -> 109 | upon 110 | (iter' t ~f:(fun v -> 111 | match%map f v with 112 | | None -> () 113 | | Some v -> Tail.extend tail v)) 114 | (fun () -> Tail.close_exn tail)) 115 | ;; 116 | 117 | let filter_map_deprecated t ~f = filter_map' t ~f:(fun a -> return (f a)) 118 | 119 | let map' t ~f = 120 | create (fun tail -> 121 | upon (iter' t ~f:(fun v -> f v >>| Tail.extend tail)) 122 | (fun () -> Tail.close_exn tail)) 123 | ;; 124 | 125 | let map t ~f = map' t ~f:(fun a -> return (f a)) 126 | 127 | let first_n s n = 128 | create (fun tail -> 129 | let rec loop s n = 130 | if n = 0 131 | then (Tail.close_exn tail) 132 | else ( 133 | upon (next s) (function 134 | | Nil -> Tail.close_exn tail 135 | | Cons (x, t) -> Tail.extend tail x; loop t (n - 1))) 136 | in 137 | loop s n) 138 | ;; 139 | 140 | let available_now t = 141 | let rec loop t ac = 142 | match Deferred.peek (next t) with 143 | | None | Some Nil -> (List.rev ac, t) 144 | | Some (Cons (x, t)) -> loop t (x :: ac) 145 | in 146 | loop t [] 147 | ;; 148 | 149 | let split ?(stop = Deferred.never ()) ?(f = (fun _ -> `Continue)) t = 150 | let reason_for_stopping = Ivar.create () in 151 | let prefix = Tail.create () in 152 | let finish v = Tail.close_exn prefix; Ivar.fill reason_for_stopping v in 153 | let rec loop t = 154 | choose [ choice stop (fun () -> `Stopped) 155 | ; choice (next t) (fun o -> `Next o) ] 156 | >>> function 157 | | `Stopped -> finish (`Stopped t) 158 | | `Next o -> 159 | match o with 160 | | Nil -> finish `End_of_stream 161 | | Cons (a, t) -> 162 | match f a with 163 | | `Continue -> Tail.extend prefix a; loop t 164 | | `Found b -> finish (`Found (b, t)) 165 | in 166 | loop t; 167 | (Tail.collect prefix, Ivar.read reason_for_stopping) 168 | ;; 169 | 170 | let find t ~f = 171 | let (_, found) = split t ~f:(fun a -> if f a then (`Found a) else `Continue) in 172 | match%map found with 173 | | `Stopped _ -> assert false 174 | | `End_of_stream | `Found _ as x -> x 175 | ;; 176 | 177 | let ungroup t = 178 | create (fun tail -> 179 | upon (iter' t ~f:(fun l -> 180 | List.iter l ~f:(fun x -> Tail.extend tail x); return ())) 181 | (fun () -> Tail.close_exn tail)) 182 | ;; 183 | 184 | let interleave ts = 185 | create (fun tail -> 186 | (* The interleaved stream should be closed when the outer stream and all of 187 | the inner streams have been closed. Keep a count of the number of open 188 | streams and close the interleaved stream when that count becomes 189 | zero. *) 190 | let num_open = ref 1 in (* 1 for the outer stream that is open *) 191 | let close () = 192 | num_open := !num_open - 1; 193 | if !num_open = 0 then (Tail.close_exn tail); 194 | in 195 | let outer_closed = 196 | iter' ts ~f:(fun t -> 197 | num_open := !num_open + 1; 198 | upon (copy_to_tail t tail) close; 199 | return ()) 200 | in 201 | upon outer_closed close) 202 | ;; 203 | 204 | let take_until t d = 205 | create (fun tail -> 206 | let rec loop t = 207 | upon (choose [ choice d (fun () -> `Stop) 208 | ; choice (next t) (fun z -> `Next z) ]) 209 | (function 210 | | `Stop | `Next Nil -> Tail.close_exn tail 211 | | `Next (Cons (x, t)) -> Tail.extend tail x; loop t) 212 | in 213 | loop t) 214 | ;; 215 | 216 | let iter_durably' t ~f = 217 | Deferred.create (fun result -> 218 | let rec loop t = 219 | next t 220 | >>> function 221 | | Nil -> Ivar.fill result () 222 | | Cons (x, t) -> 223 | Monitor.try_with ~rest:`Raise (fun () -> f x) 224 | >>> fun z -> 225 | loop t; 226 | match z with 227 | | Ok () -> () 228 | | Error e -> Monitor.send_exn (Monitor.current ()) e 229 | in 230 | loop t) 231 | ;; 232 | 233 | let iter_durably_report_end t ~f = 234 | Deferred.create (fun result -> 235 | let rec loop t = 236 | next t 237 | >>> function 238 | | Nil -> Ivar.fill result () 239 | | Cons (x, t) -> 240 | (* We immediately call [loop], thus making the iter durable. Any exceptions 241 | raised by [f] will not prevent the loop from continuing, and will go to the 242 | monitor of whomever called [iter_durably_report_end]. *) 243 | loop t; f x 244 | in 245 | loop t) 246 | ;; 247 | 248 | let iter_durably t ~f = don't_wait_for (iter_durably_report_end t ~f) 249 | 250 | let of_fun f = unfold () ~f:(fun () -> let%map a = f () in Some (a, ())) 251 | -------------------------------------------------------------------------------- /src/types.ml: -------------------------------------------------------------------------------- 1 | (* This file defines the mutually recursive types at the heart of Async. The functions 2 | associated with the types are defined in the corresponding file(s) for each module. 3 | This file should define onlye types, not functions, since functions defined inside the 4 | recursive modules are not inlined. 5 | 6 | If you need to add functionality to a module but doing so would create a dependency 7 | cycle, split the file into pieces as needed to break the cycle, e.g. scheduler0.ml, 8 | scheduler1.ml, scheduler.ml. *) 9 | 10 | open! Core_kernel 11 | open! Import 12 | 13 | module rec Bvar : sig 14 | type ('a, -'permission) t 15 | 16 | (** [repr] exists so that we may hide the implementation of a [Bvar.t], and then add a 17 | phantom type to it upstream. Without this, the phantom type variable would allow 18 | for anything to be coerced in and out, since it is unused. *) 19 | type 'a repr = 20 | { mutable has_any_waiters : bool 21 | ; mutable ivar : 'a Ivar.t } 22 | 23 | val of_repr : 'a repr -> ('a, 'permission) t 24 | val to_repr : ('a, 'permission) t -> 'a repr 25 | end = struct 26 | type 'a repr = 27 | { mutable has_any_waiters : bool 28 | ; mutable ivar : 'a Ivar.t } 29 | 30 | type ('a, 'permission) t = 'a repr 31 | 32 | let to_repr t = t 33 | let of_repr t = t 34 | end 35 | 36 | and Cell : sig 37 | type any = 38 | [ `Empty 39 | | `Empty_one_handler 40 | | `Empty_one_or_more_handlers 41 | | `Full 42 | | `Indir ] 43 | 44 | type ('a, 'b) t = 45 | | Empty_one_or_more_handlers 46 | : { mutable run : 'a -> unit 47 | ; execution_context : Execution_context.t 48 | ; mutable prev : 'a Handler.t 49 | ; mutable next : 'a Handler.t 50 | } -> ('a, [> `Empty_one_or_more_handlers ]) t 51 | | Empty_one_handler 52 | : ('a -> unit) * Execution_context.t -> ('a, [> `Empty_one_handler ]) t 53 | | Empty : ('a, [> `Empty ]) t 54 | | Full : 'a -> ('a, [> `Full ]) t 55 | | Indir : 'a Ivar.t -> ('a, [> `Indir ]) t 56 | end = Cell 57 | 58 | and Deferred : sig 59 | type +'a t 60 | end = Deferred 61 | 62 | and Event : sig 63 | module Status : sig 64 | type t = 65 | | Fired 66 | | Happening 67 | | Scheduled 68 | | Unscheduled 69 | end 70 | 71 | type t = 72 | { mutable alarm : Job_or_event.t Timing_wheel_ns.Alarm.t 73 | ; mutable at : Time_ns.t 74 | ; callback : unit -> unit 75 | ; execution_context : Execution_context.t 76 | ; mutable interval : Time_ns.Span.t option 77 | ; mutable next_fired : t 78 | ; mutable status : Status.t } 79 | end = Event 80 | 81 | and Execution_context : sig 82 | type t = 83 | { monitor : Monitor.t 84 | ; priority : Priority.t 85 | ; local_storage : Univ_map.t 86 | ; backtrace_history : Backtrace.t list } 87 | end = Execution_context 88 | 89 | and External_job : sig 90 | type t = T : Execution_context.t * ('a -> unit) * 'a -> t 91 | end = External_job 92 | 93 | and Handler : sig 94 | type 'a t = ('a, [ `Empty_one_or_more_handlers ]) Cell.t 95 | end = Handler 96 | 97 | and Ivar : sig 98 | type 'a t = 99 | { mutable cell : ('a, Cell.any) Cell.t } 100 | module Immutable : sig 101 | type 'a t = 102 | { cell : ('a, Cell.any) Cell.t } 103 | end 104 | end = Ivar 105 | 106 | and Job : sig 107 | type slots = (Execution_context.t, Obj.t -> unit, Obj.t) Pool.Slots.t3 108 | type t = slots Pool.Pointer.t 109 | end = Job 110 | 111 | and Job_or_event : sig 112 | type t 113 | end = Job_or_event 114 | 115 | and Job_pool : sig 116 | type t = Job.slots Pool.t 117 | end = Job_pool 118 | 119 | and Job_queue : sig 120 | type t = 121 | { mutable num_jobs_run : int 122 | ; mutable jobs_left_this_cycle : int 123 | ; mutable jobs : Core_kernel.Obj_array.t 124 | ; mutable mask : int 125 | ; mutable front : int 126 | ; mutable length : int } 127 | end = Job_queue 128 | 129 | and Jobs : sig 130 | type t = 131 | { scheduler : Scheduler.t 132 | ; mutable job_pool : Job_pool.t 133 | ; normal : Job_queue.t 134 | ; low : Job_queue.t } 135 | end = Jobs 136 | 137 | and Monitor : sig 138 | type t = 139 | { name : Info.t 140 | ; here : Source_code_position.t option 141 | ; id : int 142 | ; parent : t option 143 | ; mutable next_error : exn Ivar.t 144 | ; mutable handlers_for_all_errors : (Execution_context.t * (exn -> unit)) Bag.t 145 | ; mutable tails_for_all_errors : exn Tail.t list 146 | ; mutable has_seen_error : bool 147 | ; mutable is_detached : bool } 148 | end = Monitor 149 | 150 | and Scheduler : sig 151 | type t = 152 | { mutable check_access : (unit -> unit) option 153 | ; mutable job_pool : Job_pool.t 154 | ; normal_priority_jobs : Job_queue.t 155 | ; low_priority_jobs : Job_queue.t 156 | ; very_low_priority_workers : Very_low_priority_worker.t Deque.t 157 | ; mutable main_execution_context : Execution_context.t 158 | ; mutable current_execution_context : Execution_context.t 159 | ; mutable uncaught_exn : (Exn.t * Sexp.t) option 160 | ; mutable cycle_count : int 161 | ; mutable cycle_start : Time_ns.t 162 | ; mutable run_every_cycle_start : (unit -> unit) list 163 | ; mutable last_cycle_time : Time_ns.Span.t 164 | ; mutable last_cycle_num_jobs : int 165 | ; mutable time_source : read_write Time_source.t1 166 | ; external_jobs : External_job.t Thread_safe_queue.t 167 | ; mutable thread_safe_external_job_hook : unit -> unit 168 | ; mutable job_queued_hook : (Priority.t -> unit) option 169 | ; mutable event_added_hook : (Time_ns.t -> unit) option 170 | ; mutable yield : (unit, read_write) Bvar.t 171 | ; mutable yield_until_no_jobs_remain : (unit, read_write) Bvar.t 172 | ; mutable check_invariants : bool 173 | ; mutable max_num_jobs_per_priority_per_cycle : Max_num_jobs_per_priority_per_cycle.t 174 | ; mutable record_backtraces : bool 175 | ; mutable on_start_of_cycle : unit -> unit 176 | ; mutable on_end_of_cycle : unit -> unit } 177 | end = Scheduler 178 | 179 | and Stream : sig 180 | type 'a t = 'a next Deferred.t 181 | and 'a next = Nil | Cons of 'a * 'a t 182 | end = Stream 183 | 184 | and Tail : sig 185 | type 'a t = 186 | { mutable next: 'a Stream.next Ivar.t } 187 | end = Tail 188 | 189 | and Time_source : sig 190 | type -'rw t1 = 191 | { mutable advance_errors : Error.t list 192 | ; mutable am_advancing : bool 193 | ; events : Job_or_event.t Timing_wheel_ns.t 194 | ; mutable fired_events : Event.t 195 | ; mutable most_recently_fired : Event.t 196 | ; handle_fired : Job_or_event.t Timing_wheel_ns.Alarm.t -> unit 197 | ; is_wall_clock : bool 198 | ; scheduler : Scheduler.t } 199 | end = Time_source 200 | 201 | and Very_low_priority_worker : sig 202 | module Exec_result : sig 203 | type t = 204 | | Finished 205 | | Not_finished 206 | end 207 | 208 | type t = 209 | { execution_context : Execution_context.t 210 | ; exec : unit -> Exec_result.t } 211 | end = Very_low_priority_worker 212 | -------------------------------------------------------------------------------- /src/deferred.mli: -------------------------------------------------------------------------------- 1 | (** A value that will become determined asynchronously. 2 | 3 | A deferred can be "undetermined" or "determined". A deferred that is undetermined may 4 | at some point become determined with value v, and will henceforth always be determined 5 | with value v. *) 6 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | type +'a t = 'a Deferred1.t [@@deriving sexp_of] 11 | 12 | include Invariant.S1 with type 'a t := 'a t 13 | 14 | (** [sexp_of_t t f] returns a sexp of the deferred's value, if it is determined, or an 15 | informative string otherwise. 16 | 17 | This is just for display purposes. There is no [t_of_sexp]. *) 18 | 19 | (** [create f] calls [f i], where [i] is an empty ivar. [create] returns a deferred that 20 | becomes determined when [f] fills [i]. *) 21 | val create : ('a Ivar.t -> unit) -> 'a t 22 | 23 | (** [upon t f] will run [f v] at some point after [t] becomes determined with value 24 | [v]. *) 25 | val upon : 'a t -> ('a -> unit) -> unit 26 | 27 | (** [peek t] returns [Some v] iff [t] is determined with value [v]. *) 28 | val peek : 'a t -> 'a option 29 | 30 | (** [value_exn t] returns [v] if [t] is determined with value [v], and raises 31 | otherwise. *) 32 | val value_exn : 'a t -> 'a 33 | 34 | (** [is_determined t] returns [true] iff [t] is determined. *) 35 | val is_determined : 'a t -> bool 36 | 37 | (** Deferreds form a monad. 38 | 39 | [let%bind v = t in f v] returns a deferred [t'] that waits until [t] is determined 40 | with value [v], at which point it waits for [f v] to become determined with value 41 | [v'], to which [t'] will become determined. 42 | 43 | [return v] returns a deferred that is immediately determined with value v. 44 | 45 | Note that: 46 | 47 | {[ upon t f ]} 48 | 49 | is more efficient than: 50 | 51 | {[ ignore (let%bind a = t in f a; return ()) ]} 52 | 53 | because [upon], unlike [let%bind], does not create a deferred to hold the result. 54 | 55 | For example, one can write a loop that has good constant factors with: 56 | 57 | {[ 58 | let rec loop () = 59 | upon t (fun a -> ... loop () ... ) ]} 60 | 61 | although often [forever] or [repeat_until_finished] is more clear. 62 | 63 | The same loop written with [let%bind] would allocate deferreds that would be 64 | immediately garbage collected. (In the past, this loop would have also used linear 65 | space in recursion depth!) 66 | 67 | In general, for deferreds that are allocated by [let%bind] to be garbage collected 68 | quickly, it is sufficient that the allocating bind be executed in tail-call position 69 | of the right-hand side of an outer bind. *) 70 | include Monad with type 'a t := 'a t 71 | 72 | module Infix : sig 73 | include Monad.Infix with type 'a t := 'a t 74 | val (>>>) : 'a t -> ('a -> unit) -> unit 75 | end 76 | 77 | (** [unit] is a deferred that is always determined with value [()] *) 78 | val unit : unit t 79 | 80 | val ignore : _ t -> unit t 81 | 82 | (** [never ()] returns a deferred that never becomes determined. *) 83 | val never : unit -> _ t 84 | 85 | (** [both t1 t2] becomes determined after both [t1] and [t2] become determined. *) 86 | val both : 'a t -> 'b t -> ('a * 'b) t 87 | 88 | (** [all ts] returns a deferred that becomes determined when every [t] in [t]s is 89 | determined. The output is in the same order as the input. *) 90 | val all : 'a t list -> 'a list t 91 | 92 | (** Like [all], but ignores results of the component deferreds. *) 93 | val all_unit : unit t list -> unit t 94 | 95 | (** [any ts] returns a deferred that is determined when any of the underlying deferreds is 96 | determined. *) 97 | val any : 'a t list -> 'a t 98 | 99 | (** [any_unit] is like [any], but ignores results of the component deferreds. *) 100 | val any_unit : 'a t list -> unit t 101 | 102 | (** [don't_wait_for t] ignores [t]. It is like [Fn.ignore], but is more constrained 103 | because it requires a [unit Deferred.t]. 104 | 105 | Rather than [ignore (t : _ t)], do [don't_wait_for (Deferred.ignore t)]. 106 | 107 | We chose to give [don't_wait_for] type [unit t] rather than [_ t] to catch errors 108 | where a value is accidentally ignored. *) 109 | val don't_wait_for : unit t -> unit 110 | 111 | (** A [Choice.t] is used to produce an argument to [enabled] or [choose]. See below. *) 112 | module Choice : sig 113 | type +'a t = 'a Deferred1.choice 114 | 115 | val map : 'a t -> f:('a -> 'b) -> 'b t 116 | end 117 | 118 | type 'a choice = 'a Choice.t 119 | 120 | val choice : 'a t -> ('a -> 'b) -> 'b Choice.t 121 | 122 | (** [enabled [choice t1 f1; ... choice tn fn;]] returns a deferred [d] that becomes 123 | determined when any of the [ti] becomes determined. The value of [d] is a function 124 | [f] that when called, for each [ti] that is enabled, applies [fi] to [ti], and returns 125 | a list of the results. It is guaranteed that the list is in the same order as the 126 | choices supplied to [enabled], but of course it may be shorter than the input list if 127 | not all [ti] are determined. *) 128 | val enabled : 'b Choice.t list -> (unit -> 'b list) t 129 | 130 | (** 131 | {[ 132 | choose [ choice t1 f1 133 | ; ... 134 | ; choice tn fn ] ]} 135 | 136 | returns a deferred [t] that becomes determined with value [fi ai] after some [ti] 137 | becomes determined with value [ai]. It is guaranteed that [choose] calls at most one 138 | of the [fi]s, the one that determines its result. There is no guarantee 139 | that the [ti] that becomes determined earliest in time will be the one whose value 140 | determines the [choose]. Nor is it guaranteed that the value in [t] is the first value 141 | (in place order) from [choices] that is determined at the time [t] is examined. 142 | 143 | For example, in: 144 | 145 | {[ 146 | choose [ choice t1 (fun () -> `X1) 147 | ; choice t2 (fun () -> `X2) ] 148 | >>> function 149 | | `X1 -> e1 150 | | `X2 -> e2 ]} 151 | 152 | it may be the case that both [t1] and [t2] become determined, yet [e2] actually runs. 153 | 154 | It is guaranteed that if multiple choices are determined with no intervening 155 | asynchrony, then the earliest choice in the list will become the value of the 156 | [choose]. *) 157 | val choose : 'b Choice.t list -> 'b t 158 | 159 | (** [for_ start ~to_:stop ~do_:f] is the deferred analog of: 160 | 161 | {[ 162 | for i = start to stop do 163 | f i; 164 | done ]} *) 165 | val for_ 166 | : int 167 | -> to_ : int 168 | -> do_ : (int -> unit t) 169 | -> unit t 170 | 171 | (** [repeat_until_finished initial_state f] repeatedly runs [f] until [f] returns 172 | [`Finished]. The first call to [f] happens immediately when [repeat_until_finished] 173 | is called. *) 174 | val repeat_until_finished 175 | : 'state 176 | -> ('state -> [ `Repeat of 'state 177 | | `Finished of 'result 178 | ] t) 179 | -> 'result t 180 | 181 | (** [forever initial_state f] repeatedly runs [f], supplying the state returned to the 182 | next call to [f]. *) 183 | val forever 184 | : 'state 185 | -> ('state -> 'state t) 186 | -> unit 187 | 188 | (** Useful for lifting values from the [Deferred.t] monad to the [Result.t Deferred.t] 189 | monad. *) 190 | val ok : 'a t -> ('a, _) Core_kernel.Result.t t 191 | 192 | (** {2 Deferred collections} 193 | 194 | These contain operations for iterating in a deferred manner over different 195 | collection types. *) 196 | 197 | module Array = Deferred_array 198 | module List = Deferred_list 199 | module Map = Deferred_map 200 | module Memo = Deferred_memo 201 | module Queue = Deferred_queue 202 | module Sequence = Deferred_sequence 203 | 204 | (** {2 Error-carrying deferreds} 205 | 206 | These contain interfaces for working with deferred type containing error-aware types, 207 | like ['a Option.t Deferred.t], or ['a Or_error.t Deferred.t]. These all include 208 | support for monadic programming. *) 209 | 210 | module Option = Deferred_option 211 | module Or_error = Deferred_or_error 212 | module Result = Deferred_result 213 | -------------------------------------------------------------------------------- /limiter_async/src/limiter_async.mli: -------------------------------------------------------------------------------- 1 | (** Implements an async aware throttling rate limiter on top of [Limiter]. 2 | 3 | All forms of [enqueue_exn] and [enqueue'] below will raise if the requested job 4 | is not possible to run within the resource limitations given to the related 5 | [create_exn]. 6 | 7 | If any enqueued job raises then the exception will be raised to the monitor in scope 8 | when [enqueue_exn] is called. Deferred jobs passed to [enqueue'] return [Raised] 9 | (in a deferred manner) instead. 10 | 11 | Jobs are always executed in FIFO order. *) 12 | 13 | open! Core_kernel 14 | open! Async_kernel 15 | 16 | (** The outcome of a job *) 17 | module Outcome : sig 18 | type 'a t = 19 | | Ok of 'a 20 | | Aborted 21 | | Raised of exn 22 | [@@deriving sexp_of] 23 | end 24 | 25 | type t [@@deriving sexp_of] 26 | type limiter = t [@@deriving sexp_of] 27 | 28 | 29 | (** {5 Specialized limiters} 30 | 31 | A collection of limiters, specialized to different use-cases, all supporting a shared 32 | subset of their interface *) 33 | 34 | module type Common = sig 35 | type _ t 36 | 37 | (** kills [t], which aborts all enqueued jobs that haven't started and all jobs enqueued 38 | in the future. If [t] has already been killed, then calling [kill t] has no effect. 39 | Note that kill does not affect currently running jobs in any way. *) 40 | val kill : _ t -> unit 41 | 42 | (** [is_dead t] returns [true] if [t] was killed, either by [kill] or by an unhandled 43 | exception in a job. *) 44 | val is_dead : _ t -> bool 45 | 46 | (** Convert to a limiter *) 47 | val to_limiter : _ t -> limiter 48 | end 49 | 50 | module Token_bucket : sig 51 | type t [@@deriving sexp_of] 52 | type _ u = t 53 | (*_ This type synonym is introduced because older versions of OCaml 54 | do not support destructive substitutions with `type 'a t1 = t2`. *) 55 | 56 | val create_exn 57 | : burst_size:int 58 | -> sustained_rate_per_sec:float 59 | -> continue_on_error:bool (** If false, then the token bucket is [kill]ed if there's 60 | an unhandled exception in any job *) 61 | -> ?in_flight_limit:int (** default to infinite. This can be used for concurrency 62 | control *) 63 | -> ?initial_burst_size:int (** Defaults to zero *) 64 | -> unit 65 | -> t 66 | 67 | (** [enqueue_exn t x f a] enqueues an immediate job consuming [x] tokens, running [f] on 68 | input [a]. 69 | 70 | if [allow_immediate_run] is true then [f] is allowed to run within the same async 71 | job as [enqueue_exn] iff there are enough tokens available to fully run the job and 72 | there are no other previously enqueued jobs that have not run. If this is the case, 73 | it is run before [enqueue_exn] returns. Otherwise no part of [f] is run before 74 | [enqueue_exn] returns. 75 | 76 | If there is a failure associated with this job then the exception will be raised to 77 | the monitor in scope when [enqueue_exn] is called. Note that it may fail for a 78 | number of reasons, including [f] throws an exception, the limiter is killed, or the 79 | number of tokens requested is larger than the burst size. *) 80 | val enqueue_exn : t -> ?allow_immediate_run:bool -> int -> ('a -> unit) -> 'a -> unit 81 | 82 | (** [enqueue' t x f a] enqueues a deferred job consuming [x] tokens, running [f] on 83 | input [a]. No part of f is run before [enqueue'] returns. *) 84 | val enqueue' : t -> int -> ('a -> 'b Deferred.t) -> 'a -> 'b Outcome.t Deferred.t 85 | 86 | include Common with type 'a t := 'a u 87 | end 88 | 89 | (** [Throttle], [Sequencer], and [Resource_throttle] re-implement the functionality 90 | available in the core Async.Throttle module with the hope that these implementations 91 | can eventually supplant that code. It is helpful to use these modules in systems that 92 | can afford to do a bit more testing so that we can get feedback on the behavior of the 93 | new implementation. They are intended to be mostly drop-in replacements. *) 94 | 95 | (** Implements a basic throttle meant to bound the number of jobs that can concurrently 96 | run. Additionally the [~burst_size] and [~sustained_rate_per_sec] arguments can be 97 | used to control how many jobs can be spawned in a burst, and how quickly jobs can be 98 | spawned over time. If these options are not given to [create_exn] they are unbounded. 99 | 100 | [concurrent_jobs_target] is the desired maximum number of concurrent jobs. If the 101 | value is never changed, then this is in fact a hard upper bound. The value is 102 | mutable, however, and so may be violated temporarily if the value is reduced. *) 103 | module Throttle : sig 104 | type t [@@ deriving sexp_of] 105 | type _ u = t 106 | (*_ This type synonym is introduced because older versions of OCaml 107 | do not support destructive substitutions with `type 'a t1 = t2`. *) 108 | 109 | val create_exn 110 | : concurrent_jobs_target:int 111 | -> continue_on_error:bool 112 | -> ?burst_size:int 113 | -> ?sustained_rate_per_sec:float 114 | -> unit 115 | -> t 116 | 117 | val concurrent_jobs_target : t -> int 118 | val num_jobs_waiting_to_start : t -> int 119 | val num_jobs_running : t -> int 120 | 121 | val enqueue_exn : t -> ?allow_immediate_run:bool -> ('a -> unit) -> 'a -> unit 122 | val enqueue' : t -> ('a -> 'b Deferred.t) -> 'a -> 'b Outcome.t Deferred.t 123 | 124 | include Common with type 'a t := 'a u 125 | end 126 | 127 | (** A sequencer is a throttle that is specialized to only allow one job at a time and to, 128 | by default, not continue on error. *) 129 | module Sequencer : sig 130 | type t [@@deriving sexp_of] 131 | type _ u = t 132 | (*_ This type synonym is introduced because older versions of OCaml 133 | do not support destructive substitutions with `type 'a t1 = t2`. *) 134 | 135 | val create 136 | : ?continue_on_error:bool (** default is [false] *) 137 | -> ?burst_size:int 138 | -> ?sustained_rate_per_sec:float 139 | -> unit 140 | -> t 141 | 142 | val enqueue_exn : t -> ?allow_immediate_run:bool -> ('a -> unit) -> 'a -> unit 143 | val enqueue' : t -> ('a -> 'b Deferred.t) -> 'a -> 'b Outcome.t Deferred.t 144 | 145 | val num_jobs_waiting_to_start : t -> int 146 | 147 | include Common with type 'a t := 'a u 148 | end 149 | 150 | (** A resource throttle holds a static list of [n] resources that are handed out in a 151 | round-robin fashion to up to [n] concurrent jobs. A resource given to [create] 152 | may be re-used many times in the lifetime of [t] but will never be used by more 153 | than one job at a time. *) 154 | module Resource_throttle : sig 155 | type 'a t [@@deriving sexp_of] 156 | 157 | val create_exn 158 | : resources:'a list 159 | -> continue_on_error:bool 160 | -> ?burst_size:int 161 | -> ?sustained_rate_per_sec:float 162 | -> unit 163 | -> 'a t 164 | 165 | val max_concurrent_jobs : _ t -> int 166 | 167 | val enqueue_exn : 'a t -> ?allow_immediate_run:bool -> ('a -> unit) -> unit 168 | val enqueue' : 'a t -> ('a -> 'b Deferred.t) -> 'b Outcome.t Deferred.t 169 | 170 | include Common with type 'a t := 'a t 171 | end 172 | 173 | module Expert : sig 174 | (** kills [t], which aborts all enqueued jobs that haven't started and all jobs enqueued 175 | in the future. If [t] has already been killed, then calling [kill t] has no effect. 176 | Note that kill does not affect currently running jobs in any way. *) 177 | val kill : t -> unit 178 | 179 | (** [is_dead t] returns [true] if [t] was killed, either by [kill] or by an unhandled 180 | exception in a job. *) 181 | val is_dead : t -> bool 182 | 183 | (** returns the total cost of all jobs that have been enqueued but have not yet 184 | started. *) 185 | val cost_of_jobs_waiting_to_start : t -> int 186 | 187 | (** returns the underlying limiter. It is an error to do anything with the limiter that 188 | isn't a read-only operation. *) 189 | val to_jane_limiter : t -> Limiter.t 190 | end 191 | -------------------------------------------------------------------------------- /src/persistent_connection.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Deferred_std 3 | 4 | include Persistent_connection_intf 5 | 6 | module Make (Conn : T) = struct 7 | type address = Conn.Address.t [@@deriving sexp_of] 8 | type conn = Conn.t 9 | 10 | module Event = struct 11 | type t = 12 | | Attempting_to_connect 13 | | Obtained_address of address 14 | | Failed_to_connect of Error.t 15 | | Connected of conn sexp_opaque 16 | | Disconnected 17 | [@@deriving sexp_of] 18 | 19 | type event = t 20 | 21 | module Handler = struct 22 | type t = 23 | { server_name : string 24 | ; on_event : event -> unit Deferred.t 25 | } 26 | end 27 | 28 | let log_level = function 29 | | Attempting_to_connect | Connected _ | Disconnected | Obtained_address _ -> `Info 30 | | Failed_to_connect _ -> `Error 31 | 32 | let handle t { Handler. server_name=_; on_event } = 33 | on_event t 34 | end 35 | 36 | type t = 37 | { get_address : unit -> address Or_error.t Deferred.t 38 | ; connect : address -> Conn.t Or_error.t Deferred.t 39 | ; retry_delay : unit -> unit Deferred.t 40 | ; mutable conn : [`Ok of Conn.t | `Close_started] Ivar.t 41 | ; event_handler : Event.Handler.t 42 | ; close_started : unit Ivar.t 43 | ; close_finished : unit Ivar.t 44 | } 45 | [@@deriving fields] 46 | 47 | let handle_event t event = Event.handle event t.event_handler 48 | 49 | (* This function focuses in on the the error itself, discarding information about which 50 | monitor caught the error, if any. 51 | 52 | If we don't do this, we sometimes end up with noisy logs which report the same error 53 | again and again, differing only as to what monitor caught them. *) 54 | let same_error e1 e2 = 55 | let to_sexp e = Exn.sexp_of_t (Monitor.extract_exn (Error.to_exn e)) in 56 | Sexp.equal (to_sexp e1) (to_sexp e2) 57 | 58 | let try_connecting_until_successful t = 59 | (* We take care not to spam logs with the same message over and over by comparing 60 | each log message the the previous one of the same type. *) 61 | let previous_address = ref None in 62 | let previous_error = ref None in 63 | let connect () = 64 | t.get_address () 65 | >>= function 66 | | Error e -> return (Error e) 67 | | Ok addr -> 68 | let same_as_previous_address = 69 | match !previous_address with 70 | | None -> false 71 | | Some previous_address -> Conn.Address.equal addr previous_address 72 | in 73 | previous_address := Some addr; 74 | (if same_as_previous_address 75 | then Deferred.unit 76 | else (handle_event t (Obtained_address addr))) 77 | >>= fun () -> 78 | t.connect addr 79 | in 80 | let rec loop () = 81 | if Ivar.is_full t.close_started 82 | then begin 83 | return `Close_started 84 | end 85 | else begin 86 | connect () 87 | >>= function 88 | | Ok conn -> return (`Ok conn) 89 | | Error err -> 90 | let same_as_previous_error = 91 | match !previous_error with 92 | | None -> false 93 | | Some previous_err -> same_error err previous_err 94 | in 95 | previous_error := Some err; 96 | (if same_as_previous_error 97 | then Deferred.unit 98 | else (handle_event t (Failed_to_connect err))) 99 | >>= fun () -> 100 | Deferred.any [t.retry_delay (); Ivar.read t.close_started] 101 | >>= fun () -> 102 | loop () 103 | end 104 | in 105 | loop () 106 | 107 | let create ~server_name ?(on_event = fun _ -> Deferred.unit) 108 | ?(retry_delay = const (Time_ns.Span.of_sec 10.)) ~connect get_address 109 | = 110 | let event_handler = { Event.Handler. server_name; on_event } in 111 | let retry_delay () = 112 | let span = Time_ns.Span.to_sec (retry_delay ()) in 113 | let distance = Random.float (span *. 0.3) in 114 | let wait = 115 | if Random.bool () 116 | then begin 117 | span +. distance 118 | end 119 | else begin 120 | span -. distance 121 | end 122 | in 123 | Clock_ns.after (Time_ns.Span.of_sec wait) 124 | in 125 | let t = 126 | { event_handler 127 | ; get_address 128 | ; connect 129 | ; retry_delay 130 | ; conn = Ivar.create () 131 | ; close_started = Ivar.create () 132 | ; close_finished = Ivar.create () 133 | } 134 | in 135 | (* this loop finishes once [close t] has been called, in which case it makes sure to 136 | leave [t.conn] filled with [`Close_started]. *) 137 | don't_wait_for @@ Deferred.repeat_until_finished () (fun () -> 138 | handle_event t Attempting_to_connect 139 | >>= fun () -> 140 | let ready_to_retry_connecting = t.retry_delay () in 141 | try_connecting_until_successful t 142 | >>= fun maybe_conn -> 143 | Ivar.fill t.conn maybe_conn; 144 | match maybe_conn with 145 | | `Close_started -> return (`Finished ()) 146 | | `Ok conn -> 147 | handle_event t (Connected conn) 148 | >>= fun () -> 149 | Conn.close_finished conn 150 | >>= fun () -> 151 | t.conn <- Ivar.create (); 152 | handle_event t Disconnected 153 | >>= fun () -> 154 | (* waits until [retry_delay ()] time has passed since the time just before we last 155 | tried to connect rather than the time we noticed being disconnected, so that if 156 | a long-lived connection dies, we will attempt to reconnect immediately. *) 157 | Deferred.choose [ 158 | Deferred.choice ready_to_retry_connecting (fun () -> `Repeat ()); 159 | Deferred.choice (Ivar.read t.close_started) (fun () -> 160 | Ivar.fill t.conn `Close_started; 161 | `Finished ()); 162 | ] 163 | ); 164 | t 165 | 166 | let connected t = 167 | (* Take care not to return a connection that is known to be closed at the time 168 | [connected] was called. This could happen in client code that behaves like 169 | {[ 170 | Persistent_connection.Rpc.connected t 171 | >>= fun c1 -> 172 | ... 173 | Rpc.Connection.close_finished c1 174 | (* at this point we are in a race with the same call inside 175 | persistent_client.ml *) 176 | >>= fun () -> 177 | Persistent_connection.Rpc.connected t 178 | (* depending on how the race turns out, we don't want to get a closed connection 179 | here *) 180 | >>= fun c2 -> 181 | ... 182 | ]} 183 | This doesn't remove the race condition, but it makes it less likely to happen. 184 | *) 185 | let rec loop () = 186 | let d = Ivar.read t.conn in 187 | match Deferred.peek d with 188 | | None -> 189 | begin 190 | d >>= function 191 | | `Close_started -> 192 | Deferred.never () 193 | | `Ok conn -> 194 | return conn 195 | end 196 | | Some `Close_started -> 197 | Deferred.never () 198 | | Some (`Ok conn) -> 199 | if Conn.is_closed conn 200 | then begin 201 | (* give the reconnection loop a chance to overwrite the ivar *) 202 | Conn.close_finished conn >>= loop 203 | end 204 | else begin 205 | return conn 206 | end 207 | in 208 | loop () 209 | 210 | let current_connection t = 211 | match Deferred.peek (Ivar.read t.conn) with 212 | | None | Some `Close_started -> None 213 | | Some (`Ok conn) -> Some conn 214 | 215 | let close_finished t = Ivar.read t.close_finished 216 | let is_closed t = Ivar.is_full t.close_started 217 | 218 | let close t = 219 | if Ivar.is_full t.close_started 220 | then begin 221 | (* Another call to close is already in progress. Wait for it to finish. *) 222 | close_finished t 223 | end 224 | else begin 225 | Ivar.fill t.close_started (); 226 | Ivar.read t.conn 227 | >>= fun conn_opt -> 228 | begin 229 | match conn_opt with 230 | | `Close_started -> Deferred.unit 231 | | `Ok conn -> Conn.close conn 232 | end 233 | >>| fun () -> 234 | Ivar.fill t.close_finished () 235 | end 236 | end 237 | -------------------------------------------------------------------------------- /src/async_stream.mli: -------------------------------------------------------------------------------- 1 | (** An immutable sequence of values, with a possibly incomplete tail that may be extended 2 | asynchronously. 3 | 4 | For most applications one should use {!Pipe} instead of Stream. One justifiable usage 5 | of [Stream] rather than [Pipe] is in single-writer, multi-consumer (multicast) 6 | scenarios where pushback is not required. 7 | 8 | The basic primitive operation for getting the next element out of stream is 9 | [Stream.next], which (asynchronously) returns the element and the rest of the 10 | stream. *) 11 | 12 | open! Core_kernel 13 | open! Import 14 | 15 | module Deferred = Deferred1 16 | 17 | type 'a t = 'a Tail.Stream.t [@@deriving sexp_of] 18 | (** [sexp_of_t t f] returns a sexp of all of the elements currently available in the 19 | stream. It is just for display purposes. There is no [t_of_sexp]. *) 20 | 21 | (** [create f] returns a stream [t] and calls [f tail], where the elements of the stream 22 | are determined as the tail is extended, and the end of the stream is reached when the 23 | tail is closed. *) 24 | val create : ('a Tail.t -> unit) -> 'a t 25 | 26 | (** [next t] returns a deferred that will become determined when the next part of the 27 | stream is determined. This is [Cons (v, t')], where v is the next element of the 28 | stream and t' is the rest of the stream, or with Nil at the end of the stream. *) 29 | type 'a next = Nil | Cons of 'a * 'a t 30 | 31 | val next : 'a t -> 'a next Deferred.t 32 | 33 | (** [first_exn t] returns a deferred that becomes determined with the first element of 34 | [t]. *) 35 | val first_exn : 'a t -> 'a Deferred.t 36 | 37 | (** Streams can be converted to and from lists. Although, conversion to a list returns a 38 | deferred, because the stream is determined asynchronously. *) 39 | 40 | (** [of_list l] returns a stream with the elements of list l. *) 41 | val of_list : 'a list -> 'a t 42 | 43 | (** [to_list t] returns a deferred that will become determined with the list 44 | of elements in t, if the end of t is reached. *) 45 | val to_list : 'a t -> 'a list Deferred.t 46 | 47 | (** [of_fun f] returns a stream whose elements are determined by calling [f] forever. *) 48 | val of_fun : (unit -> 'a Deferred.t) -> 'a t 49 | 50 | (** [copy_to_tail t tail] reads elements from [t] and puts them in [tail], until 51 | the end of [t] is reached. *) 52 | val copy_to_tail : 'a t -> 'a Tail.t -> unit Deferred.t 53 | 54 | (** Sequence operations 55 | ---------------------------------------------------------------------- 56 | There are the usual sequence operations: 57 | 58 | {v 59 | append, fold, iter, map, filter_map, take 60 | v} 61 | 62 | There are also deferred variants: 63 | 64 | {v 65 | iter', map', filter_map' 66 | v} 67 | 68 | These take anonymous functions that return deferreds generalizing the usual sequence 69 | operation and allowing the client to control the rate at which the sequence is 70 | processed. *) 71 | 72 | (** [append t1 t2] returns a stream with all the values of t1, in order, and if t1 ends, 73 | these values are followed by all the values of t2. *) 74 | val append : 'a t -> 'a t -> 'a t 75 | 76 | (** [concat t] takes a stream of streams and produces a stream that is the concatenation 77 | of each stream in order (you see all of stream 1, then all of stream 2... etc.) *) 78 | val concat : 'a t t -> 'a t 79 | 80 | (** [available_now t] returns t prefix of t that is available now, along with the rest of 81 | the stream. *) 82 | val available_now : 'a t -> 'a list * 'a t 83 | 84 | (** [filter_deprecated s ~f] returns a stream with one element, v, for each v in s such 85 | with f v = true. 86 | 87 | Using [filter_deprecated] can easily lead to space leaks. It is better to use 88 | [Async.Pipe] than [Async.Stream]. *) 89 | val filter_deprecated : 'a t -> f:('a -> bool) -> 'a t 90 | 91 | (** [filter_map_deprecated s ~f] returns a stream with one element, v', for each v in s 92 | such with f v = Some v'. 93 | 94 | Using [filter_map_deprecated] can easily lead to space leaks. It is better to use 95 | [Async.Pipe] than [Async.Stream]. *) 96 | val filter_map_deprecated : 'a t -> f:('a -> 'b option) -> 'b t 97 | 98 | (** [fold' t ~init ~f] is like list fold, walking over the elements of the stream in 99 | order, as they become available. [fold'] returns a deferred that will yield the final 100 | value of the accumulator, if the end of the stream is reached. *) 101 | val fold' : 'a t -> init:'b -> f:('b -> 'a -> 'b Deferred.t) -> 'b Deferred.t 102 | 103 | (** [fold t ~init ~f] is a variant of [fold'] in which [f] does not return a deferred. *) 104 | val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b Deferred.t 105 | 106 | (** [iter' t ~f] applies [f] to each element of the stream in turn, as they become 107 | available. It continues onto the next element only after the deferred returned by [f] 108 | becomes determined. *) 109 | val iter' : 'a t -> f:('a -> unit Deferred.t) -> unit Deferred.t 110 | 111 | (** [closed t] returns a deferred that becomes determined when the end of [t] is 112 | reached. *) 113 | val closed : _ t -> unit Deferred.t 114 | 115 | (** [iter t ~f] = [don't_wait_for (iter' t ~f:(fun a -> f a; return ()))] *) 116 | val iter : 'a t -> f:('a -> unit) -> unit 117 | 118 | (** [take_until t d] returns a stream [t'] that has the same elements as [t] up until [d] 119 | becomes determined. *) 120 | val take_until : 'a t -> unit Deferred.t -> 'a t 121 | 122 | (** [iter_durably' t ~f] is like [iter' t ~f], except if [f] raises an exception it 123 | continues with the next element of the stream *and* reraises the exception (to the 124 | monitor in scope when iter_durably was called). 125 | 126 | [iter_durably t ~f] is like [iter t ~f], except if [f] raises an exception it 127 | continues with the next element of the stream *and* reraises the exception (to the 128 | monitor in scope when iter_durably was called). 129 | 130 | [iter_durably_report_end t ~f] is equivalent to [iter_durably' t ~f:(fun x -> return 131 | (f x))] but it is more efficient *) 132 | val iter_durably' : 'a t -> f:('a -> unit Deferred.t) -> unit Deferred.t 133 | val iter_durably : 'a t -> f:('a -> unit ) -> unit 134 | val iter_durably_report_end : 'a t -> f:('a -> unit ) -> unit Deferred.t 135 | 136 | (** [length s] returns a deferred that is determined when the end of s is reached, taking 137 | the value of the number of elements in s *) 138 | val length : 'a t -> int Deferred.t 139 | 140 | (** [map' t f] creates a new stream that with one element, (f v), for each element v of 141 | t. *) 142 | val map' : 'a t -> f:('a -> 'b Deferred.t) -> 'b t 143 | 144 | (** [map t ~f] creates a new stream that with one element, (f v), for each element v of t. 145 | [map t f] = [map' t ~f:(fun a -> return (f a))]. *) 146 | val map : 'a t -> f:('a -> 'b) -> 'b t 147 | 148 | (** [first_n t n] returns a stream with the first n elements of t, if t has n or more 149 | elements, or it returns t. *) 150 | val first_n : 'a t -> int -> 'a t 151 | 152 | 153 | (** Stream generation 154 | ---------------------------------------------------------------------- *) 155 | 156 | 157 | (** [unfold b f] returns a stream [a1; a2; ...; an] whose elements are 158 | determined by the equations: 159 | {v 160 | b0 = b 161 | Some (a1, b1) = f b0 162 | Some (a2, b2) = f b1 163 | ... 164 | None = f bn 165 | v} *) 166 | val unfold : 'b -> f:('b -> ('a * 'b) option Deferred.t) -> 'a t 167 | 168 | 169 | (** Miscellaneous operations 170 | ---------------------------------------------------------------------- *) 171 | 172 | (** [split ~stop ~f t] returns a pair [(p, d)], where [p] is a prefix of [t] that ends 173 | for one of three reasons: 174 | {v 175 | 1. [t] ends 176 | 2. stop becomes determined 177 | 3. f returns `Found 178 | v} 179 | The deferred [d] describes why the prefix ended, and returns the suffix of the 180 | stream in case (2) or (3). *) 181 | val split 182 | : ?stop:unit Deferred.t 183 | -> ?f:('a -> [ `Continue | `Found of 'b ]) 184 | -> 'a t 185 | -> 'a t * [ `End_of_stream 186 | | `Stopped of 'a t 187 | | `Found of 'b * 'a t 188 | ] Deferred.t 189 | 190 | (** [find ~f t] returns a deferred that becomes determined when [f x] is true for some 191 | element of [t], or if the end of the stream is reached *) 192 | val find 193 | : 'a t 194 | -> f:('a -> bool) 195 | -> [ `End_of_stream 196 | | `Found of 'a * 'a t 197 | ] Deferred.t 198 | 199 | (** [ungroup t] takes a stream of lists and unpacks the items from each list into a single 200 | stream *) 201 | val ungroup : 'a list t -> 'a t 202 | 203 | (** [interleave list] takes a stream of streams and returns a stream of their items 204 | interleaved as they become determined. The interleaved stream will be closed when the 205 | outer stream and all of the inner streams have been closed. *) 206 | val interleave : 'a t t -> 'a t 207 | --------------------------------------------------------------------------------