Commit 86748961 authored by Kim Nguyễn's avatar Kim Nguyễn

Recursively check in the global normalisation hash table whether the

type has already been normalized. Without this patch, in the following usage:

norm(T1, delta)
norm(<a>[ T1 ], delta)

the fact that T1 has already been normalized against some delta is not taken into
account while normalizin <a>[T1].
parent 7932c071
......@@ -3233,55 +3233,60 @@ module Tallying = struct
module NormMemoHash = Hashtbl.Make(Custom.Pair(Descr)(Var.Set))
let memo_norm = NormMemoHash.create 17
let rec norm (t,delta,mem) =
if is_empty t then CS.sat
else
try
let finished, cst = NormMemoHash.find mem (t, delta) in
if finished then cst else CS.sat
with
Not_found ->
begin
let res =
if is_var t then
begin
try
(* If we find it in the global hashtable, we are finished *)
NormMemoHash.find memo_norm (t, delta)
with
Not_found ->
try
let finished, cst = NormMemoHash.find mem (t, delta) in
if finished then cst else CS.sat
with
Not_found ->
begin
let res =
(* base cases *)
if is_empty t then CS.sat (* empty type is sat *)
else if no_var t then CS.unsat (* if the type has no variable and is not empty, unsat *)
else if is_var t then (* a single top_level variable *)
begin
(* if there is only one variable then is it A <= 0 or 1 <= A *)
let (v,p) = extract_variable t in
if Var.Set.mem v delta then CS.unsat
else
let s = if p then (Pos (v,empty)) else (Neg (any,v)) in
CS.singleton s
(* if there are no vars, and it is not empty then unsat *)
end
else if no_var t then CS.unsat
else begin
let mem = NormMemoHash.add mem (t,delta) (false, CS.sat); mem in
let aux single norm_aux acc l =
big_prod delta (toplevel delta single norm_aux mem) acc l
in
let acc = aux single_atoms normatoms CS.sat (BoolAtoms.get t.atoms) in
let acc = aux single_chars normchars acc (BoolChars.get t.chars) in
let acc = aux single_ints normints acc (BoolIntervals.get t.ints) in
let acc = aux single_times normpair acc (BoolPair.get t.times) in
let acc = aux single_xml normpair acc (BoolPair.get t.xml) in
let acc = aux single_arrow normarrow acc (BoolPair.get t.arrow) in
let acc = aux single_abstract normabstract acc (BoolAbstracts.get t.abstract) in
let (v,p) = extract_variable t in
if Var.Set.mem v delta then CS.unsat (* if it is monomorphic, unsat *)
else
(* otherwise, create a single constraint according to its polarity *)
let s = if p then (Pos (v,empty)) else (Neg (any,v)) in
CS.singleton s
end
else begin (* type is not empty and is not a variable *)
let mem = NormMemoHash.add mem (t,delta) (false, CS.sat); mem in
let aux single norm_aux acc l =
big_prod delta (toplevel delta single norm_aux mem) acc l
in
let acc = aux single_atoms normatoms CS.sat (BoolAtoms.get t.atoms) in
let acc = aux single_chars normchars acc (BoolChars.get t.chars) in
let acc = aux single_ints normints acc (BoolIntervals.get t.ints) in
let acc = aux single_times normpair acc (BoolPair.get t.times) in
let acc = aux single_xml normpair acc (BoolPair.get t.xml) in
let acc = aux single_arrow normarrow acc (BoolPair.get t.arrow) in
let acc = aux single_abstract normabstract acc (BoolAbstracts.get t.abstract) in
(* XXX normrec is not tested at all !!! *)
let acc = aux single_record normrec acc (BoolRec.get t.record) in
let acc = (* Simplify the constraints on that type *)
CS.S.filter
(fun m -> CS.M.for_all (fun v (s, t) -> not (Var.Set.mem v delta) ||
let x = var v in subtype s x && subtype x t
) m)
acc
in
let acc = aux single_record normrec acc (BoolRec.get t.record) in
let acc = (* Simplify the constraints on that type *)
CS.S.filter
(fun m -> CS.M.for_all (fun v (s, t) -> not (Var.Set.mem v delta) ||
let x = var v in subtype s x && subtype x t
) m)
acc
in
acc
end
in
NormMemoHash.replace mem (t, delta) (true,res); res
end
(* Format.printf "Normalizing %a yields %a\n%!" Print.pp_type t CS.pp_s res; *)
end
in
NormMemoHash.replace mem (t, delta) (true,res); res
end
(* (t1,t2) = intersection of all (fst pos,snd pos) \in P
* (s1,s2) \in N
......@@ -3376,7 +3381,6 @@ module Tallying = struct
in
big_prod delta norm_arrow CS.sat (Pair.get t)
let memo_norm = NormMemoHash.create 17
let norm delta t =
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment