Future: each computation has a uuid

1 files changed, 32 insertions, 15 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