Browse Source

Source import

pull/3/head
Frédéric Bour 2 years ago
parent
commit
cc70dea085
  1. 107
      lib/dset/dset.ml
  2. 33
      lib/dset/dset.mli
  3. 0
      lib/dset/dset.opam
  4. 9
      lib/dset/dune
  5. 1
      lib/dset/dune-project
  6. 28
      lib/dset/test.ml
  7. 22
      lib/dset/test_1.ml
  8. 5
      lib/lwd/dune
  9. 2
      lib/lwd/dune-project
  10. 451
      lib/lwd/lwd.ml
  11. 40
      lib/lwd/lwd.mli
  12. 0
      lib/lwd/lwd.opam
  13. 522
      lib/lwd/lwd_table.ml
  14. 28
      lib/lwd/lwd_table.mli
  15. 474
      lib/lwd/lwd_trace_debug.ml
  16. 49
      lib/lwd/lwd_utils.ml
  17. 8
      lib/lwd/lwd_utils.mli
  18. 2
      lib/nottui-lwt/Makefile
  19. 4
      lib/nottui-lwt/dune
  20. 2
      lib/nottui-lwt/dune-project
  21. 0
      lib/nottui-lwt/nottui-lwt.opam
  22. 73
      lib/nottui-lwt/nottui_lwt.ml
  23. 13
      lib/nottui-lwt/nottui_lwt.mli
  24. 4
      lib/nottui-widgets/dune
  25. 2
      lib/nottui-widgets/dune-project
  26. 0
      lib/nottui-widgets/nottui-widgets.opam
  27. 379
      lib/nottui-widgets/nottui_widgets.ml
  28. 5
      lib/nottui/Makefile
  29. 3
      lib/nottui/dune
  30. 2
      lib/nottui/dune-project
  31. 677
      lib/nottui/nottui.ml
  32. 105
      lib/nottui/nottui.mli
  33. 0
      lib/nottui/nottui.opam
  34. 14
      tests/dune
  35. 137
      tests/misc.ml
  36. 135
      tests/reranger.ml
  37. 41
      tests/stress.ml

107
lib/dset/dset.ml

@ -0,0 +1,107 @@
type 'a t =
| Empty
| Leaf of {
mutable mark: int;
v: 'a;
}
| Join of {
mutable mark: int;
l: 'a t;
r: 'a t;
}
let empty = Empty
let element v = Leaf { mark = 0; v }
let union a b = match a, b with
| Empty, x | x, Empty -> x
| l, r -> Join { mark = 0; l; r }
let rec mark_all mask = function
| Empty -> ()
| Leaf t -> t.mark <- t.mark lor mask
| Join t ->
let mark = t.mark in
if mark <> 0 && mark land mask = 0 then (
t.mark <- mark lor mask;
mark_all mask t.l;
mark_all mask t.r;
)
let enqueue q mask = function
| Empty -> ()
| Leaf t -> t.mark <- t.mark lor mask
| Join t as node ->
let mark = t.mark in
if mark land mask = 0 then (
if mark = 0 then (
t.mark <- mask;
Queue.push node q
) else (
t.mark <- mark lor mask;
mark_all mask t.l;
mark_all mask t.r;
)
)
let dequeue q mask =
match Queue.pop q with
| Join t ->
if t.mark = mask then (
enqueue q mask t.l;
enqueue q mask t.r;
)
| _ -> assert false
let traverse1 q mask =
while not (Queue.is_empty q) do
dequeue q mask
done
let old_mask = 1
let new_mask = 2
let rec traverse qold qnew =
if Queue.is_empty qold then
traverse1 qnew new_mask
else if Queue.is_empty qnew then
traverse1 qold old_mask
else (
dequeue qold old_mask;
dequeue qnew new_mask;
traverse qold qnew
)
type 'a diff = { added : 'a list; removed : 'a list }
let diff told tnew =
if told == tnew then
{ added = []; removed = [] }
else
let qold = Queue.create () in
let qnew = Queue.create () in
enqueue qold old_mask told;
enqueue qnew new_mask tnew;
traverse qold qnew;
let added = ref [] in
let removed = ref [] in
let rec unmark = function
| Empty -> ()
| Leaf ({mark; v} as t) ->
t.mark <- 0;
if mark = old_mask then (
removed := v :: !removed;
) else if mark = new_mask then (
added := v :: !added;
)
| Join t ->
if t.mark <> 0 then (
t.mark <- 0;
unmark t.l;
unmark t.r;
)
in
unmark told;
unmark tnew;
{ added = !added; removed = !removed }

33
lib/dset/dset.mli

@ -0,0 +1,33 @@
(** A set of abstract elements annotated with values of type ['a] that can be
efficiently diffed. *)
type 'a t
(** The empty set *)
val empty : 'a t
(** [element x] creates a new set element tagged with metadata [x] (O(1)).
It is the physical identity of the element that is considered when
computing set difference, not the tag.
Therefore [diff (element x) (element x) = { added = [x]; removed = [x]; }]
But [(let e = element x in diff e e) = { added = []; removed = []; }]
*)
val element : 'a -> 'a t
(** The union of two set of resources (O(1)) *)
val union : 'a t -> 'a t -> 'a t
(** Compute the difference between two sets.
[diff old_set new_set = { added; removed }]
where [removed] lists the tag of elements only present in [old_set]
and [added] lists the tag of elements only present in [new_set]
_Conjecture_: the algorithm is linear in the number of changes between
[old_set] and [new_set].
When used in a linear fashion (you have a sequence of sets [s_i] and only
compare [s_i] and [s_i+1], at most once for each [i]), it should not affect
the complexity of the program.
*)
type 'a diff = { added : 'a list; removed : 'a list }
val diff : 'a t -> 'a t -> 'a diff

0
lib/dset/dset.opam

9
lib/dset/dune

@ -0,0 +1,9 @@
(library
(name dset)
(modules dset)
(wrapped false))
(test
(name test_1)
(modules test_1)
(libraries dset))

1
lib/dset/dune-project

@ -0,0 +1 @@
(lang dune 1.11)

28
lib/dset/test.ml

@ -0,0 +1,28 @@
open Rtree.Rtree
let x = leaf 1
let y = leaf 2
let _ = diff empty empty
let _ = diff (leaf 1) (leaf 2)
let _ = diff (join x x) (join x x)
let _ = diff (join x y) (join x x)
let _ = diff (join x x) (join x y)
let _ = diff (join x y) (join x y)
let t0 = join x y
let _ = diff t0 t0
let _ =
let k1 = ref 0 in
let k2 = ref 1_000_000 in
let t1 = join t0 (leaf 3) in
let t2 = join (leaf 0) t0 in
while true do
incr k1;
decr k2;
ignore (diff t1 t2);
if !k2 = 0 then (
k2 := 1_000_000;
Printf.printf "% 8d iterations in %fs\n%!" !k1 (Sys.time ());
)
done

22
lib/dset/test_1.ml

@ -0,0 +1,22 @@
open Dset
let check ?(removed=[]) ?(added=[]) diff =
List.for_all (fun x -> List.mem x added) diff.added &&
List.for_all (fun x -> List.mem x removed) diff.removed
let e1 = element 1 and e2 = element 2
let () =
assert (check (diff empty empty));
assert (check (diff (element 1) (element 2)) ~removed:[1] ~added:[2]);
assert (check (diff (element 1) (element 1)) ~removed:[1] ~added:[1]);
assert (check (diff e1 e1));
assert (check (diff e1 e2) ~removed:[1] ~added:[2]);
assert (check (diff e2 e1) ~removed:[2] ~added:[1]);
assert (check (diff e2 e2));
assert (check (diff (union e1 e1) (union e1 e1)));
assert (check (diff (union e1 e2) (union e1 e1)) ~removed:[2]);
assert (check (diff (union e1 e1) (union e1 e2)) ~added:[2]);
assert (check (diff (union e1 e2) (union e1 e2)));
assert (check (diff (union e1 e2) empty) ~removed:[2; 1]);
assert (check (diff empty (union e1 e2)) ~added:[1; 2]);

5
lib/lwd/dune

@ -0,0 +1,5 @@
(library
(name lwd)
(public_name lwd)
(modules lwd lwd_table lwd_utils)
(wrapped false))

2
lib/lwd/dune-project

@ -0,0 +1,2 @@
(lang dune 1.11)
(name lwd)

451
lib/lwd/lwd.ml

@ -0,0 +1,451 @@
type 'a t =
| Pure of 'a
| Impure : {
mutable value : 'a option;
mutable trace : trace;
mutable trace_idx : trace_idx;
desc: 'a desc;
} -> 'a t
| Root : {
mutable value : 'a option;
mutable trace_idx : trace_idx;
mutable on_invalidate : 'a -> unit;
mutable child : 'a t option;
} -> '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
| Bind : { child : 'a t; map : 'a -> 'b t;
mutable intermediate : 'b t option } -> 'b desc
| Var : { mutable binding : 'a } -> 'a desc
| Prim : { acquire : unit -> 'a;
release : 'a -> unit } -> 'a desc
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;
mutable entries : Obj.t t array } -> trace
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
let dummy = Pure (Obj.repr ())
let impure desc =
Impure { value = None; trace = T0; desc; trace_idx = I0 }
let map f x = impure (Map (x, f))
let map2 f x y = impure (Map2 (x, y, f))
let map' x f = impure (Map (x, f))
let map2' x y f = impure (Map2 (x, y, f))
let pair x y = impure (Pair (x, y))
let app f x = impure (App (f, x))
let bind child map = impure (Bind { child; map; intermediate = None })
let id x = x
let join child = impure (Bind { child; map = id; intermediate = None })
(* Management of trace indices *)
external t_equal : _ t -> _ t -> bool = "%eq"
external obj_t : 'a t -> Obj.t t = "%identity"
let add_idx obj idx = function
| Pure _ -> assert false
| Root t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
| Impure t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
let rec rem_idx 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
t.next <- result;
(idx, self)
let rem_idx obj = function
| Pure _ -> assert false
| Root t' ->
let idx, trace_idx = rem_idx obj t'.trace_idx in
t'.trace_idx <- trace_idx; idx
| Impure t' ->
let idx, trace_idx = rem_idx obj t'.trace_idx in
t'.trace_idx <- trace_idx; idx
let rec mov_idx 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
let mov_idx obj oldidx newidx = function
| Pure _ -> assert false
| Root t' -> mov_idx obj oldidx newidx t'.trace_idx
| Impure t' -> mov_idx obj oldidx newidx t'.trace_idx
let rec get_idx obj = function
| I0 -> assert false
| I1 t ->
if t_equal t.obj obj
then t.idx
else get_idx obj t.next
let get_idx obj = function
| Pure _ -> assert false
| Root t' -> get_idx obj t'.trace_idx
| Impure t' -> get_idx obj t'.trace_idx
(* Propagating invalidation *)
let rec invalidate_node : type a . a t -> unit = function
| Pure _ -> assert false
| Root { value = None; _ } -> ()
| Root ({ value = Some x; _ } as t) ->
t.value <- None;
t.on_invalidate x
| Impure t ->
begin match t.value with
| None -> ()
| Some _ ->
t.value <- None;
invalidate_trace t.trace
end
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
let var x = impure (Var {binding = x})
let get x = x
let set vx x =
match vx with
| Impure ({desc = Var v; _}) ->
invalidate_node vx;
v.binding <- x
| _ -> assert false
let peek = function
| Impure ({desc = Var v; _}) -> v.binding
| _ -> assert false
(* Primitives *)
type 'a prim = 'a t
let prim ~acquire ~release =
impure (Prim { acquire; release })
let get_prim x = x
let invalidate = function
| Impure ({ desc = Prim p; _ } as t) ->
let value = t.value in
t.value <- None;
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
(* [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
= fun failures origin -> function
| Root _ -> assert false
| Pure _ -> failures
| Impure t as self ->
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 (
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)
) 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 ->
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
| Bind ({ child; intermediate; map = _ } as t) ->
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
| Pure _ -> ()
| Impure t as self ->
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) ->
let obj = obj_t origin in
let entries =
[| obj_t x; obj_t y; obj_t z; obj_t w; obj; 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 =
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
let obj = obj_t origin in
entries.(index) <- obj;
add_idx self index obj;
trace
in
t.trace <- trace;
if acquire then
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
| Bind { child; intermediate; map = _ } ->
sub_acquire self child;
begin match intermediate with
| None -> ()
| Some _ -> assert false
end
| Var _ -> ()
| Prim _ -> ()
let activate_tracing self origin = function
| Tn tn ->
let idx = get_idx self origin in
let active = tn.active in
if idx >= active then
tn.active <- active + 1;
if idx > active then (
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
)
| _ -> ()
(* [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 ->
function
| Root _ -> assert false
| Pure x -> x
| Impure t as self ->
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)
| Bind x ->
let old_intermediate = x.intermediate in
let intermediate =
(* We haven't touched any state yet,
it is safe for [x.map] or [sub_sample] to raise *)
x.map (sub_sample self x.child)
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' ->
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;
activate_tracing self origin t.trace;
value
type 'a root = 'a t
(* TODO: use of Root after release is not detected and will break invariant *)
let observe ?(on_invalidate=ignore) child =
let root = Root {
child = Some child;
value = None;
on_invalidate;
trace_idx = I0
} in
sub_acquire root child;
root
let sample = function
| Pure _ | Impure _ -> assert false
| Root t as self ->
match t.value with
| Some value -> value
| None ->
match t.child with
| None -> invalid_arg "sample: root has been released"
| Some child ->
let value = sub_sample self child in
t.value <- Some value;
value
let is_damaged = function
| Pure _ | Impure _ -> assert false
| Root { value = None ; _ } -> true
| Root { value = Some _ ; _ } -> false
let is_released = function
| Pure _ | Impure _ -> assert false
| Root { child = None ; _ } -> true
| Root { child = Some _ ; _ } -> false
let release = function
| Pure _ | Impure _ -> assert false
| Root t as self ->
match t.child with
| None -> ()
| Some child ->
t.value <- None;
t.child <- None;
match sub_release [] self child with
| [] -> ()
| failures -> raise (Release_failure failures)
let set_on_invalidate x f =
match x with
| Pure _ | Impure _ -> assert false
| Root t -> t.on_invalidate <- f
module Infix = struct
let (let$) = bind
let (and$) = pair
let ($=) = set
end

40
lib/lwd/lwd.mli

@ -0,0 +1,40 @@
type 'a t
val return : 'a -> 'a t
val pure : 'a -> 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val map' : 'a t -> ('a -> 'b) -> 'b t
val map2' : 'a t -> 'b t -> ('a -> 'b -> 'c) -> 'c t
val join : 'a t t -> 'a t
val bind : 'a t -> ('a -> 'b t) -> 'b t
val app : ('a -> 'b) t -> 'a t -> 'b t
val pair : 'a t -> 'b t -> ('a * 'b) t
type 'a var
val var : 'a -> 'a var
val get : 'a var -> 'a t
val set : 'a var -> 'a -> unit
val peek : 'a var -> 'a
type 'a prim
val prim : acquire:(unit -> 'a) -> release:('a -> unit) -> 'a prim
val get_prim : 'a prim -> 'a t
val invalidate : 'a prim -> unit
type release_failure = exn * Printexc.raw_backtrace
exception Release_failure of release_failure list
type 'a root
val observe : ?on_invalidate:('a -> unit) -> 'a t -> 'a root
val set_on_invalidate : 'a root -> ('a -> unit) -> unit
val sample : 'a root -> 'a
val is_damaged : 'a root -> bool
val is_released : 'a root -> bool
val release : 'a root -> unit
module Infix : sig
val (let$) : 'a t -> ('a -> 'b t) -> 'b t
val (and$) : 'a t -> 'b t -> ('a * 'b) t
val ($=) : 'a var -> 'a -> unit
end

0
lib/lwd/lwd.opam

522
lib/lwd/lwd_table.ml

@ -0,0 +1,522 @@
type 'a binding =
| Bound of { value : 'a ; mutable valid : bool }
| Unbound
type 'a tree =
| Leaf
| Node of {
mutable version : int;
mutable left : 'a tree;
mutable binding : 'a binding;
mutable right : 'a tree;
mutable parent : 'a tree;
mutable size : int;
}
| Root of {
mutable version : int;
mutable child : 'a tree;
mutable generation : unit ref;
mutable on_invalidate : Obj.t Lwd.prim list;
}
type 'a t = 'a tree
type 'a row = 'a tree
let not_origin = ref ()
let origin = ref ()
let make () =
Root { child = Leaf; generation = origin; version = 0; on_invalidate = [] }
let set_parent ~parent = function
| Root _ -> assert false
| Node n -> n.parent <- parent
| Leaf -> ()
let reparent ~parent ~oldchild ~newchild =
match parent with
| Root r ->
assert (r.child == oldchild);
r.child <- newchild
| Node n when n.left == oldchild ->
n.left <- newchild
| Node n when n.right == oldchild ->
n.right <- newchild
| Leaf | Node _ -> assert false
let make_node ?set ~left ~right ~parent =
let binding = match set with
| None -> Unbound
| Some value -> Bound { value ; valid = true }
in
let node = Node { left; right; parent; version = 0; size = 0; binding } in
set_parent left ~parent:node;
set_parent right ~parent:node;
node
let rec raw_invalidate = function
| Node { size = 0; _ } -> ()
| Node t ->
t.size <- 0;
raw_invalidate t.parent
| Root r ->
List.iter Lwd.invalidate r.on_invalidate
| Leaf -> assert false
let prepend ?set = function
| Root r as parent ->
raw_invalidate parent;
let node = make_node ?set ~left:Leaf ~right:r.child ~parent in
r.child <- node;
node
| Leaf | Node _ -> assert false
let prepend' x set = ignore (prepend x ~set)
let append ?set = function
| Root r as parent ->
raw_invalidate parent;
let node = make_node ?set ~left:r.child ~right:Leaf ~parent in
r.child <- node;
node
| Leaf | Node _ -> assert false
let append' x set = ignore (append x ~set)
let before ?set = function
| Node { parent = Leaf ; _ } | Leaf -> Leaf
| Node n as parent ->
raw_invalidate parent;
let node = make_node ?set ~left:Leaf ~right:n.left ~parent in
n.left <- node;
node
| Root _ -> assert false
let after ?set = function
| Node { parent = Leaf ; _ } | Leaf -> Leaf
| Node n as parent ->
raw_invalidate parent;
let node = make_node ?set ~left:n.right ~right:Leaf ~parent in
n.right <- node;
node
| Root _ -> assert false
let get = function
| Node { binding = Bound { value ; _ } ; _ } -> Some value
| Leaf | Root _ | Node { binding = Unbound ; _ } -> None
let invalidate_binding = function
| Unbound -> ()
| Bound b -> b.valid <- false
let set_binding x = function
| Root _ -> assert false
| Leaf | Node { parent = Leaf; _ } -> ()
| Node n as t ->
raw_invalidate t;
invalidate_binding n.binding;
n.binding <- x
let set t value = set_binding (Bound { value; valid = true }) t
let unset t = set_binding Unbound t
let is_bound = function
| Leaf | Node { parent = Leaf; _ } -> false
| Root _ | Node _ -> true
let rec join left = function
| Root _ | Leaf -> assert false
| Node ({ left = Leaf; _ } as n) as self ->
n.left <- left;
set_parent left ~parent:self;
raw_invalidate self
| Node node ->
join left node.left
let join left = function
| Leaf -> left
| right -> join left right; right
let remove = function
| Root _ | Leaf | Node {parent = Leaf; _} -> ()
| Node ({left; right; parent; _} as n) as t ->
invalidate_binding n.binding;
n.left <- Leaf;
n.right <- Leaf;
n.parent <- Leaf;
n.binding <- Unbound;
n.version <- max_int;
raw_invalidate parent;
let join = join left right in
reparent ~parent ~oldchild:t ~newchild:join;
set_parent join ~parent
let rec clear = function
| Leaf -> ()
| Node ({left; right; _} as n) ->
invalidate_binding n.binding;
n.left <- Leaf;
n.right <- Leaf;
n.parent <- Leaf;
n.binding <- Unbound;
n.version <- max_int;
clear left;
clear right
| Root r as root ->
let child = r.child in
r.child <- Leaf;
clear child;
raw_invalidate root
(* Tree balancing *)
let size = function
| Node node ->
assert (node.size <> 0);
node.size
| Leaf -> 0
| Root _ -> assert false
(** [smaller_ell smin smax] iff
- [smin] is less than [smax]
- [smin] and [smax] differs by less than two magnitude orders, i.e
msbs(smin) >= msbs(smax) - 1
where msbs is the index of the most significant bit set *)
let smaller_ell smin smax = (smin < smax) && ((smin land smax) lsl 1 < smax)
(** [disbalanced smin smax] check if two sub-trees of size [smin] and [smax],
are disbalanczed. That is, msbs(smin) < msbs(smax) - 1 *)
let disbalanced smin smax = smaller_ell smin (smax lsr 1)
let reparent ~parent ~oldchild ~newchild =
match parent with
| Root r ->
assert (r.child == oldchild);
r.child <- newchild;
| Node n when n.left == oldchild ->
n.left <- newchild
| Node n when n.right == oldchild ->
n.right <- newchild
| Leaf | Node _ -> assert false
let rec rot_left version = function
| Node ({ right = (Node rn) as r; _} as sn) as s ->
let parent = sn.parent in
let rl = match rn.left with
| Root _ -> assert false
| Leaf -> Leaf
| (Node rln) as rl ->
rln.parent <- s;
rl
in
rn.left <- s;
sn.right <- rl;
sn.parent <- r;
rn.parent <- parent;
reparent ~parent ~oldchild:s ~newchild:r;
ignore (balance version s);
balance version r
| _ -> assert false
and rot_right version = function
| Node ({ left = (Node ln) as l; _} as sn) as s ->
let parent = sn.parent in
let lr = match ln.right with
| Root _ -> assert false
| Leaf -> Leaf
| (Node lrn) as lr ->
lrn.parent <- s;
lr
in
ln.right <- s;
sn.left <- lr;
sn.parent <- l;
ln.parent <- parent;
reparent ~parent ~oldchild:s ~newchild:l;
ignore (balance version s);
balance version l
| _ -> assert false
and inc_left version = function
| Root _ | Leaf -> assert false
| Node {right; _} as self ->
begin match right with
| Node rn when smaller_ell (size rn.right) (size rn.left) ->
ignore (rot_right version right)
| _ -> ()
end;
rot_left version self
and inc_right version = function
| Root _ | Leaf -> assert false
| Node {left; _} as self ->
begin match left with
| Node ln when smaller_ell (size ln.left) (size ln.right) ->
ignore (rot_left version left)
| _ -> ()
end;
rot_right version self
and balance version = function
| Root _ | Leaf -> assert false
| Node node as self ->
let sl = size node.left and sr = size node.right in
if sl < sr then (
if disbalanced sl sr
then inc_left version self
else (node.version <- version; node.size <- 1 + sl + sr; self)
) else (
if disbalanced sr sl
then inc_right version self
else (node.version <- version; node.size <- 1 + sl + sr; self)
)
let rec _compute_sub_size1 version = function
| Root _ -> ()
| Leaf -> ()
| Node node as self ->
if node.size = 0 then begin
_compute_sub_size1 version node.left;
_compute_sub_size1 version node.right;
ignore (balance version self)
end
let compute_sub_size = _compute_sub_size1
let rec reset_version version = function
| Leaf -> ()
| Node n ->
n.version <- version;
reset_version version n.left;
reset_version version n.right
| Root _ -> assert false
let rebalance = function
| Root r ->
begin match r.child with
| Node { size = 0; _ } ->
let version = succ r.version in
let version =
if version = max_int then (
r.generation <- ref ();
reset_version 0 r.child;
0
)
else version
in
r.version <- version;
compute_sub_size version r.child;
version
| Node _ | Leaf -> r.version
| Root _ -> assert false
end
| _ -> assert false
let plus (zero, plus) x y =
if x == zero then y
else if y == zero then x
else plus x y
type ('a, 'b) reduction_tree =
| Red_leaf
| Red_node of {
cell: 'a row;
binding: 'a binding;
reduction: 'b;
aggregate: 'b;
left : ('a, 'b) reduction_tree;
right : ('a, 'b) reduction_tree;
}
type ('a, 'b) reduction = {
mutable version: int;
source: 'a tree;
mutable result : ('a, 'b) reduction_tree;
mutable generation: unit ref;
mapper: 'a row -> 'a -> 'b;
monoid: 'b Lwd_utils.monoid;
primitive : ('a, 'b) reduction Lwd.prim lazy_t;
}
let extract_bindings tree =
let rec aux acc = function
| Red_leaf -> acc
| Red_node rnode ->
let acc = aux acc rnode.right in
let acc = match rnode.binding with
| Unbound -> acc
| Bound { valid = false; _ } -> acc
| _ -> (rnode.binding, rnode.reduction) :: acc
in
aux acc rnode.left
in
aux [] tree
let full_rebuild red tree =
let bindings = ref (extract_bindings red.result) in
let rec aux = function
| Node node as cell ->
let left = aux node.left in
let reduction =
match node.binding, !bindings with
| Unbound, _ -> fst red.monoid
| binding, ((binding', reduction) :: bindings')
when binding == binding' ->
bindings := bindings';
reduction
| Bound b, _ -> assert b.valid; red.mapper cell b.value
in
let right = aux node.right in
let aggregate = match left with
| Red_leaf -> reduction
| Red_node r -> plus red.monoid r.aggregate reduction
in
let aggregate = match right with
| Red_leaf -> aggregate
| Red_node r -> plus red.monoid aggregate r.aggregate
in
Red_node {
cell;
binding = node.binding;
reduction;
aggregate;
left;
right;
}
| Leaf -> Red_leaf
| Root _ -> assert false
in
let result = aux tree in
assert (!bindings = []);
result
let extract_fringe version tree =
let rec aux acc = function
| Red_leaf -> acc
| Red_node rnode as tree ->
match rnode.cell with
| Node node when node.version <= version -> tree :: acc
| _ ->
let acc = aux acc rnode.right in
let acc = match rnode.binding with
| Unbound -> acc
| Bound { valid = false; _ } -> acc
| _ -> tree :: acc
in
aux acc rnode.left
in
aux [] tree
let incremental_rebuild red version tree =
let fringe = ref (extract_fringe version red.result) in
let rec aux = function
| Node node as cell when node.version <= version ->
begin match !fringe with
| (Red_node rnode as reduction) :: fringe' ->
assert (rnode.cell == cell);
fringe := fringe';
reduction
| _ -> assert false
end
| Node node as cell ->
let left = aux node.left in
let reduction =
match node.binding, !fringe with
| Unbound, _ -> fst red.monoid
| binding, (Red_node rnode :: fringe')
when binding == rnode.binding ->
fringe := fringe';
rnode.reduction
| Bound b, _ ->
assert b.valid; red.mapper cell b.value
in
let right = aux node.right in
let aggregate = match left with
| Red_leaf -> reduction
| Red_node r -> plus red.monoid r.aggregate reduction
in
let aggregate = match right with
| Red_leaf -> aggregate
| Red_node r -> plus red.monoid aggregate r.aggregate
in
Red_node {
cell;
binding = node.binding;
reduction;
aggregate;
left;
right;
}
| Root _ | Leaf -> Red_leaf
in
let result = aux tree in
assert (!fringe = []);
result
let eval red =
match red.source with
| Leaf | Node _ -> assert false
| Root root ->
let version = rebalance red.source in
if true then (
if red.generation != root.generation then (
red.generation <- root.generation;
red.result <- full_rebuild red root.child;
) else (
red.result <- incremental_rebuild red red.version root.child
);
) else (
red.result <- full_rebuild red root.child;
);
red.version <- version;
match red.result with
| Red_leaf -> fst red.monoid
| Red_node r -> r.aggregate
let opaque : 'a Lwd.prim -> Obj.t Lwd.prim = Obj.magic
let map_reduce mapper monoid source =
let rec reduction = {
source; mapper; monoid;
result = Red_leaf;
generation = not_origin;
version = 0;
primitive = lazy begin Lwd.prim
~acquire:(fun () ->
let lazy node = reduction.primitive in
match reduction.source with
| Leaf | Node _ -> assert false
| Root root ->
root.on_invalidate <- opaque node :: root.on_invalidate;
reduction
)
~release:(fun reduction ->
let lazy node = reduction.primitive in
match reduction.source with
| Leaf | Node _ -> assert false
| Root root ->
root.on_invalidate <-
List.filter ((!=) (opaque node)) root.on_invalidate
)
end
} in
Lwd.map eval (Lwd.get_prim (Lazy.force reduction.primitive))
let reduce monoid source = map_reduce (fun _ x -> x) monoid source
let rec iter f = function
| Leaf -> ()
| Node t ->
iter f t.left;
begin match t.binding with
| Bound x -> f x.value
| Unbound -> ()
end;
iter f t.right
| Root t ->
iter f t.child
module Infix = struct
let ($<-) = set
end

28
lib/lwd/lwd_table.mli

@ -0,0 +1,28 @@
type 'a t
type 'a row
val make : unit -> 'a t
val clear : 'a t -> unit
val prepend : ?set:'a -> 'a t -> 'a row
val append : ?set:'a -> 'a t -> 'a row
val prepend' : 'a t -> 'a -> unit
val append' : 'a t -> 'a -> unit
val before : ?set:'a -> 'a row -> 'a row
val after : ?set:'a -> 'a row -> 'a row
val get : 'a row -> 'a option
val set : 'a row -> 'a -> unit
val unset : 'a row -> unit
val is_bound : 'a row -> bool
val remove : 'a row -> unit
val reduce : 'a Lwd_utils.monoid -> 'a t -> 'a Lwd.t
val map_reduce : ('a row -> 'a -> 'b) -> 'b Lwd_utils.monoid -> 'a t -> 'b Lwd.t
val iter : ('a -> unit) -> 'a t -> unit
module Infix : sig
val ($<-) : 'a row -> 'a -> unit
end

474
lib/lwd/lwd_trace_debug.ml

@ -0,0 +1,474 @@
type 'a t =
| Pure of 'a
| Impure : {
mutable value : 'a option;
mutable trace : trace;
mutable trace_idx : trace_idx;
desc: 'a desc;
} -> 'a t
| Root : {
mutable on_invalidate : 'a -> unit;
mutable value : 'a option;
child : 'a t;
mutable trace_idx : trace_idx;
} -> '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
| Bind : { child : 'a t; map : 'a -> 'b t;
mutable intermediate : 'b t option } -> 'b desc
| Var : { mutable binding : 'a } -> 'a desc
| Prim : { acquire : unit -> 'a;
release : 'a -> unit;
mutable acquired : 'a option } -> 'a desc
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;
mutable entries : Obj.t t array } -> trace
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
let dummy = Pure (Obj.repr ())
let impure desc =
Impure { value = None; trace = T0; desc; trace_idx = I0 }
let map f x = impure (Map (x, f))
let map2 f x y = impure (Map2 (x, y, f))
let map' x f = impure (Map (x, f))
let map2' x y f = impure (Map2 (x, y, f))
let pair x y = impure (Pair (x, y))
let app f x = impure (App (f, x))
let bind child map = impure (Bind { child; map; intermediate = None })
let id x = x
let join child = impure (Bind { child; map = id; intermediate = None })
(* Management of trace indexes *)
external t_equal : _ t -> _ t -> bool = "%eq"
external obj_t : 'a t -> Obj.t t = "%identity"
let debug_trace_idx (type a) (self : a t) idx =
let rec gather = function
| I0 -> []
| I1 {obj = obj1; next = I1 {obj = obj2; _}; _}
when t_equal obj1 obj2 && (
let self = match self with
| Pure _ | Root _ -> assert false
| Impure t ->
match t.desc with
| Map (t1, _) ->
Printf.sprintf "Map (%x, _)" (Obj.magic t1)
| Map2 (t1, t2, _) ->
Printf.sprintf "Map2 (%x, %x, _)" (Obj.magic t1) (Obj.magic t2)
| Pair (t1, t2) ->
Printf.sprintf "Pair (%x, %x)" (Obj.magic t1) (Obj.magic t2)
| App (t1, t2) ->
Printf.sprintf "App (%x, %x)" (Obj.magic t1) (Obj.magic t2)
| Bind {child; intermediate = None; _} ->
Printf.sprintf "Bind (%x)" (Obj.magic child)
| Bind {child; intermediate = Some i; _} ->
Printf.sprintf "Bind (%x, %x)" (Obj.magic child) (Obj.magic i)
| Var _ -> "Var _"
| Prim _ -> "Prim _"
in
Printf.eprintf "%x: %s\n" (Obj.magic obj1) self;
false
) -> assert false
| I1 t ->
begin match t.obj with
| Impure {trace = Tn {active; count; entries}; _} ->
if not (t.idx < count) then (
prerr_endline
(Printexc.raw_backtrace_to_string (Printexc.get_callstack 10));
assert false
);
assert (entries.(t.idx) == obj_t self);
if t.idx > active then (
match self with
| Root { value = None; _ } | Impure { value = None; _} -> ()
| _ -> assert false
)
| Impure {trace = T0; _} -> () (* invariant temporary broken, can't do much *)
| _ ->
prerr_endline
(Printexc.raw_backtrace_to_string (Printexc.get_callstack 10));
assert false
end;
Printf.sprintf "%x@%d" (Obj.magic t.obj) t.idx :: gather t.next
in
Printf.eprintf "idx : [%s]\n" (String.concat "; " (gather idx));
idx
let debug_trace = function
| T0 -> Printf.eprintf "empty trace"
| Tn tn ->
Printf.eprintf "trace: {active = %d; count = %d; capacity = %d}\n"
tn.active tn.count (Array.length tn.entries)
let add_idx obj idx = function
| Pure _ -> assert false
| Root t' as self->
t'.trace_idx <- debug_trace_idx self (I1 { idx; obj; next = t'.trace_idx })
| Impure t' as self->
t'.trace_idx <- debug_trace_idx self (I1 { idx; obj; next = t'.trace_idx })
let rec rem_idx 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
t.next <- result;
(idx, self)
let rem_idx obj = function
| Pure _ -> assert false
| Root t' as self ->
let idx, trace_idx = rem_idx obj t'.trace_idx in
t'.trace_idx <- debug_trace_idx self trace_idx; idx
| Impure t' as self ->
let idx, trace_idx = rem_idx obj t'.trace_idx in
t'.trace_idx <- debug_trace_idx self trace_idx; idx
let rec mov_idx 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
let mov_idx obj oldidx newidx = function
| Pure _ -> assert false
| Root t' -> mov_idx obj oldidx newidx t'.trace_idx
| Impure t' -> mov_idx obj oldidx newidx t'.trace_idx
let rec get_idx obj = function
| I0 -> assert false
| I1 t ->
if t_equal t.obj obj
then t.idx
else get_idx obj t.next
let get_idx obj = function
| Pure _ -> assert false
| Root t' as self -> get_idx obj (debug_trace_idx self t'.trace_idx)
| Impure t' as self -> get_idx obj (debug_trace_idx self t'.trace_idx)
(* Propagating invalidation *)
let rec invalidate_node : type a . a t -> unit = function
| Pure _ -> assert false
| Root { value = None; _ } -> ()
| Root ({ value = Some x; _ } as t) ->
t.value <- None;
t.on_invalidate x
| Impure t ->
begin match t.value with
| None -> ()
| Some _ ->
t.value <- None;
debug_trace t.trace;
invalidate_trace t.trace
end
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
let var x = impure (Var {binding = x})
let get x = x
let set vx x =
match vx with
| Impure ({desc = Var v; _}) ->
invalidate_node vx;
v.binding <- x
| _ -> assert false
let peek = function
| Impure ({desc = Var v; _}) -> v.binding
| _ -> assert false
(* Primitives *)
type 'a prim = 'a t
let prim ~acquire ~release =
impure (Prim { acquire; release; acquired = None })
let get_prim x = x
let invalidate = invalidate_node
let rec sub_release : type a b . a t -> b t -> unit = fun origin ->
function
| Root _ -> assert false
| Pure _ -> ()