Commit a8ba6ab6 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Implement a cache for the positive equation solver (partial results are stored in nodes)

parent 083edd02
......@@ -41,7 +41,7 @@ let balance ( Unbalanced('a) -> Rtree('a) ; 'b & RBtree('a) -> 'b & RBtree('a) )
| x -> x
;;
let [] = []
(* *)
(* Version 2: restrict the first branch to Unbalanced trees whatever *)
(* type it contains *)
......@@ -182,8 +182,8 @@ let cardinal ( RBtree('a) -> Int ) (* better type: [] -> 0, Any\[] -> [1--*] *
raise "impossible"
| <(c) elem=e>[ l r ] ->
(<black elem=e>[ l (balance (redify r)) ], (c = `black))
(*
let remove(x : 'a)(t : RBtree('a) ) : RBtree('a) =
let remove_aux(RBtree('a) -> (RBtree('a),Bool) )
| [] ->
......@@ -206,4 +206,5 @@ let remove(x : 'a)(t : RBtree('a) ) : RBtree('a) =
let tree = <(c) elem=z>[ ll r] in
if d then bubble_left tree else (tree, `false)
in
let (sol,_) = remove_aux t in sol
\ No newline at end of file
let (sol,_) = remove_aux t in sol
*)
......@@ -64,6 +64,7 @@ sig
val mapi: (Elem.t -> 'a -> 'b) -> 'a map -> 'b map
val constant: 'a -> t -> 'a map
val num: int -> t -> int map
val init : (Elem.t -> 'a) -> t -> 'a map
val map_to_list: ('a -> 'b) -> 'a map -> 'b list
val mapi_to_list: (Elem.t -> 'a -> 'b) -> 'a map -> 'b list
val assoc: Elem.t -> 'a map -> 'a
......@@ -97,9 +98,9 @@ module Make(X : Custom.T) = struct
let hash l = hash 1 l
let rec compare l1 l2 =
if l1 == l2 then 0
if l1 == l2 then 0
else match (l1,l2) with
| x1::l1, x2::l2 ->
| x1::l1, x2::l2 ->
let c = Elem.compare x1 x2 in if c <> 0 then c
else compare l1 l2
| [],_ -> -1
......@@ -115,7 +116,7 @@ module Make(X : Custom.T) = struct
external get: t -> Elem.t list = "%identity"
let singleton x = [ x ]
let pick = function x::_ -> Some x | _ -> None
let pick = function x::_ -> Some x | _ -> None
let choose = function x::_ -> x | _ -> raise Not_found
let length = List.length
......@@ -125,13 +126,13 @@ module Make(X : Custom.T) = struct
let rec disjoint l1 l2 =
if l1 == l2 then l1 == [] else
match (l1,l2) with
| (t1::q1, t2::q2) ->
| (t1::q1, t2::q2) ->
let c = Elem.compare t1 t2 in
if c < 0 then disjoint q1 l2
else if c > 0 then disjoint l1 q2
else false
| _ -> true
let rec cup l1 l2 =
if l1 == l2 then l1 else
match (l1,l2) with
......@@ -144,7 +145,7 @@ module Make(X : Custom.T) = struct
| (l1,[]) -> l1
let add x l = cup [x] l
let rec split l1 l2 =
match (l1,l2) with
| (t1::q1, t2::q2) ->
......@@ -153,8 +154,8 @@ module Make(X : Custom.T) = struct
else if c < 0 then let (l1,i,l2) = split q1 l2 in (t1::l1,i,l2)
else let (l1,i,l2) = split l1 q2 in (l1,i,t2::l2)
| _ -> (l1,[],l2)
let rec diff l1 l2 =
if l1 == l2 then [] else
match (l1,l2) with
......@@ -177,7 +178,7 @@ module Make(X : Custom.T) = struct
else cap l1 q2
| _ -> []
let rec subset l1 l2 =
(l1 == l2) ||
match (l1,l2) with
......@@ -196,8 +197,8 @@ module Make(X : Custom.T) = struct
else if c < 0 then false
else subset l1 q2
| [],_ -> true | _ -> false
let from_list l =
let from_list l =
let rec initlist = function
| [] -> []
| e::rest -> [e] :: initlist rest in
......@@ -209,14 +210,14 @@ module Make(X : Custom.T) = struct
| [l] -> l
| llist -> mergeall (merge2 llist) in
mergeall (initlist l)
let map f l =
from_list (List.map f l)
let rec mem l x =
match l with
| [] -> false
| t::q ->
| t::q ->
let c = Elem.compare x t in
(c = 0) || ((c > 0) && (mem q x))
......@@ -247,7 +248,7 @@ module Make(X : Custom.T) = struct
let rec assoc_remove_aux v r = function
| ((x,y) as a)::l ->
let c = Elem.compare x v in
if c = 0 then (r := Some y; l)
if c = 0 then (r := Some y; l)
else if c < 0 then a :: (assoc_remove_aux v r l)
else raise Not_found
| [] -> raise Not_found
......@@ -323,7 +324,7 @@ module Make(X : Custom.T) = struct
let rec mem x l =
match l with
| [] -> false
| (t,_)::q ->
| (t,_)::q ->
let c = Elem.compare x t in
(c = 0) || ((c > 0) && (mem x q))
......@@ -345,7 +346,7 @@ module Make(X : Custom.T) = struct
else restrict l1 q2
| _ -> []
let from_list f l =
let from_list f l =
let rec initlist = function
| [] -> []
| e::rest -> [e] :: initlist rest in
......@@ -358,7 +359,7 @@ module Make(X : Custom.T) = struct
| llist -> mergeall (merge2 llist) in
mergeall (initlist l)
let from_list_disj l =
let from_list_disj l =
let rec initlist = function
| [] -> []
| e::rest -> [e] :: initlist rest in
......@@ -374,7 +375,7 @@ module Make(X : Custom.T) = struct
let rec map_from_slist f = function
| x::l -> (x,f x)::(map_from_slist f l)
| [] -> []
let rec collide f l1 l2 =
match (l1,l2) with
| (_,y1)::l1, (_,y2)::l2 -> f y1 y2; collide f l1 l2
......@@ -410,10 +411,14 @@ module Make(X : Custom.T) = struct
| (x,y)::l -> (f y)::(map_to_list f l)
| [] -> []
let rec init f = function
[] -> []
| x :: l -> (x, f x) :: (init f l)
let rec assoc v = function
| (x,y)::l ->
let c = Elem.compare x v in
if c = 0 then y
if c = 0 then y
else if c < 0 then assoc v l
else raise Not_found
| [] -> raise Not_found
......@@ -426,7 +431,7 @@ module Make(X : Custom.T) = struct
| [] -> assert false
let rec compare f l1 l2 =
if l1 == l2 then 0
if l1 == l2 then 0
else match (l1,l2) with
| (x1,y1)::l1, (x2,y2)::l2 ->
let c = Elem.compare x1 x2 in if c <> 0 then c
......@@ -448,13 +453,13 @@ module Make(X : Custom.T) = struct
let rec check f = function
| (x,a)::((y,b)::_ as tl) ->
| (x,a)::((y,b)::_ as tl) ->
Elem.check x; f a;
assert (Elem.compare x y < 0); check f tl
| [x,a] -> Elem.check x; f a
| _ -> ()
end (* Map *)
end (* Map *)
module MakeMap(Y : Custom.T) = struct
......@@ -464,10 +469,10 @@ module Make(X : Custom.T) = struct
in types.ml... *)
let hash x = Map.hash Y.hash x
let compare x y = Map.compare Y.compare x y
let equal x y = Map.equal Y.equal x y
let equal x y = Map.equal Y.equal x y
let check l = Map.check Y.check l
let dump ppf l =
let dump ppf l =
List.iter (fun (x,y) ->
Format.fprintf ppf "(%a->%a)" Elem.dump x Y.dump y) l
......@@ -507,7 +512,7 @@ module FiniteCofinite(X : Custom.T) = struct
let compare l1 l2 =
match (l1,l2) with
| Finite l1, Finite l2
| Finite l1, Finite l2
| Cofinite l1, Cofinite l2 -> SList.compare l1 l2
| Finite _, Cofinite _ -> -1
| _ -> 1
......@@ -555,11 +560,11 @@ module FiniteCofinite(X : Custom.T) = struct
let neg = function
| Finite s -> Cofinite s
| Cofinite s -> Finite s
let contains x = function
| Finite s -> SList.mem s x
| Cofinite s -> not (SList.mem s x)
let disjoint s t =
match (s,t) with
| (Finite s, Finite t) -> SList.disjoint s t
......@@ -581,79 +586,79 @@ struct
let sample = function
| Cofinite _ -> None
| Finite l -> (match T.get l with
| Finite l -> (match T.get l with
| [] -> raise Not_found
| (x,y)::_ -> Some (x, SymbolSet.sample y))
let get = function
| Finite l -> `Finite (T.get l)
| Cofinite l -> `Cofinite (T.get l)
let check = function
| Finite l | Cofinite l -> TMap.check l
let dump ppf = function
| Finite s -> Format.fprintf ppf "Finite[%a]" TMap.dump s
| Cofinite s -> Format.fprintf ppf "Cofinite[%a]" TMap.dump s
let empty = Finite T.empty
let any = Cofinite T.empty
let any_in_ns ns = Finite (T.singleton ns SymbolSet.any)
let finite l =
let l =
T.filter
let l =
T.filter
(fun _ x -> match x with SymbolSet.Finite [] -> false | _ -> true)
l in
Finite l
let cofinite l =
let l =
T.filter
let l =
T.filter
(fun _ x -> match x with SymbolSet.Finite [] -> false | _ -> true)
l in
Cofinite l
let atom (ns,x) = Finite (T.singleton ns (SymbolSet.atom x))
let cup s t =
match (s,t) with
| (Finite s, Finite t) -> finite (T.merge SymbolSet.cup s t)
| (Finite s, Cofinite t) -> cofinite (T.sub SymbolSet.diff t s)
| (Cofinite s, Finite t) -> cofinite (T.sub SymbolSet.diff s t)
| (Cofinite s, Cofinite t) -> cofinite (T.cap SymbolSet.cap s t)
let cap s t =
match (s,t) with
| (Finite s, Finite t) -> finite (T.cap SymbolSet.cap s t)
| (Finite s, Cofinite t) -> finite (T.sub SymbolSet.diff s t)
| (Cofinite s, Finite t) -> finite (T.sub SymbolSet.diff t s)
| (Cofinite s, Cofinite t) -> cofinite (T.merge SymbolSet.cup s t)
let diff s t =
match (s,t) with
| (Finite s, Cofinite t) -> finite (T.cap SymbolSet.cap s t)
| (Finite s, Finite t) -> finite (T.sub SymbolSet.diff s t)
| (Cofinite s, Cofinite t) -> finite (T.sub SymbolSet.diff t s)
| (Cofinite s, Finite t) -> cofinite (T.merge SymbolSet.cup s t)
let is_empty = function
| Finite l -> T.is_empty l
| _ -> false
| _ -> false
let hash = function
| Finite l -> 1 + 17 * (TMap.hash l)
| Cofinite l -> 2 + 17 * (TMap.hash l)
let compare l1 l2 =
match (l1,l2) with
| Finite l1, Finite l2
| Finite l1, Finite l2
| Cofinite l1, Cofinite l2 -> TMap.compare l1 l2
| Finite _, Cofinite _ -> -1
| _ -> 1
let equal t1 t2 =
let equal t1 t2 =
compare t1 t2 = 0
let symbol_set ns = function
......@@ -663,12 +668,12 @@ struct
(try SymbolSet.neg (T.assoc ns s) with Not_found -> SymbolSet.any)
let contains (ns,x) = function
| Finite s ->
| Finite s ->
(try SymbolSet.contains x (T.assoc ns s) with Not_found -> false)
| Cofinite s ->
| Cofinite s ->
(try not (SymbolSet.contains x (T.assoc ns s)) with Not_found -> true)
let disjoint s t =
let disjoint s t =
is_empty (cap t s) (* TODO: OPT *)
end
......@@ -64,6 +64,7 @@ sig
val mapi: (Elem.t -> 'a -> 'b) -> 'a map -> 'b map
val constant: 'a -> t -> 'a map
val num: int -> t -> int map
val init : (Elem.t -> 'a) -> t -> 'a map
val map_to_list: ('a -> 'b) -> 'a map -> 'b list
val mapi_to_list: (Elem.t -> 'a -> 'b) -> 'a map -> 'b list
val assoc: Elem.t -> 'a map -> 'a
......@@ -103,7 +104,7 @@ module FiniteCofinite(X : Custom.T) : FiniteCofinite with type elem = X.t
module FiniteCofiniteMap(X : Custom.T)(SymbolSet : FiniteCofinite) :
sig
include Custom.T
val empty: t
val any: t
val any_in_ns: X.t -> t
......@@ -117,7 +118,7 @@ sig
val contains: X.t * SymbolSet.elem -> t -> bool
val disjoint: t -> t -> bool
val get: t -> [ `Finite of (X.t * SymbolSet.t) list
val get: t -> [ `Finite of (X.t * SymbolSet.t) list
| `Cofinite of (X.t * SymbolSet.t) list ]
val sample: t -> (X.t * SymbolSet.elem option) option
......
......@@ -2636,7 +2636,8 @@ module Positive = struct
|`Xml of v * v
|`Record of bool * (bool * Ns.Label.t * v) list
]
and v = { mutable def : rhs; mutable node : node option; }
and v = { mutable def : rhs; mutable node : node option;
mutable descr : Descr.t option}
module MemoHash = Hashtbl.Make( struct
type t = v
......@@ -2670,21 +2671,23 @@ module Positive = struct
aux ppf v
let printf = pp Format.std_formatter
let rec make_descr seen v =
if List.memq v seen then empty
else
let seen = v :: seen in
match v.def with
match v.descr with
| Some d -> d
| None ->
if List.memq v seen then empty
else
let seen = v :: seen in
match v.def with
|`Type d -> d
|`Variable d -> var d
|`Variable d -> var d
|`Cup vl -> List.fold_left (fun acc v -> cup acc (make_descr seen v)) empty vl
|`Cap vl -> List.fold_left (fun acc v -> cap acc (make_descr seen v)) any vl
|`Times (v1,v2) -> times (make_node v1) (make_node v2)
|`Arrow (v1,v2) -> arrow (make_node v1) (make_node v2)
|`Xml (v1,v2) -> xml (make_node v1) (make_node v2)
|`Record (b, flst) -> rec_of_list b (List.map (fun (b,l,v) -> (b,l,make_descr seen v)) flst)
|`Neg v -> neg (make_descr seen v)
|`Record (b, flst) -> rec_of_list b (List.map (fun (b,l,v) -> (b,l,make_descr seen v)) flst)
|`Neg v -> neg (make_descr seen v)
and make_node v =
match v.node with
......@@ -2697,13 +2700,13 @@ module Positive = struct
n
(* We shadow the corresponding definitions in the outer module *)
let forward () = { def = `Cup []; node = None; }
let forward () = { def = `Cup []; node = None; descr = None }
let def v d = v.def <- d
let cons d = let v = forward () in def v d; v
let ty d = cons (`Type d)
let var d = cons (`Variable d)
let neg v = cons (`Neg v)
let rec cup vl = cons (`Cup vl)
let cup vl = cons (`Cup vl)
let cap vl = cons (`Cap vl)
let times v1 v2 = cons (`Times (v1,v2))
let arrow v1 v2 = cons (`Arrow (v1,v2))
......@@ -2762,6 +2765,7 @@ module Positive = struct
and decompose_type t =
try DescrHash.find memo t
with Not_found ->
let r =
if no_var t then ty t
else
match check_var t with
......@@ -2781,136 +2785,153 @@ module Positive = struct
@@ decompose_kind Abstract.any abstract (BoolAbstracts.get t.abstract) []
in
node_t.def <- (cup descr_t).def; node_t
in
r.descr <- Some t;
r
in
decompose_type t
let solve v = internalize (make_node v)
(* [map_var f v] applies returns the type
[v{ 'a <- f 'a}] for all ['a] in [v]
*)
let map_var subst v =
let memo = MemoHash.create 17 in
let rec aux v subst =
try MemoHash.find memo v
with Not_found ->
let node_v = forward () in
let () = MemoHash.add memo v node_v in
let new_v =
match v.def with
|`Type d -> `Type d
(* |`Variable d when Var.Set.mem d delta -> v.def *)
|`Variable d -> (subst d).def
|`Cup vl -> `Cup (List.map (fun v -> aux v subst) vl)
|`Cap vl -> `Cap (List.map (fun v -> aux v subst) vl)
|`Times (v1,v2) -> `Times (aux v1 subst, aux v2 subst)
|`Arrow (v1,v2) -> `Arrow (aux v1 subst, aux v2 subst)
|`Xml (v1,v2) -> `Xml (aux v1 subst, aux v2 subst)
|`Record (b, flst) ->
`Record (b, List.map (fun (b,l,v) -> (b,l,aux v subst)) flst)
|`Neg v -> `Neg (aux v subst)
in
node_v.def <- new_v;
node_v
in
aux v subst
let apply_subst ?(subst=(fun v -> var v)) ?(after=(fun x -> x)) t =
if no_var t then t else
let res = map_var subst (decompose t) in
let res = after res in
descr (solve res)
(* Given a type t and a polymorphic variable 'a occuring in t,
returns the type s which is the solution of 'a = t *)
let solve_rectype t alpha =
let x = forward () in
let subst d = if Var.equal d alpha then x else var d in
apply_subst ~subst:subst ~after:(fun y -> define x y;x) t
(* Pre-condition : alpha \not\in \delta *)
module MemoSubst =
struct
include Hashtbl.Make (struct
type t = descr * (Var.t * descr) list
let hash (t, l) =
List.fold_left
(fun acc (v,t) -> Var.hash v + 17 * Descr.hash t + 31 * acc)
(Descr.hash t) l
let solve v = (*match v.descr with
None -> *)internalize (make_node v)
(*| Some t -> T.cons t *)
let equal (t1, l1) (t2, l2) =
Descr.equal t1 t2 && (try List.for_all2 (fun (v1, t1) (v2, t2) ->
Var.equal v1 v2 && Descr.equal t1 t2) l1 l2 with _ -> false)
end)
end
end
module Substitution =
struct
module Map = Var.Set.Map
type t = Descr.t Map.map
type order = int Map.map
let identity = Map.empty
let add v t m =
if is_var t && Var.(equal v (Set.choose (all_vars t))) then m
else Map.add v t m
let of_list l =
List.fold_left (fun acc (v, t) -> add v t acc) identity l
module Memo = Hashtbl.Make
(struct
type subst = t
type t = Descr.t * subst
let equal ((t1, l1) as k1) ((t2, l2) as k2) =
k1 == k2
|| ((t1 == t2 || Descr.equal t1 t2)
&& (l1 == l2 || Map.equal Descr.equal l1 l2))
let hash (t, l) =
(Descr.hash t + 31 * Map.hash Descr.hash l) land 0x3fff_ffff
end)
let global_memo = Memo.create 17
let memo_subst = MemoSubst.create 17
let rec substitute_list t l =
if no_var t || l == [] then t else
let k = (t,l) in
try
MemoSubst.find memo_subst k
with Not_found ->
let r =
let subst d =
try
ty
@@ snd
@@ List.find (fun (alpha,_) -> Var.equal d alpha) l
with Not_found -> var d
in
apply_subst ~subst:subst t
in
let () =
try
let (cu, name, subst) = DescrMap.find t !Print.named in
let _nsubst =
List.map (fun (v, vt) -> v, substitute_list vt l) subst
in
Print.register_global (cu, name, _nsubst) r;
with Not_found -> ()
let rec apply_subst ?(after = (fun x -> x)) ?(do_var= fun x -> Positive.ty x) t subst =
let open Positive in
if subst == identity then descr (solve t) else
let memo = MemoHash.create 17 in
let todo = ref [] in
let rec aux v =
let found, update, v =
match v.descr with
| None -> false, None, v
| Some d ->
let vars = all_vars d in
if Var.Set.is_empty vars then true, None, ty d
else
let subst' = Map.restrict subst vars in
let key = (d, subst') in
try
let d = Memo.find global_memo key in
true, None , ty d
with
Not_found ->
false, Some (key), v
in
MemoSubst.add memo_subst k r;
r