Skip to content

GitLab

Commit ea80ff58 authored by Pietro Abate's avatar Pietro Abate
Browse files

Add delta to Positive.clean_type and Tallying.norm

parent ec80900d
Hide whitespace changes
Inline Side-by-side
Showing with 138 additions and 77 deletions
tests/libtest/tallyingTest.ml
View file @ ea80ff58
......@@ -39,8 +39,8 @@ and vv = V of string
let mk_s ll =
let aux l =
List.fold_left (fun acc -> function
|P(V alpha,t) -> Tallying.CS.M.add ((*true,*)Var.mk alpha) (Types.empty,parse_typ t) acc
|N(t,V alpha) -> Tallying.CS.M.add ((*false,*)Var.mk alpha) (parse_typ t,Types.any) acc
|P(V alpha,t) -> Tallying.CS.M.add Var.Set.empty (Var.mk alpha) (Types.empty,parse_typ t) acc
|N(t,V alpha) -> Tallying.CS.M.add Var.Set.empty (Var.mk alpha) (parse_typ t,Types.any) acc
) Tallying.CS.M.empty l
in
List.fold_left (fun acc l ->
......@@ -50,8 +50,8 @@ let mk_s ll =
let mk_union_res l1 l2 =
let aux l =
List.fold_left (fun acc -> function
|P(V v,s) -> Tallying.CS.M.merge acc (Tallying.CS.M.singleton (Var.mk v) (Types.empty, parse_typ s))
|N(s,V v) -> Tallying.CS.M.merge acc (Tallying.CS.M.singleton (Var.mk v) (parse_typ s, Types.any))
|P(V v,s) -> Tallying.CS.M.inter Var.Set.empty acc (Tallying.CS.M.singleton (Var.mk v) (Types.empty, parse_typ s))
|N(s,V v) -> Tallying.CS.M.inter Var.Set.empty acc (Tallying.CS.M.singleton (Var.mk v) (parse_typ s, Types.any))
) Tallying.CS.M.empty l
in
match l1,l2 with
......@@ -62,12 +62,12 @@ let mk_union_res l1 l2 =
(* check invariants on the constraints sets *)
let mk_pp = function
|P(V alpha,t) -> Tallying.CS.singleton (Tallying.Pos (Var.mk alpha,parse_typ t))
|N(t,V alpha) -> Tallying.CS.singleton (Tallying.Neg (parse_typ t,Var.mk alpha))
|P(V alpha,t) -> Tallying.CS.singleton Var.Set.empty (Tallying.Pos (Var.mk alpha,parse_typ t))
|N(t,V alpha) -> Tallying.CS.singleton Var.Set.empty (Tallying.Neg (parse_typ t,Var.mk alpha))
let mk_prod l =
List.fold_left (fun acc c ->
Tallying.CS.prod (mk_pp c) acc
Tallying.CS.prod Var.Set.empty (mk_pp c) acc
) Tallying.CS.sat l
let mk_union l1 l2 =
......
types/boolVar.mli 0 → 100644
View file @ ea80ff58
module type E = sig
type elem
include Custom.T
val empty : t
val full : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : elem -> t
end
module type S = sig
type s
type elem = s Var.pairvar
include Custom.T
(** returns the union of all leaves in the BDD *)
val leafconj: t -> s
val get: t -> (elem list * elem list) list
val empty : t
val full : t
(* same as full, but we keep it for the moment to avoid chaging the code everywhere *)
val any : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : elem -> t
val trivially_disjoint: t -> t -> bool
(** vars a : return a bdd that is ( Any ^ Var a ) *)
val vars : Var.var -> t
val iter: (elem-> unit) -> t -> unit
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
atom:(elem -> 'b) -> t -> 'b
val is_empty : t -> bool
val pp_print : Format.formatter -> t -> unit
val print : ?f:(Format.formatter -> elem -> unit) -> t -> (Format.formatter -> unit) list
end
module type MAKE = functor (T : E) -> S with type s = T.t
module Make : MAKE
types/types.ml
View file @ ea80ff58
......@@ -295,7 +295,7 @@ struct
ints = BoolIntervals.full;
atoms = BoolAtoms.full;
chars = BoolChars.full;
abstract = BoolAbstracts.any;
abstract = BoolAbstracts.full;
absent= false;
toplvars = TLV.any
}
......@@ -466,7 +466,7 @@ let var a = {
ints = BoolIntervals.vars a;
atoms = BoolAtoms.vars a;
chars = BoolChars.vars a;
abstract = BoolAbstracts.empty;
abstract = BoolAbstracts.vars a;
absent= false;
toplvars = TLV.singleton (a,true)
}
......@@ -1919,7 +1919,11 @@ struct
(Record (r,some,none))
) (Record.get { empty with record = BoolRec.atom (`Atm x) })) not_seq.toplvars not_seq.record;
List.iter (fun x -> add (Atomic x)) (BoolAbstracts.print not_seq.abstract);
prepare_boolvar BoolAbstracts.get (Abstracts.equal Abstracts.full) (fun bdd ->
match Abstracts.print bdd with
|[x] -> [Atomic x]
|l -> [Union(alloc (List.map (fun x -> (Atomic x)) l))]
) not_seq.toplvars not_seq.abstract;
if not_seq.absent then add (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT"));
slot.def <- List.rev slot.def;
......@@ -2729,6 +2733,8 @@ module Tallying = struct
|Pos of (Var.var * s) (** alpha <= t | alpha \in P *)
|Neg of (s * Var.var) (** t <= alpha | alpha \in N *)
exception UnSatConstr of string
module CS = struct
(* we require that types are semantically equivalent and not structurally
......@@ -2749,18 +2755,7 @@ module Tallying = struct
module VarMap = Map.Make(Key)
type t = (Descr.s * Descr.s) VarMap.t
let singleton = VarMap.singleton
let empty = VarMap.empty
let cardinal = VarMap.cardinal
let add v (inf, sup) map =
let new_i, new_s =
try
let old_i, old_s = VarMap.find v map in
cup old_i inf,
cap old_s sup
with
Not_found -> inf, sup
in
VarMap.add v (new_i, new_s) map
(* a set of constraints m1 subsumes a set of constraints m2,
that is the solutions for m1 contains all the solutions for
......@@ -2768,7 +2763,6 @@ module Tallying = struct
forall i1 <= v <= s1 in m1,
there exists i2 <= v <= s2 in m2 such that i1 <= i2 <= v <= s2 <= s1
*)
let subsumes map1 map2 =
VarMap.for_all (fun v (i1, s1) ->
try let i2, s2 = VarMap.find v map2 in
......@@ -2787,9 +2781,27 @@ module Tallying = struct
if c == 0 then semantic_compare s1 s2
else c) map1 map2
let inter map1 map2 = VarMap.fold add map1 map2
let add delta v (inf, sup) map =
let new_i, new_s =
try
let old_i, old_s = VarMap.find v map in
cup old_i inf,
cap old_s sup
with
Not_found -> inf, sup
in
if Var.Set.mem v delta then
if ((equal inf empty) && (equal sup any)) ||
(equal (var v) inf && equal (var v) sup) then
map
else
raise (UnSatConstr (Format.sprintf "%s is a monomorphic variable" (Utils.string_of_formatter Var.pp v)))
else
VarMap.add v (new_i, new_s) map
let inter delta map1 map2 = VarMap.fold (add delta) map1 map2
let fold = VarMap.fold
let merge = inter
let empty = VarMap.empty
end
......@@ -2890,7 +2902,7 @@ module Tallying = struct
loop s1 s2 []
(* Square intersection *)
let inter s1 s2 =
let inter delta s1 s2 =
match s1,s2 with
[], _ | _, [] -> []
| _ ->
......@@ -2906,7 +2918,7 @@ module Tallying = struct
fold (fun m2 acc2 ->
let merged = if M.subsumes m1 m2 then m2
else if M.subsumes m2 m1 then m1
else M.inter m1 m2
else M.inter delta m1 m2
in
add merged acc2
)
......@@ -2929,9 +2941,19 @@ module Tallying = struct
type sl = sigma list
let singleton = function
|Pos (v,s) -> S.singleton (M.singleton v (empty,s))
|Neg (s,v) -> S.singleton (M.singleton v (s,any))
let singleton delta = function
|Pos (v,s) ->
if Var.Set.mem v delta then
if equal s any || equal (var v) s then S.singleton M.empty
else raise (UnSatConstr (Format.sprintf "%s is a monomorphic variable" (Utils.string_of_formatter Var.pp v)))
else
S.singleton (M.singleton v (empty,s))
|Neg (s,v) ->
if Var.Set.mem v delta then
if equal s any || equal (var v) s then S.singleton M.empty
else raise (UnSatConstr (Format.sprintf "%s is a monomorphic variable" (Utils.string_of_formatter Var.pp v)))
else
S.singleton (M.singleton v (s,any))
let pp_s = S.pp
let pp_m = M.pp
......@@ -2942,9 +2964,8 @@ module Tallying = struct
let unsat = S.empty
let union = S.union
let prod = S.inter
let merge = M.inter
let prod delta = S.inter delta
let merge delta = M.inter delta
end
let normatoms (t,_,_) = if Atoms.is_empty t then CS.sat else CS.unsat
......@@ -2986,31 +3007,31 @@ module Tallying = struct
let toplevel delta single norm_rec mem p n = match (p,n) with
|([],(`Var x)::neg) ->
let t = single (false,x,[],neg) in
CS.singleton (Neg (t,`Var x))
CS.singleton delta (Neg (t,`Var x))
|((`Var x)::pos,[]) ->
let t = single (true,x,pos,[]) in
CS.singleton (Pos (`Var x,t))
CS.singleton delta (Pos (`Var x,t))
|((`Var x)::pos, (`Var y)::neg) ->
if Var.compare (`Var x) (`Var y) < 0 then
let t = single (true,x,pos,n) in
CS.singleton (Pos (`Var x,t))
CS.singleton delta (Pos (`Var x,t))
else
let t = single (false,y,p,neg) in
CS.singleton (Neg (t,`Var y))
CS.singleton delta (Neg (t,`Var y))
|([`Atm a], (`Var x)::neg) ->
let t = single (false,x,p,neg) in
CS.singleton (Neg (t,`Var x))
CS.singleton delta (Neg (t,`Var x))
|([`Atm t], []) -> norm_rec (t,delta,mem)
|_,_ -> assert false
let big_prod f acc l =
let big_prod delta f acc l =
List.fold_left (fun acc (pos,neg) ->
(* if CS.S.is_empty acc then acc else *)
CS.prod acc (f pos neg)
CS.prod delta acc (f pos neg)
) acc l
(* norm generates a constraint set for the costraint t <= 0 *)
......@@ -3025,12 +3046,12 @@ module Tallying = struct
else if is_var t then
let (v,p) = TLV.max t.toplvars in
let s = if p then (Pos (v,empty)) else (Neg (any,v)) in
CS.singleton s
CS.singleton delta s
(* if there are no vars, and it is not empty then unsat *)
else if no_var t then CS.unsat
else begin
let mem = DescrSet.add t mem in
let aux single norm_aux acc l = big_prod (toplevel delta single norm_aux mem) acc l 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
......@@ -3068,7 +3089,7 @@ module Tallying = struct
let con20 = aux t1 z2 rest in
let con11 = CS.union con1 con10 in
let con22 = CS.union con2 con20 in
CS.prod con11 con22
CS.prod delta con11 con22
end
in
(* cap_product return the intersection of all (fst pos,snd pos) *)
......@@ -3078,7 +3099,7 @@ module Tallying = struct
let con0 = aux t1 t2 neg in
CS.union (CS.union con1 con2) con0
in
big_prod norm_prod CS.sat (Pair.get t)
big_prod delta norm_prod CS.sat (Pair.get t)
and normrec (t,delta,mem) =
let norm_rec ((oleft,left),rights) =
......@@ -3090,15 +3111,15 @@ module Tallying = struct
snd (Array.fold_left (fun (i,acc) t ->
let di = diff accus.(i) t in
let accus' = Array.copy accus in accus'.(i) <- di ;
(i+1,CS.prod acc (CS.prod (norm (di,delta,mem)) (aux accus' [] right)))
(i+1,CS.prod delta acc (CS.prod delta (norm (di,delta,mem)) (aux accus' [] right)))
) (0,CS.sat) field
)
in
let c = Array.fold_left (fun acc t -> CS.union (norm (t,delta,mem)) acc) CS.sat left in
CS.prod (aux left [] rights) c
CS.prod delta (aux left [] rights) c
in
List.fold_left (fun acc (_,p,n) ->
if CS.S.is_empty acc then acc else CS.prod acc (norm_rec (p,n))
if CS.S.is_empty acc then acc else CS.prod delta acc (norm_rec (p,n))
) CS.sat (get_record t)
(* arrow(p,{t1 -> t2}) = [t1] v arrow'(t1,any \ t2,p)
......@@ -3134,9 +3155,9 @@ module Tallying = struct
let con20 = aux t1 acc1 p in
let con11 = CS.union con1 con10 in
let con22 = CS.union con2 con20 in
CS.prod con11 con22
CS.prod delta con11 con22
in
big_prod norm_arrow CS.sat (Pair.get t)
big_prod delta norm_arrow CS.sat (Pair.get t)
let memo_norm = DescrHash.create 17
(* XXX here I hash over a set . this might lead to a
......@@ -3148,8 +3169,6 @@ module Tallying = struct
DescrHash.add memo_norm t res; res
end
exception UnSatConstr of string
let rec merge (m,delta,mem) =
let res =
CS.M.fold (fun v (inf, sup) acc ->
......@@ -3163,7 +3182,7 @@ module Tallying = struct
let n =
let n = norm delta x in if CS.S.is_empty n then raise (UnSatConstr "merge2") else n
in
let c1 = CS.prod (CS.S.singleton m) n in
let c1 = CS.prod delta (CS.S.singleton m) n in
let c2 = CS.S.fold (fun m1 acc -> CS.union acc (merge (m1,delta,mem))) c1 CS.S.empty in
CS.union c2 acc
end) m CS.S.empty
......@@ -3239,7 +3258,7 @@ module Tallying = struct
let d = diff s t in
if is_empty d then CS.sat
else if no_var d then CS.unsat
else CS.prod acc (norm delta d)
else CS.prod delta acc (norm delta d)
) CS.sat l
in
if Pervasives.(n = CS.unsat) then raise Step1Fail else
......@@ -3335,24 +3354,16 @@ let set a i v =
end
let get a i = if i < 0 then any else (!a).(i)
exception FoundSquareSub of Tallying.CS.sl * bool
exception FoundSquareSub of Tallying.CS.sl
let squaresubtype delta s t =
DescrHash.clear Tallying.memo_norm;
(* assert (Var.Set.is_empty (Var.Set.diff (all_vars t) delta)); *)
let ai = ref [| |] in
let tallying i =
try
let s = get ai i in
let sl = Tallying.tallying ~delta [ (s,t) ] in
let ss =
Positive.clean_type delta (
List.fold_left (fun acc si ->
cap acc (Tallying.(s $$ si))
) any sl
)
in
raise (FoundSquareSub(sl,subtype ss t))
raise (FoundSquareSub sl)
with
Tallying.Step1Fail -> (assert (i == 0); raise (Tallying.UnSatConstr "apply_raw step1"))
| Tallying.Step2Fail -> () (* continue *)
......@@ -3364,17 +3375,14 @@ let squaresubtype delta s t =
else (cap (Positive.substitutefree delta s) (get ai (i-1)))
in
set ai i ss;
(*
Format.printf "Starting expansion %i @\n@." i;
Format.printf "%a < %a\n@." Print.print ss Print.print t;
*)
tallying i;
loop (i+1)
with FoundSquareSub (sl,res) -> sl, res
with FoundSquareSub sl -> sl
in
loop 0
let is_squaresubtype delta s t = snd(squaresubtype delta s t)
let is_squaresubtype delta s t =
try ignore(squaresubtype delta s t);true with Tallying.UnSatConstr _ -> false
exception FoundApply of t * int * int * Tallying.CS.sl
......
types/types.mli
View file @ ea80ff58
......@@ -164,11 +164,11 @@ module Positive : sig
val times: v -> v -> v
val xml: v -> v -> v
(* val decompose : t -> v *)
val substitute : t -> (Var.var * t) -> t
val substituterec : t -> Var.var -> t
val solve: v -> Node.t
val substitutefree : Var.Set.t -> t -> t
val clean_type : Var.Set.t -> t -> t
end
(** Normalization **)
......@@ -203,7 +203,6 @@ module Product : sig
val need_second: t -> bool
(* Is there more than a single rectangle ? *)
val clean_normal: t -> t
(* Merge rectangles with same second component *)
end
......@@ -383,10 +382,10 @@ module Tallying : sig
type t
val compare : t -> t -> int
val empty : t
val add : key -> descr*descr -> t -> t
val add : Var.Set.t -> key -> descr*descr -> t -> t
val singleton : key -> descr*descr -> t
val pp : Format.formatter -> t -> unit
val merge : t -> t -> t
val inter : Var.Set.t -> t -> t -> t
end
module E : sig
include Map.S with type key = Var.var
......@@ -418,12 +417,12 @@ module Tallying : sig
val pp_e : Format.formatter -> sigma -> unit
val pp_sl : Format.formatter -> sl -> unit
val merge : m -> m -> m
val singleton : constr -> s
(* val merge : m -> m -> m *)
val singleton : Var.Set.t -> constr -> s
val sat : s
val unsat : s
val union : s -> s -> s
val prod : s -> s -> s
val prod : Var.Set.t -> s -> s -> s
end
val norm : Var.Set.t -> t -> CS.s
......@@ -458,7 +457,7 @@ end
(** Square Subtype relation. [squaresubtype delta s t] .
True if there exists a substitution such that s < t only
considering variables that are not in delta *)
val squaresubtype : Var.Set.t -> t -> t -> (Tallying.CS.sl * bool)
val squaresubtype : Var.Set.t -> t -> t -> Tallying.CS.sl
val is_squaresubtype : Var.Set.t -> t -> t -> bool
(** apply_raw s t returns the 4-tuple (subst,ss, tt, res) where
......
typing/typer.ml
View file @ ea80ff58
......@@ -912,7 +912,7 @@ and type_check' loc env ed constr precise = match ed with
if not (Types.subtype t1 acc) then
raise_loc loc (NonExhaustive (Types.diff t1 acc));
let t = type_check_branches loc env t1 a.fun_body t2 false in
(fst(Types.squaresubtype env.delta t t2))::tacc (* H_j *)
(Types.squaresubtype env.delta t t2)::tacc (* H_j *)
) [] a.fun_iface
in
List.iter (fun sl ->
......
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