finer-grained distinction between pure and impure nodes to optimize graph

This commit is contained in:
Frédéric Bour 2020-01-08 11:24:53 +01:00
parent af73521473
commit 6f05c93463
2 changed files with 60 additions and 36 deletions

View File

@ -1,6 +1,7 @@
type 'a t =
| Pure of 'a
| Impure : {
| Impure of 'a
| Operator : {
mutable value : 'a option;
mutable trace : trace;
mutable trace_idx : trace_idx;
@ -43,18 +44,39 @@ and trace_idx =
let return x = Pure x
let pure x = Pure x
let impure = function
| Pure x -> Impure x
| other -> other
let dummy = Pure (Obj.repr ())
let impure desc =
Impure { value = None; trace = T0; desc; trace_idx = I0 }
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 })
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 join child = impure (Join { child; intermediate = None })
let bind x f = join (map f x)
(* Management of trace indices *)
@ -63,9 +85,9 @@ 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
| Pure _ | Impure _ -> 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 }
| Operator t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
let rec rem_idx obj = function
| I0 -> assert false
@ -78,11 +100,11 @@ let rec rem_idx obj = function
(idx, self)
let rem_idx obj = function
| Pure _ -> assert false
| Pure _ | Impure _ -> assert false
| Root t' ->
let idx, trace_idx = rem_idx obj t'.trace_idx in
t'.trace_idx <- trace_idx; idx
| Impure t' ->
| Operator t' ->
let idx, trace_idx = rem_idx obj t'.trace_idx in
t'.trace_idx <- trace_idx; idx
@ -94,9 +116,9 @@ let rec mov_idx obj oldidx newidx = function
else mov_idx obj oldidx newidx t.next
let mov_idx obj oldidx newidx = function
| Pure _ -> assert false
| Pure _ | Impure _ -> assert false
| Root t' -> mov_idx obj oldidx newidx t'.trace_idx
| Impure t' -> mov_idx obj oldidx newidx t'.trace_idx
| Operator t' -> mov_idx obj oldidx newidx t'.trace_idx
let rec get_idx obj = function
| I0 -> assert false
@ -106,18 +128,18 @@ let rec get_idx obj = function
else get_idx obj t.next
let get_idx obj = function
| Pure _ -> assert false
| Pure _ | Impure _ -> assert false
| Root t' -> get_idx obj t'.trace_idx
| Impure t' -> get_idx obj t'.trace_idx
| Operator t' -> get_idx obj t'.trace_idx
(* Propagating invalidation *)
let rec invalidate_node : type a . a t -> unit = function
| Pure _ -> assert false
| Pure _ | Impure _ -> assert false
| Root { value = None; _ } -> ()
| Root ({ value = Some x; _ } as t) ->
t.value <- None;
t.on_invalidate x
| Impure t ->
| Operator t ->
begin match t.value with
| None -> ()
| Some _ ->
@ -149,28 +171,28 @@ and invalidate_trace = function
(* Variables *)
type 'a var = 'a t
let var x = impure (Var {binding = x})
let var x = operator (Var {binding = x})
let get x = x
let set vx x =
match vx with
| Impure ({desc = Var v; _}) ->
| Operator ({desc = Var v; _}) ->
invalidate_node vx;
v.binding <- x
| _ -> assert false
let peek = function
| Impure ({desc = Var v; _}) -> v.binding
| Operator ({desc = Var v; _}) -> v.binding
| _ -> assert false
(* Primitives *)
type 'a prim = 'a t
let prim ~acquire ~release =
impure (Prim { acquire; release })
operator (Prim { acquire; release })
let get_prim x = x
let invalidate = function
| Impure ({ desc = Prim p; _ } as t) ->
| Operator ({ desc = Prim p; _ } as t) ->
let value = t.value in
t.value <- None;
invalidate_trace t.trace;
@ -189,8 +211,8 @@ 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 ->
| Pure _ | Impure _ -> failures
| Operator t as self ->
let trace = match t.trace with
| T0 -> assert false
| T1 x -> assert (t_equal x origin); T0
@ -276,8 +298,8 @@ let rec sub_release
let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
function
| Root _ -> assert false
| Pure _ -> ()
| Impure t as self ->
| Pure _ | Impure _ -> ()
| Operator t as self ->
let acquire = match t.trace with T0 -> true | _ -> false in
let trace = match t.trace with
| T0 -> T1 origin
@ -351,8 +373,8 @@ let activate_tracing self origin = function
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 ->
| Pure x | Impure x -> x
| Operator t as self ->
match t.value with
| Some value -> value
| None ->
@ -403,7 +425,7 @@ let observe ?(on_invalidate=ignore) child =
root
let sample = function
| Pure _ | Impure _ -> assert false
| Pure _ | Impure _ | Operator _ -> assert false
| Root t as self ->
match t.value with
| Some value -> value
@ -417,12 +439,12 @@ let sample = function
value
let is_damaged = function
| Pure _ | Impure _ -> assert false
| Pure _ | Impure _ | Operator _ -> assert false
| Root { value = None ; _ } -> true
| Root { value = Some _ ; _ } -> false
let release = function
| Pure _ | Impure _ -> assert false
| Pure _ | Impure _ | Operator _ -> assert false
| Root t as self ->
if t.acquired then (
t.value <- None;
@ -434,12 +456,12 @@ let release = function
let set_on_invalidate x f =
match x with
| Pure _ | Impure _ -> assert false
| Pure _ | Impure _ | Operator _ -> assert false
| Root t -> t.on_invalidate <- f
(*let unsafe_peek = function
| Pure x -> Some x
| Impure t -> t.value
| Operator t -> t.value
| Root t -> t.value*)
module Infix = struct

View File

@ -10,6 +10,8 @@ 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
val impure : 'a t -> 'a t
type 'a var
val var : 'a -> 'a var
val get : 'a var -> 'a t