M .builds/alpine.yml +1 -0
@@ 1,5 1,6 @@
image: alpine/edge
packages:
+ - m4
- make
- mercurial
- opam
M code/pds.conf +8 -1
@@ 22,5 22,12 @@ extra_compiler_opts = "-safe-string"
[src.byocm_fut]
install = false
+[src.byocm_sched]
+install = false
+deps = [ "byocm_fut" ]
+
[tests.byocm_fut]
-deps = [ "byocm_fut" ]
No newline at end of file
+deps = [ "byocm_fut" ]
+
+[tests.byocm_sched]
+deps = [ "byocm_fut", "byocm_sched" ]
M code/src/byocm_fut/byocm_fut.ml +28 -7
@@ 10,6 10,10 @@ and 'a undet = { mutable watchers : ('a
external t_of_u : 'a u -> 'a t = "%identity"
external u_of_t : 'a t -> 'a u = "%identity"
+let rec collapse_alias = function
+ | { state = `Alias u } -> collapse_alias u
+ | u -> u
+
module Promise = struct
type 'a fut = 'a t
type 'a t = 'a fut
@@ 26,18 30,35 @@ module Promise = struct
assert false
end
-let rec collapse_alias = function
- | { state = `Alias u } -> collapse_alias u
- | u -> u
-
let return v = t_of_u { state = `Det v }
-let bind t f =
+let bind : 'a t -> ('a -> 'b t) -> 'b t = fun t f ->
let u = collapse_alias (u_of_t t) in
match u with
| { state = `Det v } ->
f v
- | { state = `Undet { watchers = watchers } } ->
- failwith "nyi"
+ | { state = `Undet undet } ->
+ let p = Promise.create () in
+ let fut = Promise.future p in
+ let w =
+ fun v ->
+ let u = collapse_alias (u_of_t (f v)) in
+ match u with
+ | { state = `Det v' } ->
+ Promise.set p v'
+ | { state = `Undet undet' } ->
+ begin match collapse_alias (u_of_t fut) with
+ | { state = `Undet undet'' } as fut' ->
+ undet'.watchers <- undet'.watchers @ undet''.watchers;
+ fut'.state <- `Alias u
+ | { state = `Det _ }
+ | { state = `Alias _ } ->
+ assert false
+ end
+ | _ ->
+ assert false
+ in
+ undet.watchers <- w::undet.watchers;
+ fut
| { state = `Alias _ } ->
assert false
A => code/src/byocm_sched/byocm_sched.ml +44 -0
@@ 0,0 1,44 @@
+module Float_map = Map.Make(struct type t = float let compare = compare end)
+
+let timers = ref Float_map.empty
+
+let rec exec_timers now =
+ match Float_map.min_binding_opt !timers with
+ | Some (n, p) when n <= now ->
+ timers := Float_map.remove n !timers;
+ Byocm_fut.Promise.set p ();
+ exec_timers now
+ | _ ->
+ ()
+
+let rec loop finished =
+ match Byocm_fut.state finished with
+ | `Det v ->
+ v
+ | `Undet ->
+ next_iter ();
+ loop finished
+and next_iter () =
+ let now = Unix.time () in
+ match Float_map.min_binding_opt !timers with
+ | Some (n, _) when n > now ->
+ ignore (Unix.select [] [] [] (n -. now))
+ | _ ->
+ exec_timers now
+
+let sleep time =
+ let trigger_time = Unix.time () +. time in
+ let p =
+ try
+ Float_map.find trigger_time !timers
+ with
+ | Not_found ->
+ let p = Byocm_fut.Promise.create () in
+ timers := Float_map.add trigger_time p !timers;
+ p
+ in
+ Byocm_fut.Promise.future p
+
+let run f =
+ loop (f ())
+
A => code/src/byocm_sched/byocm_sched.mli +3 -0
@@ 0,0 1,3 @@
+val sleep : float -> unit Byocm_fut.t
+
+val run : (unit -> 'a Byocm_fut.t) -> 'a
M code/tests/byocm_fut/test.ml +20 -1
@@ 25,7 25,26 @@ let test3 () =
Byocm_fut.Promise.set p "hello";
assert (Byocm_fut.state res = `Det "hello world")
+let test4 () =
+ let open Byocm_fut.Infix_monad in
+ let p1 = Byocm_fut.Promise.create () in
+ let p2 = Byocm_fut.Promise.create () in
+ let fut = Byocm_fut.Promise.future p1 in
+ let res =
+ fut
+ >>= fun () ->
+ Byocm_fut.Promise.future p2
+ >>= fun s ->
+ Byocm_fut.return (s ^ " world")
+ in
+ assert (Byocm_fut.state res = `Undet);
+ Byocm_fut.Promise.set p1 ();
+ assert (Byocm_fut.state res = `Undet);
+ Byocm_fut.Promise.set p2 "hello";
+ assert (Byocm_fut.state res = `Det "hello world")
+
let () =
test1 ();
test2 ();
- test3 ()
+ test3 ();
+ test4 ()
A => code/tests/byocm_sched/test.ml +37 -0
@@ 0,0 1,37 @@
+let test1 () =
+ let f () = Byocm_sched.sleep 1.0 in
+ let v = Byocm_sched.run f in
+ assert (v = ())
+
+let test2 () =
+ let f () =
+ let open Byocm_fut.Infix_monad in
+ let t1 = Unix.time () in
+ Byocm_sched.sleep 1.0
+ >>= fun () ->
+ let t2 = Unix.time () in
+ Byocm_fut.return (t2 -. t1)
+ in
+ let v = Byocm_sched.run f in
+ assert (v >= 1.0 && v <= 1.5)
+
+let test3 () =
+ let f () =
+ let open Byocm_fut.Infix_monad in
+ let t1 = Unix.time () in
+ let fut1 = Byocm_sched.sleep 1.0 in
+ let fut2 = Byocm_sched.sleep 1.5 in
+ fut1
+ >>= fun () ->
+ fut2
+ >>= fun () ->
+ let t2 = Unix.time () in
+ Byocm_fut.return (t2 -. t1)
+ in
+ let v = Byocm_sched.run f in
+ assert (v >= 1.5 && v <= 2.0)
+
+let () =
+ test1 ();
+ test2 ();
+ test3 ()