diff options
author | Enrico Tassi <Enrico.Tassi@inria.fr> | 2014-02-19 10:45:49 +0100 |
---|---|---|
committer | Enrico Tassi <Enrico.Tassi@inria.fr> | 2014-02-26 14:53:08 +0100 |
commit | 7726a81d850020b6402f445912f3a3d9310da69d (patch) | |
tree | 93f8219fd02efc9eeee6ea704c551de593d620eb /lib | |
parent | e4c81a456ed7279e255e0df2a73e14c77946be7e (diff) |
Future: each computation has a uuid
Diffstat (limited to 'lib')
-rw-r--r-- | lib/future.ml | 47 | ||||
-rw-r--r-- | lib/future.mli | 14 |
2 files changed, 45 insertions, 16 deletions
diff --git a/lib/future.ml b/lib/future.ml index c54b4e8db..8f2ae1df5 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -29,6 +29,19 @@ let _ = Errors.register_handler (function type fix_exn = exn -> exn let id x = prerr_endline "no fix_exn"; x +module UUID = struct + type t = int + let invalid = 0 + let fresh = + let count = ref invalid in + fun () -> incr count; !count + + let compare = compare + let equal = (==) +end + +open UUID + type 'a assignement = [ `Val of 'a | `Exn of exn | `Comp of 'a computation] (* Val is not necessarily a final state, so the @@ -42,55 +55,58 @@ and 'a comp = | Exn of exn (* Invariant: this exception is always "fixed" as in fix_exn *) and 'a comput = - | Ongoing of (fix_exn * 'a comp ref) Ephemeron.key + | Ongoing of (UUID.t * fix_exn * 'a comp ref) Ephemeron.key | Finished of 'a and 'a computation = 'a comput ref -let create f x = ref (Ongoing (Ephemeron.create (f, Pervasives.ref x))) +let create ?(uuid=UUID.fresh ()) f x = + ref (Ongoing (Ephemeron.create (uuid, f, Pervasives.ref x))) let get x = match !x with - | Finished v -> id, ref( Val (v,None)) + | Finished v -> UUID.invalid, id, ref (Val (v,None)) | Ongoing x -> try Ephemeron.get x - with Ephemeron.InvalidKey -> (fun x -> x), ref (Exn NotHere) + with Ephemeron.InvalidKey -> UUID.invalid, id, ref (Exn NotHere) type 'a value = [ `Val of 'a | `Exn of exn ] -let is_over kx = let _, x = get kx in match !x with +let is_over kx = let _, _, x = get kx in match !x with | Val _ | Exn _ -> true | Closure _ | Delegated _ -> false -let is_val kx = let _, x = get kx in match !x with +let is_val kx = let _, _, x = get kx in match !x with | Val _ -> true | Exn _ | Closure _ | Delegated _ -> false -let is_exn kx = let _, x = get kx in match !x with +let is_exn kx = let _, _, x = get kx in match !x with | Exn _ -> true | Val _ | Closure _ | Delegated _ -> false -let peek_val kx = let _, x = get kx in match !x with +let peek_val kx = let _, _, x = get kx in match !x with | Val (v, _) -> Some v | Exn _ | Closure _ | Delegated _ -> None +let uuid kx = let id, _, _ = get kx in id + let from_val ?(fix_exn=id) v = create fix_exn (Val (v, None)) let from_here ?(fix_exn=id) v = create fix_exn (Val (v, Some (!freeze ()))) let default_force () = raise NotReady let assignement ck = fun v -> - let fix_exn, c = get ck in + let _, fix_exn, c = get ck in assert (match !c with Delegated _ -> true | _ -> false); match v with | `Val v -> c := Val (v, None) | `Exn e -> c := Exn (fix_exn e) - | `Comp f -> let _, comp = get f in c := !comp + | `Comp f -> let _, _, comp = get f in c := !comp let create_delegate ?(force=default_force) fix_exn = let ck = create fix_exn (Delegated force) in ck, assignement ck (* TODO: get rid of try/catch to be stackless *) let rec compute ~pure ck : 'a value = - let fix_exn, c = get ck in + let _, fix_exn, c = get ck in match !c with | Val (x, _) -> `Val x | Exn e -> `Exn e @@ -112,8 +128,8 @@ let force ~pure x = match compute ~pure x with | `Exn e -> raise e let chain ~pure ck f = - let fix_exn, c = get ck in - create fix_exn (match !c with + let uuid, fix_exn, c = get ck in + create ~uuid fix_exn (match !c with | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck)) | Exn _ as x -> x | Val (v, None) when pure -> Closure (fun () -> f v) @@ -132,10 +148,11 @@ let chain ~pure ck f = let create fix_exn f = create fix_exn (Closure f) let replace kx y = - let _, x = get kx in + let _, _, x = get kx in match !x with | Exn _ -> x := Closure (fun () -> force ~pure:false y) - | _ -> Errors.anomaly (Pp.str "Only Exn futures can be replaced") + | _ -> Errors.anomaly + (Pp.str "A computation can be replaced only if is_exn holds") let purify f x = let state = !freeze () in diff --git a/lib/future.mli b/lib/future.mli index 4dca2f144..13f8ee961 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -50,6 +50,16 @@ * they will become invalid and accessing them raises a private exception. *) +(* Each computation has a unique id that is inherited by each offspring + * computation (chain, split, map...). Joined computations lose it. *) +module UUID : sig + type t + val invalid : t + + val compare : t -> t -> int + val equal : t -> t -> bool +end + exception NotReady type 'a computation @@ -75,7 +85,8 @@ val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation (* Run remotely, returns the function to assign. Optionally tekes a function - that is called when forced. The default one is to raise NotReady *) + that is called when forced. The default one is to raise NotReady. + The assignement function does not change the uuid. *) type 'a assignement = [ `Val of 'a | `Exn of exn | `Comp of 'a computation] val create_delegate : ?force:(unit -> 'a assignement) -> @@ -89,6 +100,7 @@ val is_over : 'a computation -> bool val is_val : 'a computation -> bool val is_exn : 'a computation -> bool val peek_val : 'a computation -> 'a option +val uuid : 'a computation -> UUID.t (* [chain greedy pure c f] chains computation [c] with [f]. * The [greedy] and [pure] parameters are tricky: |