doc: add some comments in lwd.ml{,i}

This commit is contained in:
Simon Cruanes 2020-03-08 23:48:52 -05:00 committed by Frédéric Bour
parent ca24d162b9
commit 4abe78c371
2 changed files with 172 additions and 41 deletions

View File

@ -1,15 +1,24 @@
(** 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
type 'a t =
| Pure of 'a
| Impure of 'a
| Impure of 'a (* NOTE: is this really used anywhere? *)
| Operator : {
mutable value : 'a option;
mutable trace : trace;
mutable trace_idx : trace_idx;
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 *)
desc: 'a desc;
} -> 'a t
| Root : {
mutable value : 'a option;
mutable trace_idx : trace_idx;
mutable value : 'a option; (* cached value *)
mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *)
mutable on_invalidate : 'a -> unit;
mutable acquired : bool;
child : 'a t;
@ -25,6 +34,7 @@ and _ desc =
| Prim : { acquire : unit -> 'a;
release : 'a -> unit } -> 'a desc
(* a set of (active) parents for a ['a t], used during invalidation *)
and trace =
| T0
| T1 : _ t -> trace
@ -32,8 +42,9 @@ and trace =
| T3 : _ t * _ t * _ t -> trace
| T4 : _ t * _ t * _ t * _ t -> trace
| Tn : { mutable active : int; mutable count : int;
mutable entries : Obj.t t array } -> trace
mutable entries : Any.t t array } -> trace
(* a set of direct children for a composite document *)
and trace_idx =
| I0
| I1 : { mutable idx : int ;
@ -48,7 +59,7 @@ let impure = function
| Pure x -> Impure x
| other -> other
let dummy = Pure (Obj.repr ())
let dummy = Pure (Any.any ())
let operator desc =
Operator { value = None; trace = T0; desc; trace_idx = I0 }
@ -82,71 +93,78 @@ let bind x f = join (map f x)
(* Management of trace indices *)
external t_equal : _ t -> _ t -> bool = "%eq"
external obj_t : 'a t -> Obj.t t = "%identity"
external obj_t : 'a t -> Any.t t = "%identity"
let add_idx obj idx = function
| Pure _ | Impure _ -> assert false
| Root t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
| Operator t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
let rec rem_idx obj = function
let rec rem_idx_rec obj = function
| I0 -> assert false
| I1 t as self ->
if t_equal t.obj obj
then (t.idx, t.next)
else
let idx, result = rem_idx obj t.next in
else (
let idx, result = rem_idx_rec obj t.next in
t.next <- result;
(idx, self)
)
(* remove [obj] from the lwd's trace. *)
let rem_idx obj = function
| Pure _ | Impure _ -> assert false
| Root t' ->
let idx, trace_idx = rem_idx obj t'.trace_idx in
let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
t'.trace_idx <- trace_idx; idx
| Operator t' ->
let idx, trace_idx = rem_idx obj t'.trace_idx in
let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
t'.trace_idx <- trace_idx; idx
let rec mov_idx obj oldidx newidx = function
(* move [obj] from old index to new index. *)
let rec mov_idx_rec obj oldidx newidx = function
| I0 -> assert false
| I1 t ->
if t.idx = oldidx && t_equal t.obj obj
then t.idx <- newidx
else mov_idx obj oldidx newidx t.next
else mov_idx_rec obj oldidx newidx t.next
let mov_idx obj oldidx newidx = function
| Pure _ | Impure _ -> assert false
| Root t' -> mov_idx obj oldidx newidx t'.trace_idx
| Operator t' -> mov_idx obj oldidx newidx t'.trace_idx
| Root t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
| Operator t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
let rec get_idx obj = function
let rec get_idx_rec obj = function
| I0 -> assert false
| I1 t ->
if t_equal t.obj obj
then t.idx
else get_idx obj t.next
else get_idx_rec obj t.next
(* find index of [obj] in the given lwd *)
let get_idx obj = function
| Pure _ | Impure _ -> assert false
| Root t' -> get_idx obj t'.trace_idx
| Operator t' -> get_idx obj t'.trace_idx
| Root t' -> get_idx_rec obj t'.trace_idx
| Operator t' -> get_idx_rec obj t'.trace_idx
(* Propagating invalidation *)
(* Propagating invalidation recursively.
Each document is invalidated at most once,
and only if it has [t.value = Some _]. *)
let rec invalidate_node : type a . a t -> unit = function
| Pure _ | Impure _ -> assert false
| Root { value = None; _ } -> ()
| Root ({ value = Some x; _ } as t) ->
t.value <- None;
t.on_invalidate x
t.on_invalidate x (* user callback that {i observes} this root. *)
| Operator t ->
begin match t.value with
| None -> ()
| Some _ ->
t.value <- None;
invalidate_trace t.trace
invalidate_trace t.trace; (* invalidate parents recursively *)
end
(* invalidate recursively documents in the given trace *)
and invalidate_trace = function
| T0 -> ()
| T1 x -> invalidate_node x
@ -174,9 +192,10 @@ type 'a var = 'a t
let var x = operator (Var {binding = x})
let get x = x
let set vx x =
let set (vx:_ var) x : unit =
match vx with
| Operator ({desc = Var v; _}) ->
(* set the variable, and invalidate all observers *)
invalidate_node vx;
v.binding <- x
| _ -> assert false
@ -195,6 +214,7 @@ let invalidate = function
| Operator ({ desc = Prim p; _ } as t) ->
let value = t.value in
t.value <- None;
(* the value is invalidated, be sure to invalidate all parents as well *)
invalidate_trace t.trace;
begin match value with
| None -> ()
@ -205,7 +225,11 @@ let invalidate = function
type release_failure = exn * Printexc.raw_backtrace
exception Release_failure of release_failure list
(* [sub_release] cannot raise.
(* [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.
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
@ -213,6 +237,7 @@ let rec sub_release
| Root _ -> assert false
| Pure _ | Impure _ -> failures
| Operator t as self ->
(* compute [t.trace \ {origin}] *)
let trace = match t.trace with
| T0 -> assert false
| T1 x -> assert (t_equal x origin); T0
@ -243,6 +268,7 @@ let rec sub_release
tn.entries.(count) <- dummy;
if tn.active > count then tn.active <- count;
if count = 4 then (
(* downgrade to [T4] to save space *)
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);
@ -250,17 +276,21 @@ let rec sub_release
ignore (rem_idx self c : int);
ignore (rem_idx self d : int);
T4 (a, b, c, d)
) else
) else (
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
)
in
t.trace <- trace;
match trace with
| T0 ->
(* [self] is not active anymore, since it's not reachable
from any root. We can release its cached value and
recursively release its subtree. *)
let value = t.value in
t.value <- None;
begin match t.desc with
@ -300,6 +330,8 @@ let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
| Root _ -> assert false
| Pure _ | Impure _ -> ()
| Operator t as self ->
(* [acquire] is true if this is the first time this operator
is used, in which case we need to acquire its children *)
let acquire = match t.trace with T0 -> true | _ -> false in
let trace = match t.trace with
| T0 -> T1 origin
@ -307,15 +339,16 @@ let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
| T2 (x, y) -> T3 (origin, x, y)
| T3 (x, y, z) -> T4 (origin, x, y, z)
| T4 (x, y, z, w) ->
let obj = obj_t origin in
let obj_origin = obj_t origin in
let entries =
[| obj_t x; obj_t y; obj_t z; obj_t w; obj; dummy; dummy; dummy |]
[| obj_t x; obj_t y; obj_t z; obj_t w; obj_origin; dummy; dummy; dummy |]
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 =
(* possibly resize array [entries] *)
if index < Array.length tn.entries then (
tn.count <- tn.count + 1;
(tn.entries, trace)
@ -325,13 +358,14 @@ let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
(entries, Tn { active = tn.active; count = index + 1; entries })
)
in
let obj = obj_t origin in
entries.(index) <- obj;
add_idx self index obj;
let obj_origin = obj_t origin in
entries.(index) <- obj_origin;
add_idx self index obj_origin;
trace
in
t.trace <- trace;
if acquire then
if acquire then (
(* acquire immediate children, and so on recursively *)
match t.desc with
| Map (x, _) -> sub_acquire self x
| Map2 (x, y, _) ->
@ -347,18 +381,25 @@ let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
sub_acquire self child;
begin match intermediate with
| None -> ()
| Some _ -> assert false
| Some _ ->
assert false (* this can't initialized already, first-time acquire *)
end
| Var _ -> ()
| Prim _ -> ()
)
(* make sure that [origin] is in [self.trace], passed as last arg. *)
let activate_tracing self origin = function
| Tn tn ->
let idx = get_idx self origin in
let idx = get_idx self origin in (* index of [self] in [origin.trace_idx] *)
let active = tn.active in
if idx >= active then
(* [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 (
tn.active <- active + 1;
);
if idx > active then (
(* swap with last entry in [tn.entries] *)
let old = tn.entries.(active) in
tn.entries.(idx) <- old;
tn.entries.(active) <- obj_t origin;
@ -367,7 +408,9 @@ let activate_tracing self origin = function
)
| _ -> ()
(* [sub_sample] raise if any user-provided computation raises.
(* [sub_sample origin self] computes a value for [self].
[sub_sample] raise if any user-provided computation raises.
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 ->
@ -375,6 +418,7 @@ let rec sub_sample : type a b . a t -> b t -> b = fun origin ->
| Root _ -> assert false
| Pure x | Impure x -> x
| Operator t as self ->
(* try to use cached value, if present *)
match t.value with
| Some value -> value
| None ->
@ -396,6 +440,8 @@ let rec sub_sample : type a b . a t -> b t -> b = fun origin ->
begin match old_intermediate with
| None -> result
| Some x' ->
(* NOTE: if [intermediate==x'], should we stop there? *)
(* release old value [x'], catching potential exceptions *)
match sub_release [] self x' with
| [] -> result
| failures ->
@ -409,12 +455,16 @@ let rec sub_sample : type a b . a t -> b t -> b = fun origin ->
| Prim t -> t.acquire ()
in
t.value <- Some value;
(* [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. *)
activate_tracing self origin t.trace;
value
type 'a root = 'a t
let observe ?(on_invalidate=ignore) child =
let observe ?(on_invalidate=ignore) child : _ root =
let root = Root {
child = child;
value = None;
@ -430,12 +480,13 @@ let sample = function
match t.value with
| Some value -> value
| None ->
(* no cached value, compute it now *)
if not t.acquired then (
t.acquired <- true;
sub_acquire self t.child;
);
let value = sub_sample self t.child in
t.value <- Some value;
t.value <- Some value; (* cache value *)
value
let is_damaged = function
@ -447,6 +498,7 @@ let release = function
| Pure _ | Impure _ | Operator _ -> assert false
| Root t as self ->
if t.acquired then (
(* release subtree, remove cached value *)
t.value <- None;
t.acquired <- false;
match sub_release [] self t.child with

View File

@ -1,25 +1,86 @@
type 'a t
(** A dynamic document of type ['a]. Documents can be produced in several
different ways:
- operators, such as {!map}, {!bind}, {!app}, {!pair}, etc.
combine several documents into one. The result is (lazily)
updated whenever the sub-documents are.
- variables {!var}, a mutable reference.
- primitive documents {!prim}, providing custom leaves to trees of
documents.
*)
val return : 'a -> 'a t
(** The content document with the given value inside *)
val pure : 'a -> 'a t
(** Alias to {!return} *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** [map f d] is the document that has value [f x] whenever [d] has value [x] *)
val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
(** [map2 f d1 d2] is the document that has value [f x y] whenever
[d1] has value [x1] and [d2] has value [x2] *)
val map' : 'a t -> ('a -> 'b) -> 'b t
(** Alias to {!map} with arguments flipped *)
val map2' : 'a t -> 'b t -> ('a -> 'b -> 'c) -> 'c t
(** Alias to {!map2} with arguments flipped *)
val join : 'a t t -> 'a t
(** Monadic operator [join d] is the document pointed to by document [d].
This is powerful but potentially costly in case of recomputation.
*)
val bind : 'a t -> ('a -> 'b t) -> 'b t
(** Monadic bind, a mix of {!join} and {!map} *)
val app : ('a -> 'b) t -> 'a t -> 'b t
(** Applicative: [app df dx] is the document that has value [f x]
whenever [df] has value [f] and [dx] has value [x] *)
val pair : 'a t -> 'b t -> ('a * 'b) t
(** [pair a b] is [map2 (fun x y->x,y) a b] *)
val impure : 'a t -> 'a t
type 'a var
(** The workhorse of Lwd: a mutable variable that also tracks dependencies.
Every time {!set} is called, all documents that depend on this variable
via {!map}, {!bind}, etc. will be at least partially invalidated
and will be recomputed incrementally on demand. *)
val var : 'a -> 'a var
(** Create a new variable with the given initial value *)
val get : 'a var -> 'a t
(** A document that reflects the current content of a variable *)
val set : 'a var -> 'a -> unit
val peek : 'a var -> 'a
(** Change the variable's content, invalidating all documents depending
on it. *)
val peek : 'a var -> 'a
(** Observe the current value of the variable, without any dependency
tracking. *)
type 'a prim
(** A primitive document. It can correspond, for example, to
a primitive UI element.
A primitive is a resource with [acquire] and [release] functions
to manage its lifecycle. *)
val prim : acquire:(unit -> 'a) -> release:('a -> unit) -> 'a prim
(** create a new primitive document.
@param acquire is called when the document becomes observed (indirectly)
via at least one {!root}.
@param release is called when the document is no longer observed.
Internal resources can be freed. *)
val get_prim : 'a prim -> 'a t
val invalidate : 'a prim -> unit
@ -27,9 +88,27 @@ type release_failure = exn * Printexc.raw_backtrace
exception Release_failure of release_failure list
type 'a root
(** A root of computation, whose value(s) over time we're interested in. *)
val observe : ?on_invalidate:('a -> unit) -> 'a t -> 'a root
(** [observe x] creates a root that contains document [x].
@param on_invalidate is called whenever the root is invalidated
because the content of [x] has changed. This can be useful to
perform side-effects such as re-rendering some UI. *)
val set_on_invalidate : 'a root -> ('a -> unit) -> unit
(** Change the callback for the root.
@see observe for more details. *)
val sample : 'a root -> 'a
(** Force the computation of the value for this root.
The value is cached, so this is idempotent, until the next invalidation. *)
val is_damaged : 'a root -> bool
(** [is_damaged root] is true if the root doesn't have a valid value in
cache. This can be the case if the value was never computed, or
if it was computed and then invalidated. *)
val release : 'a root -> unit
(** Forget about this root and release sub-values no longer reachable from
any root. *)