def
/
lwd
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
Browse Source

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

pull/6/head^2
Simon Cruanes 2 years ago committed by Frédéric Bour
parent
ca24d162b9
commit
4abe78c371
2 changed files with 172 additions and 41 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 132
      lib/lwd/lwd.ml
  2. 81
      lib/lwd/lwd.mli

132
lib/lwd/lwd.ml
Unescape 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

81
lib/lwd/lwd.mli
Unescape 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. *)

Write Preview
Loading…
Cancel
Save