mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 03:05:28 -05:00
started refactoring Future
This commit is contained in:
Simon Cruanes
parent
11259c9297
commit
1972f0f55d
3 changed files with 530 additions and 598 deletions
151
future.mli
151
future.mli
|
|
@ -25,9 +25,6 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|||
|
||||
(** {1 Futures for concurrency} *)
|
||||
|
||||
type 'a t
|
||||
(** A future value of type 'a *)
|
||||
|
||||
exception SendTwice
|
||||
(** Exception raised when a future is evaluated several time *)
|
||||
|
||||
|
|
@ -59,113 +56,103 @@ module MVar : sig
|
|||
(** Look at the value, without removing it *)
|
||||
end
|
||||
|
||||
(** {2 Thread pool} *)
|
||||
module Pool : sig
|
||||
type t
|
||||
(** A pool of threads *)
|
||||
(** {2 Signature} *)
|
||||
|
||||
val create : ?timeout:float -> size:int -> t
|
||||
(** Create a pool with at most the given number of threads. [timeout]
|
||||
is the time after which idle threads are killed. *)
|
||||
module type S = sig
|
||||
type 'a t
|
||||
(** A future value of type 'a *)
|
||||
|
||||
val size : t -> int
|
||||
(** Current size of the pool *)
|
||||
|
||||
val run : t -> (unit -> unit) -> unit
|
||||
val run : (unit -> unit) -> unit
|
||||
(** Run the function in the pool *)
|
||||
|
||||
val finish : t -> unit
|
||||
(** Kill threads in the pool *)
|
||||
end
|
||||
val finish : unit -> unit
|
||||
(** Kill threads in the pool. The pool won't be usable any more. *)
|
||||
|
||||
val default_pool : Pool.t
|
||||
(** Pool of threads that is used by default. Growable if needed. *)
|
||||
(** {2 Basic low-level Future functions} *)
|
||||
|
||||
(** {2 Basic low-level Future functions} *)
|
||||
type 'a state =
|
||||
| NotKnown
|
||||
| Success of 'a
|
||||
| Failure of exn
|
||||
|
||||
val make : Pool.t -> 'a t
|
||||
(** Create a future, representing a value that is not known yet. *)
|
||||
val state : 'a t -> 'a state
|
||||
(** Current state of the future *)
|
||||
|
||||
val get : 'a t -> 'a
|
||||
(** Blocking get: wait for the future to be evaluated, and get the value,
|
||||
or the exception that failed the future is returned *)
|
||||
val is_done : 'a t -> bool
|
||||
(** Is the future evaluated (success/failure)? *)
|
||||
|
||||
val send : 'a t -> 'a -> unit
|
||||
(** Send a result to the future. Will raise SendTwice if [send] has
|
||||
already been called on this future before *)
|
||||
(** {2 Combinators} *)
|
||||
|
||||
val fail : 'a t -> exn -> unit
|
||||
(** Fail the future by raising an exception inside it *)
|
||||
val on_success : 'a t -> ('a -> unit) -> unit
|
||||
(** Attach a handler to be called upon success *)
|
||||
|
||||
val is_done : 'a t -> bool
|
||||
(** Is the future evaluated (success/failure)? *)
|
||||
val on_failure : _ t -> (exn -> unit) -> unit
|
||||
(** Attach a handler to be called upon failure *)
|
||||
|
||||
(** {2 Combinators} *)
|
||||
val on_finish : _ t -> (unit -> unit) -> unit
|
||||
(** Attach a handler to be called when the future is evaluated *)
|
||||
|
||||
val on_success : 'a t -> ('a -> unit) -> unit
|
||||
(** Attach a handler to be called upon success *)
|
||||
val flatMap : ('a -> 'b t) -> 'a t -> 'b t
|
||||
(** Monadic combination of futures *)
|
||||
|
||||
val on_failure : _ t -> (exn -> unit) -> unit
|
||||
(** Attach a handler to be called upon failure *)
|
||||
val andThen : 'a t -> (unit -> 'b t) -> 'b t
|
||||
(** Wait for the first future to succeed, then launch the second *)
|
||||
|
||||
val on_finish : _ t -> (unit -> unit) -> unit
|
||||
(** Attach a handler to be called when the future is evaluated *)
|
||||
val sequence : 'a t list -> 'a list t
|
||||
(** Future that waits for all previous sequences to terminate *)
|
||||
|
||||
val flatMap : ?pool:Pool.t -> ('a -> 'b t) -> 'a t -> 'b t
|
||||
(** Monadic combination of futures *)
|
||||
val choose : 'a t list -> 'a t
|
||||
(** Choose among those futures (the first to terminate) *)
|
||||
|
||||
val andThen : ?pool:Pool.t -> 'a t -> (unit -> 'b t) -> 'b t
|
||||
(** Wait for the first future to succeed, then launch the second *)
|
||||
val map : ('a -> 'b) -> 'a t -> 'b t
|
||||
(** Maps the value inside the future *)
|
||||
|
||||
val sequence : ?pool:Pool.t -> 'a t list -> 'a list t
|
||||
(** Future that waits for all previous sequences to terminate *)
|
||||
(** {2 Future constructors} *)
|
||||
|
||||
val choose : ?pool:Pool.t -> 'a t list -> 'a t
|
||||
(** Choose among those futures (the first to terminate) *)
|
||||
val return : 'a -> 'a t
|
||||
(** Future that is already computed *)
|
||||
|
||||
val map : ?pool:Pool.t -> ('a -> 'b) -> 'a t -> 'b t
|
||||
(** Maps the value inside the future *)
|
||||
val spawn : (unit -> 'a) -> 'a t
|
||||
(** Spawn a thread that wraps the given computation *)
|
||||
|
||||
(** {2 Future constructors} *)
|
||||
val spawn_process : ?stdin:string -> cmd:string ->
|
||||
(int * string * string) t
|
||||
(** Spawn a sub-process with the given command [cmd] (and possibly input);
|
||||
returns a future containing (returncode, stdout, stderr) *)
|
||||
|
||||
val return : 'a -> 'a t
|
||||
(** Future that is already computed *)
|
||||
val sleep : float -> unit t
|
||||
(** Future that returns with success in the given amount of seconds *)
|
||||
|
||||
val spawn : ?pool:Pool.t -> (unit -> 'a) -> 'a t
|
||||
(** Spawn a thread that wraps the given computation *)
|
||||
(** {2 Event timer} *)
|
||||
|
||||
val spawn_process : ?pool:Pool.t -> ?stdin:string -> cmd:string ->
|
||||
(int * string * string) t
|
||||
(** Spawn a sub-process with the given command [cmd] (and possibly input);
|
||||
returns a future containing (returncode, stdout, stderr) *)
|
||||
module Timer : sig
|
||||
val schedule_at : at:float -> (unit -> unit) -> unit
|
||||
(** [schedule_at ~at act] will run [act] at the Unix echo [at] *)
|
||||
|
||||
val sleep : ?pool:Pool.t -> float -> unit t
|
||||
(** Future that returns with success in the given amount of seconds *)
|
||||
val schedule_after : after:float -> (unit -> unit) -> unit
|
||||
(** [schedule_after ~after act] will run [act] in [after] seconds *)
|
||||
end
|
||||
|
||||
(** {2 Event timer} *)
|
||||
module Infix : sig
|
||||
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val (>>) : 'a t -> (unit -> 'b t) -> 'b t
|
||||
end
|
||||
|
||||
module Timer : sig
|
||||
type t
|
||||
(** A scheduler for events *)
|
||||
|
||||
val create : ?pool:Pool.t -> unit -> t
|
||||
(** A timer that runs tasks in the given thread pool *)
|
||||
|
||||
val schedule_at : t -> float -> (unit -> unit) -> unit
|
||||
(** [schedule_at s t act] will run [act] at the Unix echo [t] *)
|
||||
|
||||
val schedule_in : t -> float -> (unit -> unit) -> unit
|
||||
(** [schedule_in s d act] will run [act] in [d] seconds *)
|
||||
|
||||
val stop : t -> unit
|
||||
(** Stop the given timer, cancelling pending tasks *)
|
||||
end
|
||||
|
||||
|
||||
module Infix : sig
|
||||
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val (>>) : 'a t -> (unit -> 'b t) -> 'b t
|
||||
end
|
||||
|
||||
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val (>>) : 'a t -> (unit -> 'b t) -> 'b t
|
||||
(** {2 Functor} *)
|
||||
|
||||
module type CONFIG = sig
|
||||
val timeout : float
|
||||
|
||||
val max_size : int
|
||||
end
|
||||
|
||||
module DefaultConfig : CONFIG
|
||||
|
||||
module Make(C : CONFIG) : S
|
||||
|
||||
(** Standard (default) pool *)
|
||||
module Std : S
|
||||
|
|
|
|||
|
|
@ -1,45 +1,50 @@
|
|||
|
||||
(** Test Future *)
|
||||
(** Test F *)
|
||||
|
||||
open OUnit
|
||||
|
||||
module F = Future.Std
|
||||
module MVar = Future.MVar
|
||||
|
||||
let test_mvar () =
|
||||
let box = Future.MVar.empty () in
|
||||
let f = Future.spawn (fun () -> Future.MVar.take box + 1) in
|
||||
let box = MVar.empty () in
|
||||
let f = F.spawn (fun () -> MVar.take box + 1) in
|
||||
Thread.delay 0.1;
|
||||
OUnit.assert_bool "still waiting" (not (Future.is_done f));
|
||||
Future.MVar.put box 1;
|
||||
OUnit.assert_equal 2 (Future.get f);
|
||||
OUnit.assert_bool "still waiting" (not (F.is_done f));
|
||||
MVar.put box 1;
|
||||
Thread.delay 1.;
|
||||
OUnit.assert_equal (F.Success 2) (F.state f);
|
||||
()
|
||||
|
||||
let test_parallel () =
|
||||
let open Gen.Infix in
|
||||
let l = 1 -- 300
|
||||
|> Gen.map (fun _ -> Future.spawn (fun () -> Thread.delay 0.1; 1))
|
||||
|> Gen.map (fun _ -> F.spawn (fun () -> Thread.delay 0.1; 1))
|
||||
|> Gen.to_list in
|
||||
let l' = List.map Future.get l in
|
||||
OUnit.assert_equal 300 (List.fold_left (+) 0 l');
|
||||
let l' = F.map (List.fold_left (+) 0) (F.sequence l) in
|
||||
Thread.delay 0.5;
|
||||
OUnit.assert_equal (F.Success 300) (F.state l');
|
||||
()
|
||||
|
||||
let test_time () =
|
||||
let start = Unix.gettimeofday () in
|
||||
let f1 = Future.spawn (fun () -> Thread.delay 0.5) in
|
||||
let f2 = Future.spawn (fun () -> Thread.delay 0.5) in
|
||||
Future.get f1;
|
||||
Future.get f2;
|
||||
let f1 = F.spawn (fun () -> Thread.delay 0.5) in
|
||||
let f2 = F.spawn (fun () -> Thread.delay 0.5) in
|
||||
F.get f1;
|
||||
F.get f2;
|
||||
let stop = Unix.gettimeofday () in
|
||||
OUnit.assert_bool "parallelism" (stop -. start < 0.75);
|
||||
()
|
||||
|
||||
let test_timer () =
|
||||
let timer = Future.Timer.create () in
|
||||
let mvar = Future.MVar.full 1 in
|
||||
Future.Timer.schedule_in timer 0.5
|
||||
(fun () -> ignore (Future.MVar.update mvar (fun x -> x + 2)));
|
||||
Future.Timer.schedule_in timer 0.2
|
||||
(fun () -> ignore (Future.MVar.update mvar (fun x -> x * 4)));
|
||||
let timer = F.Timer.create () in
|
||||
let mvar = MVar.full 1 in
|
||||
F.Timer.schedule_in timer 0.5
|
||||
(fun () -> ignore (MVar.update mvar (fun x -> x + 2)));
|
||||
F.Timer.schedule_in timer 0.2
|
||||
(fun () -> ignore (MVar.update mvar (fun x -> x * 4)));
|
||||
Thread.delay 0.7;
|
||||
OUnit.assert_equal 6 (Future.MVar.peek mvar);
|
||||
OUnit.assert_equal 6 (MVar.peek mvar);
|
||||
()
|
||||
|
||||
let suite =
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue