2020-03-09 05:48:52 +01:00
|
|
|
(** Create-only version of [Obj.t] *)
|
|
|
|
module Any : sig
|
|
|
|
type t
|
|
|
|
val any : 'a -> t
|
|
|
|
end = struct
|
|
|
|
type t = Obj.t
|
|
|
|
let any = Obj.repr
|
|
|
|
end
|
|
|
|
|
2019-12-12 11:36:58 +01:00
|
|
|
type 'a t =
|
|
|
|
| Pure of 'a
|
2020-03-09 05:48:52 +01:00
|
|
|
| Impure of 'a (* NOTE: is this really used anywhere? *)
|
2020-01-08 11:24:53 +01:00
|
|
|
| Operator : {
|
2020-03-09 05:48:52 +01:00
|
|
|
mutable value : 'a option; (* cached value *)
|
|
|
|
mutable trace : trace; (* list of parents this can invalidate *)
|
|
|
|
mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *)
|
2019-12-12 11:36:58 +01:00
|
|
|
desc: 'a desc;
|
|
|
|
} -> 'a t
|
|
|
|
| Root : {
|
2020-03-09 05:48:52 +01:00
|
|
|
mutable value : 'a option; (* cached value *)
|
|
|
|
mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *)
|
2019-12-12 11:36:58 +01:00
|
|
|
mutable on_invalidate : 'a -> unit;
|
2019-12-24 23:15:13 +01:00
|
|
|
mutable acquired : bool;
|
|
|
|
child : 'a t;
|
2019-12-12 11:36:58 +01:00
|
|
|
} -> 'a t
|
|
|
|
|
|
|
|
and _ desc =
|
|
|
|
| Map : 'a t * ('a -> 'b) -> 'b desc
|
|
|
|
| Map2 : 'a t * 'b t * ('a -> 'b -> 'c) -> 'c desc
|
|
|
|
| Pair : 'a t * 'b t -> ('a * 'b) desc
|
|
|
|
| App : ('a -> 'b) t * 'a t -> 'b desc
|
2019-12-14 08:51:39 +01:00
|
|
|
| Join : { child : 'a t t; mutable intermediate : 'a t option } -> 'a desc
|
2019-12-12 11:36:58 +01:00
|
|
|
| Var : { mutable binding : 'a } -> 'a desc
|
|
|
|
| Prim : { acquire : unit -> 'a;
|
|
|
|
release : 'a -> unit } -> 'a desc
|
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* a set of (active) parents for a ['a t], used during invalidation *)
|
2019-12-12 11:36:58 +01:00
|
|
|
and trace =
|
|
|
|
| T0
|
|
|
|
| T1 : _ t -> trace
|
|
|
|
| T2 : _ t * _ t -> trace
|
|
|
|
| T3 : _ t * _ t * _ t -> trace
|
|
|
|
| T4 : _ t * _ t * _ t * _ t -> trace
|
|
|
|
| Tn : { mutable active : int; mutable count : int;
|
2020-03-09 05:48:52 +01:00
|
|
|
mutable entries : Any.t t array } -> trace
|
2019-12-12 11:36:58 +01:00
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* a set of direct children for a composite document *)
|
2019-12-12 11:36:58 +01:00
|
|
|
and trace_idx =
|
|
|
|
| I0
|
|
|
|
| I1 : { mutable idx : int ;
|
|
|
|
obj : 'a t;
|
|
|
|
mutable next : trace_idx } -> trace_idx
|
|
|
|
|
|
|
|
(* Basic combinators *)
|
|
|
|
let return x = Pure x
|
|
|
|
let pure x = Pure x
|
|
|
|
|
2020-01-08 11:24:53 +01:00
|
|
|
let impure = function
|
|
|
|
| Pure x -> Impure x
|
|
|
|
| other -> other
|
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
let dummy = Pure (Any.any ())
|
2019-12-12 11:36:58 +01:00
|
|
|
|
2020-01-08 11:24:53 +01:00
|
|
|
let operator desc =
|
|
|
|
Operator { value = None; trace = T0; desc; trace_idx = I0 }
|
|
|
|
|
|
|
|
let map f x = match x with
|
|
|
|
| Pure vx -> Pure (f vx)
|
|
|
|
| x -> operator (Map (x, f))
|
|
|
|
|
|
|
|
let map2 f x y =
|
|
|
|
match x, y with
|
|
|
|
| Pure vx, Pure vy -> Pure (f vx vy)
|
|
|
|
| _ -> operator (Map2 (x, y, f))
|
|
|
|
|
|
|
|
let map' x f = map f x
|
|
|
|
let map2' x y f = map2 f x y
|
|
|
|
|
|
|
|
let pair x y = match x, y with
|
|
|
|
| Pure vx, Pure vy -> Pure (vx, vy)
|
|
|
|
| _ -> operator (Pair (x, y))
|
|
|
|
|
|
|
|
let app f x = match f, x with
|
|
|
|
| Pure vf, Pure vx -> Pure (vf vx)
|
|
|
|
| _ -> operator (App (f, x))
|
|
|
|
|
|
|
|
let join child = match child with
|
|
|
|
| Pure v -> v
|
|
|
|
| _ -> operator (Join { child; intermediate = None })
|
2019-12-12 11:36:58 +01:00
|
|
|
|
2019-12-14 08:51:39 +01:00
|
|
|
let bind x f = join (map f x)
|
2019-12-12 11:36:58 +01:00
|
|
|
|
|
|
|
(* Management of trace indices *)
|
|
|
|
|
|
|
|
external t_equal : _ t -> _ t -> bool = "%eq"
|
2020-03-09 05:48:52 +01:00
|
|
|
external obj_t : 'a t -> Any.t t = "%identity"
|
2019-12-12 11:36:58 +01:00
|
|
|
|
|
|
|
let add_idx obj idx = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ -> assert false
|
2019-12-12 11:36:58 +01:00
|
|
|
| Root t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
|
2020-01-08 11:24:53 +01:00
|
|
|
| Operator t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
|
2019-12-12 11:36:58 +01:00
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
let rec rem_idx_rec obj = function
|
2019-12-12 11:36:58 +01:00
|
|
|
| I0 -> assert false
|
|
|
|
| I1 t as self ->
|
|
|
|
if t_equal t.obj obj
|
|
|
|
then (t.idx, t.next)
|
2020-03-09 05:48:52 +01:00
|
|
|
else (
|
|
|
|
let idx, result = rem_idx_rec obj t.next in
|
2019-12-12 11:36:58 +01:00
|
|
|
t.next <- result;
|
|
|
|
(idx, self)
|
2020-03-09 05:48:52 +01:00
|
|
|
)
|
2019-12-12 11:36:58 +01:00
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* remove [obj] from the lwd's trace. *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let rem_idx obj = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ -> assert false
|
2019-12-12 11:36:58 +01:00
|
|
|
| Root t' ->
|
2020-03-09 05:48:52 +01:00
|
|
|
let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
|
2019-12-12 11:36:58 +01:00
|
|
|
t'.trace_idx <- trace_idx; idx
|
2020-01-08 11:24:53 +01:00
|
|
|
| Operator t' ->
|
2020-03-09 05:48:52 +01:00
|
|
|
let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
|
2019-12-12 11:36:58 +01:00
|
|
|
t'.trace_idx <- trace_idx; idx
|
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* move [obj] from old index to new index. *)
|
|
|
|
let rec mov_idx_rec obj oldidx newidx = function
|
2019-12-12 11:36:58 +01:00
|
|
|
| I0 -> assert false
|
|
|
|
| I1 t ->
|
|
|
|
if t.idx = oldidx && t_equal t.obj obj
|
|
|
|
then t.idx <- newidx
|
2020-03-09 05:48:52 +01:00
|
|
|
else mov_idx_rec obj oldidx newidx t.next
|
2019-12-12 11:36:58 +01:00
|
|
|
|
|
|
|
let mov_idx obj oldidx newidx = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ -> assert false
|
2020-03-09 05:48:52 +01:00
|
|
|
| Root t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
|
|
|
|
| Operator t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
|
2019-12-12 11:36:58 +01:00
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
let rec get_idx_rec obj = function
|
2019-12-12 11:36:58 +01:00
|
|
|
| I0 -> assert false
|
|
|
|
| I1 t ->
|
|
|
|
if t_equal t.obj obj
|
|
|
|
then t.idx
|
2020-03-09 05:48:52 +01:00
|
|
|
else get_idx_rec obj t.next
|
2019-12-12 11:36:58 +01:00
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* find index of [obj] in the given lwd *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let get_idx obj = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ -> assert false
|
2020-03-09 05:48:52 +01:00
|
|
|
| Root t' -> get_idx_rec obj t'.trace_idx
|
|
|
|
| Operator t' -> get_idx_rec obj t'.trace_idx
|
2019-12-12 11:36:58 +01:00
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* Propagating invalidation recursively.
|
|
|
|
Each document is invalidated at most once,
|
|
|
|
and only if it has [t.value = Some _]. *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let rec invalidate_node : type a . a t -> unit = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ -> assert false
|
2019-12-12 11:36:58 +01:00
|
|
|
| Root { value = None; _ } -> ()
|
|
|
|
| Root ({ value = Some x; _ } as t) ->
|
|
|
|
t.value <- None;
|
2020-03-09 05:48:52 +01:00
|
|
|
t.on_invalidate x (* user callback that {i observes} this root. *)
|
2020-01-08 11:24:53 +01:00
|
|
|
| Operator t ->
|
2019-12-12 11:36:58 +01:00
|
|
|
begin match t.value with
|
|
|
|
| None -> ()
|
|
|
|
| Some _ ->
|
|
|
|
t.value <- None;
|
2020-03-09 05:48:52 +01:00
|
|
|
invalidate_trace t.trace; (* invalidate parents recursively *)
|
2019-12-12 11:36:58 +01:00
|
|
|
end
|
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* invalidate recursively documents in the given trace *)
|
2019-12-12 11:36:58 +01:00
|
|
|
and invalidate_trace = function
|
|
|
|
| T0 -> ()
|
|
|
|
| T1 x -> invalidate_node x
|
|
|
|
| T2 (x, y) ->
|
|
|
|
invalidate_node x;
|
|
|
|
invalidate_node y
|
|
|
|
| T3 (x, y, z) ->
|
|
|
|
invalidate_node x;
|
|
|
|
invalidate_node y;
|
|
|
|
invalidate_node z
|
|
|
|
| T4 (x, y, z, w) ->
|
|
|
|
invalidate_node x;
|
|
|
|
invalidate_node y;
|
|
|
|
invalidate_node z;
|
|
|
|
invalidate_node w
|
|
|
|
| Tn t ->
|
|
|
|
let active = t.active in
|
|
|
|
t.active <- 0;
|
|
|
|
for i = 0 to active - 1 do
|
|
|
|
invalidate_node t.entries.(i)
|
|
|
|
done
|
|
|
|
|
|
|
|
(* Variables *)
|
|
|
|
type 'a var = 'a t
|
2020-01-08 11:24:53 +01:00
|
|
|
let var x = operator (Var {binding = x})
|
2019-12-12 11:36:58 +01:00
|
|
|
let get x = x
|
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
let set (vx:_ var) x : unit =
|
2019-12-12 11:36:58 +01:00
|
|
|
match vx with
|
2020-01-08 11:24:53 +01:00
|
|
|
| Operator ({desc = Var v; _}) ->
|
2020-03-09 05:48:52 +01:00
|
|
|
(* set the variable, and invalidate all observers *)
|
2019-12-12 11:36:58 +01:00
|
|
|
invalidate_node vx;
|
|
|
|
v.binding <- x
|
|
|
|
| _ -> assert false
|
|
|
|
|
|
|
|
let peek = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Operator ({desc = Var v; _}) -> v.binding
|
2019-12-12 11:36:58 +01:00
|
|
|
| _ -> assert false
|
|
|
|
|
|
|
|
(* Primitives *)
|
|
|
|
type 'a prim = 'a t
|
|
|
|
let prim ~acquire ~release =
|
2020-01-08 11:24:53 +01:00
|
|
|
operator (Prim { acquire; release })
|
2019-12-12 11:36:58 +01:00
|
|
|
let get_prim x = x
|
|
|
|
|
|
|
|
let invalidate = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Operator ({ desc = Prim p; _ } as t) ->
|
2019-12-12 11:36:58 +01:00
|
|
|
let value = t.value in
|
|
|
|
t.value <- None;
|
2020-03-09 05:48:52 +01:00
|
|
|
(* the value is invalidated, be sure to invalidate all parents as well *)
|
2019-12-12 11:36:58 +01:00
|
|
|
invalidate_trace t.trace;
|
|
|
|
begin match value with
|
|
|
|
| None -> ()
|
|
|
|
| Some v -> p.release v
|
|
|
|
end
|
|
|
|
| _ -> assert false
|
|
|
|
|
|
|
|
type release_failure = exn * Printexc.raw_backtrace
|
|
|
|
exception Release_failure of release_failure list
|
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* [sub_release [] origin self] is called when [origin] is released,
|
|
|
|
where [origin] is reachable from [self]'s trace.
|
|
|
|
We're going to remove [origin] from that trace as [origin] is now dead.
|
|
|
|
|
|
|
|
[sub_release] cannot raise.
|
2019-12-12 11:36:58 +01:00
|
|
|
If a primitive raises, the exception is caught and a warning is emitted. *)
|
|
|
|
let rec sub_release
|
|
|
|
: type a b . release_failure list -> a t -> b t -> release_failure list
|
|
|
|
= fun failures origin -> function
|
|
|
|
| Root _ -> assert false
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ -> failures
|
|
|
|
| Operator t as self ->
|
2020-03-09 05:48:52 +01:00
|
|
|
(* compute [t.trace \ {origin}] *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let trace = match t.trace with
|
|
|
|
| T0 -> assert false
|
|
|
|
| T1 x -> assert (t_equal x origin); T0
|
|
|
|
| T2 (x, y) ->
|
|
|
|
if t_equal x origin then T1 y
|
|
|
|
else if t_equal y origin then T1 x
|
|
|
|
else assert false
|
|
|
|
| T3 (x, y, z) ->
|
|
|
|
if t_equal x origin then T2 (y, z)
|
|
|
|
else if t_equal y origin then T2 (x, z)
|
|
|
|
else if t_equal z origin then T2 (x, y)
|
|
|
|
else assert false
|
|
|
|
| T4 (x, y, z, w) ->
|
|
|
|
if t_equal x origin then T3 (y, z, w)
|
|
|
|
else if t_equal y origin then T3 (x, z, w)
|
|
|
|
else if t_equal z origin then T3 (x, y, w)
|
|
|
|
else assert false
|
|
|
|
| Tn tn as trace ->
|
|
|
|
let revidx = rem_idx self origin in
|
|
|
|
assert (t_equal tn.entries.(revidx) origin);
|
|
|
|
let count = tn.count - 1 in
|
|
|
|
tn.count <- count;
|
|
|
|
if revidx < count then (
|
|
|
|
let obj = tn.entries.(count) in
|
|
|
|
tn.entries.(revidx) <- obj;
|
|
|
|
mov_idx self count revidx obj
|
|
|
|
);
|
|
|
|
tn.entries.(count) <- dummy;
|
|
|
|
if tn.active > count then tn.active <- count;
|
|
|
|
if count = 4 then (
|
2020-03-09 05:48:52 +01:00
|
|
|
(* downgrade to [T4] to save space *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let a = tn.entries.(0) and b = tn.entries.(1) in
|
|
|
|
let c = tn.entries.(2) and d = tn.entries.(3) in
|
|
|
|
ignore (rem_idx self a : int);
|
|
|
|
ignore (rem_idx self b : int);
|
|
|
|
ignore (rem_idx self c : int);
|
|
|
|
ignore (rem_idx self d : int);
|
|
|
|
T4 (a, b, c, d)
|
2020-03-09 05:48:52 +01:00
|
|
|
) else (
|
2019-12-12 11:36:58 +01:00
|
|
|
let len = Array.length tn.entries in
|
|
|
|
if count <= len lsr 2 then
|
|
|
|
Tn { active = tn.active; count = tn.count;
|
|
|
|
entries = Array.sub tn.entries 0 (len lsr 1) }
|
|
|
|
else
|
|
|
|
trace
|
2020-03-09 05:48:52 +01:00
|
|
|
)
|
2019-12-12 11:36:58 +01:00
|
|
|
in
|
|
|
|
t.trace <- trace;
|
|
|
|
match trace with
|
|
|
|
| T0 ->
|
2020-03-09 05:48:52 +01:00
|
|
|
(* [self] is not active anymore, since it's not reachable
|
|
|
|
from any root. We can release its cached value and
|
|
|
|
recursively release its subtree. *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let value = t.value in
|
|
|
|
t.value <- None;
|
|
|
|
begin match t.desc with
|
|
|
|
| Map (x, _) -> sub_release failures self x
|
|
|
|
| Map2 (x, y, _) ->
|
|
|
|
sub_release (sub_release failures self x) self y
|
|
|
|
| Pair (x, y) ->
|
|
|
|
sub_release (sub_release failures self x) self y
|
|
|
|
| App (x, y) ->
|
|
|
|
sub_release (sub_release failures self x) self y
|
2019-12-14 08:51:39 +01:00
|
|
|
| Join ({ child; intermediate } as t) ->
|
2019-12-12 11:36:58 +01:00
|
|
|
let failures = sub_release failures self child in
|
|
|
|
begin match intermediate with
|
|
|
|
| None -> failures
|
|
|
|
| Some child' ->
|
|
|
|
t.intermediate <- None;
|
|
|
|
sub_release failures self child'
|
|
|
|
end
|
|
|
|
| Var _ -> failures
|
|
|
|
| Prim t ->
|
|
|
|
begin match value with
|
|
|
|
| None -> failures
|
|
|
|
| Some x ->
|
|
|
|
begin match t.release x with
|
|
|
|
| () -> failures
|
|
|
|
| exception exn ->
|
|
|
|
let bt = Printexc.get_raw_backtrace () in
|
|
|
|
(exn, bt) :: failures
|
|
|
|
end
|
|
|
|
end
|
|
|
|
end
|
|
|
|
| _ -> failures
|
|
|
|
|
|
|
|
(* [sub_acquire] cannot raise *)
|
|
|
|
let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
|
|
|
|
function
|
|
|
|
| Root _ -> assert false
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ -> ()
|
|
|
|
| Operator t as self ->
|
2020-03-09 05:48:52 +01:00
|
|
|
(* [acquire] is true if this is the first time this operator
|
|
|
|
is used, in which case we need to acquire its children *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let acquire = match t.trace with T0 -> true | _ -> false in
|
|
|
|
let trace = match t.trace with
|
|
|
|
| T0 -> T1 origin
|
|
|
|
| T1 x -> T2 (origin, x)
|
|
|
|
| T2 (x, y) -> T3 (origin, x, y)
|
|
|
|
| T3 (x, y, z) -> T4 (origin, x, y, z)
|
|
|
|
| T4 (x, y, z, w) ->
|
2020-03-09 05:48:52 +01:00
|
|
|
let obj_origin = obj_t origin in
|
2019-12-12 11:36:58 +01:00
|
|
|
let entries =
|
2020-03-09 05:48:52 +01:00
|
|
|
[| obj_t x; obj_t y; obj_t z; obj_t w; obj_origin; dummy; dummy; dummy |]
|
2019-12-12 11:36:58 +01:00
|
|
|
in
|
|
|
|
for i = 0 to 4 do add_idx self i entries.(i) done;
|
|
|
|
Tn { active = 5; count = 5; entries }
|
|
|
|
| Tn tn as trace ->
|
|
|
|
let index = tn.count in
|
|
|
|
let entries, trace =
|
2020-03-09 05:48:52 +01:00
|
|
|
(* possibly resize array [entries] *)
|
2019-12-12 11:36:58 +01:00
|
|
|
if index < Array.length tn.entries then (
|
|
|
|
tn.count <- tn.count + 1;
|
|
|
|
(tn.entries, trace)
|
|
|
|
) else (
|
|
|
|
let entries = Array.make (index * 2) dummy in
|
|
|
|
Array.blit tn.entries 0 entries 0 index;
|
|
|
|
(entries, Tn { active = tn.active; count = index + 1; entries })
|
|
|
|
)
|
|
|
|
in
|
2020-03-09 05:48:52 +01:00
|
|
|
let obj_origin = obj_t origin in
|
|
|
|
entries.(index) <- obj_origin;
|
|
|
|
add_idx self index obj_origin;
|
2019-12-12 11:36:58 +01:00
|
|
|
trace
|
|
|
|
in
|
|
|
|
t.trace <- trace;
|
2020-03-09 05:48:52 +01:00
|
|
|
if acquire then (
|
|
|
|
(* acquire immediate children, and so on recursively *)
|
2019-12-12 11:36:58 +01:00
|
|
|
match t.desc with
|
|
|
|
| Map (x, _) -> sub_acquire self x
|
|
|
|
| Map2 (x, y, _) ->
|
|
|
|
sub_acquire self x;
|
|
|
|
sub_acquire self y
|
|
|
|
| Pair (x, y) ->
|
|
|
|
sub_acquire self x;
|
|
|
|
sub_acquire self y
|
|
|
|
| App (x, y) ->
|
|
|
|
sub_acquire self x;
|
|
|
|
sub_acquire self y
|
2019-12-14 08:51:39 +01:00
|
|
|
| Join { child; intermediate } ->
|
2019-12-12 11:36:58 +01:00
|
|
|
sub_acquire self child;
|
|
|
|
begin match intermediate with
|
|
|
|
| None -> ()
|
2020-03-09 05:48:52 +01:00
|
|
|
| Some _ ->
|
|
|
|
assert false (* this can't initialized already, first-time acquire *)
|
2019-12-12 11:36:58 +01:00
|
|
|
end
|
|
|
|
| Var _ -> ()
|
|
|
|
| Prim _ -> ()
|
2020-03-09 05:48:52 +01:00
|
|
|
)
|
2019-12-12 11:36:58 +01:00
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* make sure that [origin] is in [self.trace], passed as last arg. *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let activate_tracing self origin = function
|
|
|
|
| Tn tn ->
|
2020-03-09 05:48:52 +01:00
|
|
|
let idx = get_idx self origin in (* index of [self] in [origin.trace_idx] *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let active = tn.active in
|
2020-03-09 05:48:52 +01:00
|
|
|
(* [idx < active] means [self] is already traced by [origin].
|
|
|
|
We only have to add [self] to the entries if [idx >= active]. *)
|
|
|
|
if idx >= active then (
|
2019-12-12 11:36:58 +01:00
|
|
|
tn.active <- active + 1;
|
2020-03-09 05:48:52 +01:00
|
|
|
);
|
2019-12-12 11:36:58 +01:00
|
|
|
if idx > active then (
|
2020-03-09 05:48:52 +01:00
|
|
|
(* swap with last entry in [tn.entries] *)
|
2019-12-12 11:36:58 +01:00
|
|
|
let old = tn.entries.(active) in
|
|
|
|
tn.entries.(idx) <- old;
|
|
|
|
tn.entries.(active) <- obj_t origin;
|
|
|
|
mov_idx self active idx old;
|
|
|
|
mov_idx self idx active origin
|
|
|
|
)
|
|
|
|
| _ -> ()
|
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
(* [sub_sample origin self] computes a value for [self].
|
|
|
|
|
|
|
|
[sub_sample] raise if any user-provided computation raises.
|
2019-12-12 11:36:58 +01:00
|
|
|
Graph will be left in a coherent state but exception will be propagated
|
|
|
|
to the observer. *)
|
|
|
|
let rec sub_sample : type a b . a t -> b t -> b = fun origin ->
|
|
|
|
function
|
|
|
|
| Root _ -> assert false
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure x | Impure x -> x
|
|
|
|
| Operator t as self ->
|
2020-03-09 05:48:52 +01:00
|
|
|
(* try to use cached value, if present *)
|
2019-12-12 11:36:58 +01:00
|
|
|
match t.value with
|
|
|
|
| Some value -> value
|
|
|
|
| None ->
|
|
|
|
let value : b = match t.desc with
|
|
|
|
| Map (x, f) -> f (sub_sample self x)
|
|
|
|
| Map2 (x, y, f) -> f (sub_sample self x) (sub_sample self y)
|
|
|
|
| Pair (x, y) -> (sub_sample self x, sub_sample self y)
|
|
|
|
| App (f, x) -> (sub_sample self f) (sub_sample self x)
|
2019-12-14 08:51:39 +01:00
|
|
|
| Join x ->
|
2019-12-12 11:36:58 +01:00
|
|
|
let old_intermediate = x.intermediate in
|
|
|
|
let intermediate =
|
|
|
|
(* We haven't touched any state yet,
|
2019-12-14 08:51:39 +01:00
|
|
|
it is safe for [sub_sample] to raise *)
|
|
|
|
sub_sample self x.child
|
2019-12-12 11:36:58 +01:00
|
|
|
in
|
|
|
|
x.intermediate <- Some intermediate;
|
|
|
|
sub_acquire self intermediate;
|
|
|
|
let result = sub_sample self intermediate in
|
|
|
|
begin match old_intermediate with
|
|
|
|
| None -> result
|
|
|
|
| Some x' ->
|
2020-03-09 05:48:52 +01:00
|
|
|
(* NOTE: if [intermediate==x'], should we stop there? *)
|
|
|
|
(* release old value [x'], catching potential exceptions *)
|
2019-12-12 11:36:58 +01:00
|
|
|
match sub_release [] self x' with
|
|
|
|
| [] -> result
|
|
|
|
| failures ->
|
|
|
|
(* Commit result, just like normal continuation *)
|
|
|
|
t.value <- Some result;
|
|
|
|
activate_tracing self origin t.trace;
|
|
|
|
(* Raise release exception *)
|
|
|
|
raise (Release_failure failures)
|
|
|
|
end
|
|
|
|
| Var x -> x.binding
|
|
|
|
| Prim t -> t.acquire ()
|
|
|
|
in
|
|
|
|
t.value <- Some value;
|
2020-03-09 05:48:52 +01:00
|
|
|
(* [self] just became active, so it may invalidate [origin] in case its
|
|
|
|
value changes because of [t.desc], like if it's a variable and gets
|
|
|
|
mutated, or if it's a primitive that gets invalidated.
|
|
|
|
We need to put [origin] into [self.trace] in case it isn't there yet. *)
|
2019-12-12 11:36:58 +01:00
|
|
|
activate_tracing self origin t.trace;
|
|
|
|
value
|
|
|
|
|
|
|
|
type 'a root = 'a t
|
|
|
|
|
2020-03-09 05:48:52 +01:00
|
|
|
let observe ?(on_invalidate=ignore) child : _ root =
|
2019-12-12 11:36:58 +01:00
|
|
|
let root = Root {
|
2019-12-24 23:15:13 +01:00
|
|
|
child = child;
|
2019-12-12 11:36:58 +01:00
|
|
|
value = None;
|
|
|
|
on_invalidate;
|
2019-12-24 23:15:13 +01:00
|
|
|
trace_idx = I0;
|
|
|
|
acquired = false;
|
2019-12-12 11:36:58 +01:00
|
|
|
} in
|
|
|
|
root
|
|
|
|
|
|
|
|
let sample = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ | Operator _ -> assert false
|
2019-12-12 11:36:58 +01:00
|
|
|
| Root t as self ->
|
|
|
|
match t.value with
|
|
|
|
| Some value -> value
|
|
|
|
| None ->
|
2020-03-09 05:48:52 +01:00
|
|
|
(* no cached value, compute it now *)
|
2019-12-24 23:15:13 +01:00
|
|
|
if not t.acquired then (
|
|
|
|
t.acquired <- true;
|
|
|
|
sub_acquire self t.child;
|
|
|
|
);
|
|
|
|
let value = sub_sample self t.child in
|
2020-03-09 05:48:52 +01:00
|
|
|
t.value <- Some value; (* cache value *)
|
2019-12-24 23:15:13 +01:00
|
|
|
value
|
2019-12-12 11:36:58 +01:00
|
|
|
|
|
|
|
let is_damaged = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ | Operator _ -> assert false
|
2019-12-12 11:36:58 +01:00
|
|
|
| Root { value = None ; _ } -> true
|
|
|
|
| Root { value = Some _ ; _ } -> false
|
|
|
|
|
2020-01-08 11:24:12 +01:00
|
|
|
let release = function
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ | Operator _ -> assert false
|
2019-12-12 11:36:58 +01:00
|
|
|
| Root t as self ->
|
2019-12-24 23:15:13 +01:00
|
|
|
if t.acquired then (
|
2020-03-09 05:48:52 +01:00
|
|
|
(* release subtree, remove cached value *)
|
2019-12-12 11:36:58 +01:00
|
|
|
t.value <- None;
|
2019-12-24 23:15:13 +01:00
|
|
|
t.acquired <- false;
|
|
|
|
match sub_release [] self t.child with
|
2019-12-12 11:36:58 +01:00
|
|
|
| [] -> ()
|
|
|
|
| failures -> raise (Release_failure failures)
|
2019-12-24 23:15:13 +01:00
|
|
|
)
|
2019-12-12 11:36:58 +01:00
|
|
|
|
|
|
|
let set_on_invalidate x f =
|
|
|
|
match x with
|
2020-01-08 11:24:53 +01:00
|
|
|
| Pure _ | Impure _ | Operator _ -> assert false
|
2019-12-12 11:36:58 +01:00
|
|
|
| Root t -> t.on_invalidate <- f
|