From 5641fa939cb85b4e7fa7dae2cd6595393b2537c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kim=20Nguy=E1=BB=85n?= Date: Sun, 29 Mar 2015 16:25:34 +0200 Subject: [PATCH] Further simplify the type algebra code, using the newly introduced combinators (map/fold/iter) over types. --- types/types.ml | 512 +++++++++++++++---------------------------------- 1 file changed, 156 insertions(+), 356 deletions(-) diff --git a/types/types.ml b/types/types.ml index 457662cc..3dd54e26 100644 --- a/types/types.ml +++ b/types/types.ml @@ -1,8 +1,6 @@ open Ident open Encodings -let (@@) f a = f a - let count = ref 0 let () = @@ -147,12 +145,13 @@ type ('atoms, 'ints, 'chars, 'times, 'xml, 'arrow, 'record, 'abstract) descr_ = absent : bool; } -module type VarType = +module type VarTypeSig = sig include Bool.V type descr val inj : t -> descr val proj : descr -> t + val update : descr -> t -> descr end let empty_descr_ = { atoms = Bool.empty; @@ -298,7 +297,7 @@ struct let mk id d = { id = id; cu = Compunit.current (); descr = d } end -and VarAtoms : VarType with type Atom.t = Atoms.t +and VarAtoms : VarTypeSig with type Atom.t = Atoms.t and type descr = Descr.t = struct @@ -306,9 +305,10 @@ and VarAtoms : VarType with type Atom.t = Atoms.t type descr = Descr.t let inj t = { empty_descr_ with atoms = t } let proj t = t.atoms + let update t d = { t with atoms = d } end -and VarIntervals : VarType with type Atom.t = Intervals.t +and VarIntervals : VarTypeSig with type Atom.t = Intervals.t and type descr = Descr.t = struct @@ -316,9 +316,10 @@ and VarIntervals : VarType with type Atom.t = Intervals.t type descr = Descr.t let inj t = { empty_descr_ with ints = t } let proj t = t.ints + let update t d = { t with ints = d } end -and VarChars : VarType with type Atom.t = Chars.t +and VarChars : VarTypeSig with type Atom.t = Chars.t and type descr = Descr.t = struct @@ -326,9 +327,10 @@ and VarChars : VarType with type Atom.t = Chars.t type descr = Descr.t let inj t = { empty_descr_ with chars = t } let proj t = t.chars + let update t d = { t with chars = d } end -and VarAbstracts : VarType with type Atom.t = Abstracts.t +and VarAbstracts : VarTypeSig with type Atom.t = Abstracts.t and type descr = Descr.t = struct @@ -336,36 +338,40 @@ and VarAbstracts : VarType with type Atom.t = Abstracts.t type descr = Descr.t let inj t = { empty_descr_ with abstract = t } let proj t = t.abstract + let update t d = { t with abstract = d } end and Pair : Bool.S with type elem = (Node.t * Node.t) = Bool.Make(Custom.Pair(Node)(Node)) -and VarTimes : VarType with module Atom = Pair +and VarTimes : VarTypeSig with module Atom = Pair and type descr = Descr.t = struct include Bool.MakeVar(Pair) type descr = Descr.t let inj (t : t) : descr = { empty_descr_ with times = t } let proj (t : descr) : t = t.times + let update (t : descr) (d : t) : descr = { t with times = d } end -and VarXml : VarType with module Atom = Pair +and VarXml : VarTypeSig with module Atom = Pair and type descr = Descr.t = struct include Bool.MakeVar(Pair) type descr = Descr.t let inj (t : t) : descr = { empty_descr_ with xml = t } let proj (t : descr) : t = t.xml + let update (t : descr) (d : t) : descr = { t with xml = d } end -and VarArrow : VarType with module Atom = Pair +and VarArrow : VarTypeSig with module Atom = Pair and type descr = Descr.t = struct include Bool.MakeVar(Pair) type descr = Descr.t let inj (t : t) : descr = { empty_descr_ with arrow = t } let proj (t : descr) : t = t.arrow + let update (t : descr) (d : t) : descr = { t with arrow = d } end (* bool = true means that the record is open that is, that @@ -375,15 +381,20 @@ end and Rec : Bool.S with type elem = bool * Node.t Ident.label_map = Bool.Make(Custom.Pair(Custom.Bool)(LabelSet.MakeMap(Node))) -and VarRec : VarType with module Atom = Rec +and VarRec : VarTypeSig with module Atom = Rec and type descr = Descr.t = struct include Bool.MakeVar(Rec) type descr = Descr.t + let full_atom = Rec.atom (true, LabelMap.empty) let inj (t : t) : descr = { empty_descr_ with record = t } let proj (t : descr) : t = t.record + let update (t : descr) (d : t) : descr = { t with record = d } end +module type VarType = VarTypeSig with type descr = Descr.t + + module DescrHash = Hashtbl.Make(Descr) module DescrMap = Map.Make(Descr) module DescrSet = Set.Make(Descr) @@ -419,17 +430,17 @@ let non_constructed_or_absent = { non_constructed with absent = true } (* Descr.t type constructors *) -let times x y = { empty with times = VarTimes.atom (`Atm (Pair.atom (x,y))) } -let xml x y = { empty with xml = VarXml.atom (`Atm (Pair.atom (x,y))) } -let arrow x y = { empty with arrow = VarArrow.atom (`Atm (Pair.atom (x,y))) } +let times x y = VarTimes.inj (VarTimes.atom (`Atm (Pair.atom (x,y)))) +let xml x y = VarXml.inj (VarXml.atom (`Atm (Pair.atom (x,y)))) +let arrow x y = VarArrow.inj (VarArrow.atom (`Atm (Pair.atom (x,y)))) let record label t = - { empty with record = VarRec.atom (`Atm (Rec.atom (true,LabelMap.singleton label t))) } + VarRec.inj (VarRec.atom (`Atm (Rec.atom (true,LabelMap.singleton label t)))) let record_fields x = - { empty with record = VarRec.atom (`Atm (Rec.atom x)) } + VarRec.inj (VarRec.atom (`Atm (Rec.atom x))) -let atom a = { empty with atoms = VarAtoms.atom (`Atm a) } +let atom a = VarAtoms.inj (VarAtoms.atom (`Atm a)) (* Atm = Any ^ a *) let var a = @@ -445,14 +456,14 @@ let var a = absent = false; } -let char c = { empty with chars = VarChars.atom (`Atm c) } -let interval i = { empty with ints = VarIntervals.atom (`Atm i) } -let abstract a = { empty with abstract = VarAbstracts.atom (`Atm a) } +let char c = VarChars.inj (VarChars.atom (`Atm c)) +let interval i = VarIntervals.inj (VarIntervals.atom (`Atm i)) +let abstract a = VarAbstracts.inj (VarAbstracts.atom (`Atm a)) let cup x y = if x == y then x else { - ints = VarIntervals.cup x.ints y.ints; + ints = VarIntervals.cup x.ints y.ints; atoms = VarAtoms.cup x.atoms y.atoms; chars = VarChars.cup x.chars y.chars; times = VarTimes.cup x.times y.times; @@ -996,30 +1007,6 @@ let subtype d1 d2 = is_empty (diff d1 d2) let equiv d1 d2 = (subtype d1 d2) && (subtype d2 d1) - -(* perform some semantic simplifications around type constructors *) -let atom a = - let atm = - if Atoms.(is_empty (diff full a)) then - VarAtoms.full - else VarAtoms.atom (`Atm a) - in - { empty with atoms = atm } - -let times x y = - if subtype any x.Node.descr - && subtype any y.Node.descr - then - { empty with times = VarTimes.full } - else times x y - -let xml x y = - if subtype any x.Node.descr - && subtype any y.Node.descr - then - { empty with xml = VarXml.full } - else xml x y - module Cache = struct type 'a cache = @@ -1577,123 +1564,71 @@ end module Iter = struct - let any_node2 = any_node, any_node - let compute ?(normalize=false) ~empty ~full ~cup ~cap ~diff ~var ~atom ~int ~char ~times ~xml ~arrow ~record ~abs ~opt t + let all_fields : (module VarType) array = [| + (module VarAtoms); (module VarIntervals); + (module VarChars); (module VarTimes); + (module VarXml); (module VarArrow); + (module VarRec); (module VarAbstracts) + |] + let fold ?(abs=(fun _ x -> x)) + (f : (module VarType) -> Descr.t -> 'a -> 'a) (t : Descr.t) + (acc : 'a) : 'a = - let var_or f = - function `Atm a -> f a - | `Var v -> var v - in - let any_atom = atom Atoms.full in - let any_int = int Intervals.full in - let any_char = char Chars.full in - let any_abs = abs Abstracts.full in - let any_times = times any_node2 in - let any_xml = xml any_node2 in - let any_record = record (true,LabelMap.empty) in - let any_arrow = diff full - (List.fold_left cup any_atom - [ any_int; any_char; any_abs; any_times; any_xml; any_record ]) - in - let record_bdd p = - Rec.compute ~empty ~full:any_record ~cup ~cap ~diff ~atom:record p - in - let prod_bdd kind p = - let any,mk = - match kind with - `Times -> any_times, times - | `Xml -> any_xml, xml - | `Arrow -> any_arrow, arrow - in - if normalize && Pervasives.(kind <> `Arrow) then - let rects = - match kind with - `Times -> Product.normal ~kind:`Normal { Descr.empty with times = VarTimes.atom (`Atm p) } - | `Xml -> Product.normal ~kind:`XML { Descr.empty with xml = VarXml.atom (`Atm p) } - | _ -> assert false - in - List.fold_left (fun acc (d1, d2) -> cup acc (mk (cons d1, cons d2))) empty rects - else - Pair.compute ~empty ~full:any ~cup ~cap ~diff ~atom:mk p - in - List.fold_left (fun acc e -> cup acc e) - (opt t.absent) - [ (VarAtoms.compute - ~empty ~full:any_atom ~cup ~cap ~diff ~atom:(var_or atom) t.atoms); - (VarIntervals.compute - ~empty ~full:any_int ~cup ~cap ~diff ~atom:(var_or int) t.ints); - (VarChars.compute - ~empty ~full:any_char ~cup ~cap ~diff ~atom:(var_or char) t.chars); - (VarAbstracts.compute - ~empty ~full:any_abs ~cup ~cap ~diff ~atom:(var_or abs) t.abstract); - (VarTimes.compute - ~empty ~full:any_times ~cup ~cap ~diff ~atom:(var_or (prod_bdd `Times)) t.times); - (VarXml.compute - ~empty ~full:any_xml ~cup ~cap ~diff ~atom:(var_or (prod_bdd `Xml)) t.xml); - (VarArrow.compute - ~empty ~full:any_arrow ~cup ~cap ~diff ~atom:(var_or (prod_bdd `Arrow)) t.arrow); - (VarRec.compute - ~empty ~full:any_record ~cup ~cap ~diff ~atom:(var_or record_bdd) t.record);] + let acc = abs t.absent acc in + Array.fold_left (fun acc m -> f m t acc) acc all_fields + + let map ?(abs=(fun x -> x)) + (f : (module VarType) -> Descr.t -> Descr.t) + (t : Descr.t) : Descr.t = + fold ~abs:(fun a t -> { t with absent = abs a }) + (fun (module V : VarType) t acc -> + V.update acc (V.proj (f (module V) t))) + t empty + + let iter ?(abs=(fun _ -> ())) + (f : (module VarType) -> Descr.t -> unit) t + = + fold ~abs:(fun a () -> abs a) (fun m t () -> f m t) t () + + let clean_field (module V : VarType) t = + let t_bdd = V.proj t in + if is_empty (V.inj t_bdd) then V.update t V.empty else + if is_empty V.(inj (diff full t_bdd)) then V.update t V.full + else t + let clean_type t = map clean_field t let simplify = let memo = DescrHash.create 17 in - let aux (type atom) - inj - (module BV : Bool.V with type Atom.t = atom ) b - = - let clean b = - if is_empty (inj b) then BV.empty else b - in + let aux (module V : VarType) t = + let clean b = V.proj (clean_field (module V) (V.inj b)) in let rec loop b = - match BV.extract b with - `Split(`Var v, p, i , n) -> - let p = loop p in - let i = loop i in - let n = loop n in - let tp = inj p and tn = inj n in + match V.extract b with + `Split(`Var v, p, i , n) -> + let p = loop p and i = loop i and n = loop n in + let tp = V.inj p and tn = V.inj n in if disjoint tp tn then b else - let v' = clean (BV.var v) in - let p' = clean BV.(cap v' (diff p n)) in - let n' = clean BV.(diff (diff n p) v') in - let i' = clean (BV.cap n p) in - let i'' = clean (BV.cup i i') in - BV.(cup i'' (cup p' n')) - - | _ -> b + let v' = V.var v in + let p' = clean V.(cap v' (diff p n)) in + let n' = clean V.(diff (diff n p) v') in + let i' = clean (V.cap n p) in + let i'' = clean (V.cup i i') in + clean V.(cup i'' (cup p' n')) + | _ -> b in - loop b + V.inj (loop (V.proj t)) in fun t -> - try DescrHash.find memo t with - Not_found -> - let res = - { t with - atoms = aux (fun i -> { empty with atoms = i }) - (module VarAtoms) t.atoms; - chars = aux (fun i -> { empty with chars = i }) - (module VarChars) t.chars; - ints = aux (fun i -> { empty with ints = i }) - (module VarIntervals) t.ints; - abstract = aux (fun i -> { empty with abstract = i }) - (module VarAbstracts) t.abstract; - times = aux (fun i -> { empty with times = i }) - (module VarTimes) t.times; - xml = aux (fun i -> { empty with xml = i }) - (module VarXml) t.xml; - arrow = aux (fun i -> { empty with arrow = i }) - (module VarArrow) t.arrow; - record = aux (fun i -> { empty with record = i }) - (module VarRec) t.record; - } - in - DescrHash.add memo t res; - DescrHash.add memo res res; - res + try DescrHash.find memo t with + Not_found -> + let res = clean_type (map aux t) in + DescrHash.add memo t res; + DescrHash.add memo res res; + res - let compute_bdd ~typ ~cup ~cap ~neg ~var ~atoms ~ints ~chars ~times ~xml ~arrow ~record ~abstract ~absent t = + let compute ~cup ~cap ~neg ~var ~atoms ~ints ~chars ~times ~xml ~arrow ~record ~abstract ~absent t = let t = simplify t in let any_node2 = any_node, any_node in let any_atoms = atoms Atoms.full in @@ -1703,37 +1638,39 @@ module Iter = let any_times = times any_node2 in let any_xml = xml any_node2 in let any_record = record (true,LabelMap.empty) in - let any_arrow = typ Arrow.any - (*neg (cup ([ any_atoms; - any_ints; any_chars; any_abstract; - any_times; any_xml; any_record ])) *) - in + let any_arrow = arrow (empty_node,any_node) in let var_or do_atom = function `Var v -> var v | `Atm atm -> do_atom atm in let simple_bdd (type bdd) (type atom) - any - do_atom - (module B : Bool.S with type t = bdd and type elem = atom) acc bv = + any + do_atom + (module B : Bool.S with type t = bdd and type elem = atom) + acc + bv + = List.fold_left (fun acc (ipos, ineg) -> - match List.map do_atom ipos, List.map do_atom ineg - with - | [] , [] -> any :: acc - | [ e ] , [] -> e :: acc - | [], l -> cap (any :: List.map neg l) :: acc - | l1, l2 -> cap (l1 @ List.map neg l2) :: acc - ) acc (B.get bv) + match List.map do_atom ipos, List.map do_atom ineg + with + | [] , [] -> any :: acc + | [ e ] , [] -> e :: acc + | [], l -> cap (any :: List.map neg l) :: acc + | l1, l2 -> cap (l1 @ List.map neg l2) :: acc + ) acc (B.get bv) in let cplx_bdd (type atom) (type atom2) - any - do_atom - (module BV : VarType with type Atom.t = atom and type Atom.elem = atom2) - acc - bdd - = - simple_bdd (cap[]) (var_or (fun t -> cup (simple_bdd (any) do_atom (module BV.Atom) [] t))) - (module BV) acc bdd + any + do_atom + (module V : VarType with type Atom.t = atom + and type Atom.elem = atom2) + acc + bdd + = + simple_bdd (cap[]) + (var_or (fun t -> cup (simple_bdd (any) do_atom + (module V.Atom) [] t))) + (module V) acc bdd in let acc = absent t.absent in let acc = simple_bdd any_ints (var_or ints) (module VarIntervals) acc t.ints in @@ -1747,8 +1684,6 @@ module Iter = match acc with [ e ] -> e | _ -> cup acc - - end module Variable = @@ -1756,74 +1691,8 @@ module Variable = type t = Var.t let var_cache = DescrHash.create 17 - let collect_vars t = - let memo = DescrHash.create 17 in - let union s1 s2 = - match s1, s2 with - Some s1, Some s2 -> Some (Var.Set.cup s1 s2) - | None, Some s | Some s, None -> Some s - | _ -> None - in - let inter s1 s2 = - match s1, s2 with - Some s1, Some s2 -> Some (Var.Set.cup s1 s2) - | _ -> None - in - let union3 (x1,y1,z1) (x2,y2,z2) = - union x1 x2, union y1 y2, union z1 z2 - in - let inter3 (x1,y1,z1) (x2,y2,z2) = - inter x1 x2, inter y1 y2, inter z1 z2 - in - let empty = Some Var.Set.empty in - let empty3 = empty,empty,empty in - let no3 = None, None, None in - let cst_empty3 _ = empty3 in - let rec loop t = - try - DescrHash.find memo t - with - Not_found -> - DescrHash.add memo t empty3; - let res = - Iter.compute ~normalize:true - ~empty:no3 - ~full:empty3 - ~cup:union3 - ~cap:inter3 - ~diff:(fun (x1,y1,z1) (x2, y2, z2) -> - inter x1 x2, inter y1 z2, inter z1 y2) - ~var:(fun v -> let e = Some (Var.Set.singleton v) in - e,e,empty) - ~int:cst_empty3 - ~char:cst_empty3 - ~atom:cst_empty3 - ~abs:cst_empty3 - ~xml:prod - ~times:prod - ~arrow:arrow - ~record:record - ~opt:cst_empty3 t - in - DescrHash.replace memo t res; - res - and prod (t1, t2) = - let _,y1,z1 = loop (descr t1) - and _,y2,z2 = loop (descr t2) in - empty, union y1 y2, union z1 z2 - and arrow (t1, t2) = - let _,y1,z1 = loop (descr t1) - and _,y2,z2 = loop (descr t2) in - empty, union z1 y2, union y1 z2 - and record (b, lm) = - let _, y, z = List.fold_left (fun acc (_,t) -> - union3 acc (loop (descr t))) empty3 (LabelMap.get lm) - in - empty, y, z - in - loop t - let collect_vars2 t = + let collect_vars t = let memo = DescrHash.create 17 in let empty3 = Var.Set.(empty,empty,empty) in let merge l = @@ -1839,8 +1708,7 @@ module Variable = Not_found -> DescrHash.add memo t empty3; let res = - Iter.compute_bdd - ~typ:cst_empty3 + Iter.compute ~cup:merge ~cap:merge ~neg:(fun (a, b, c) -> (a , c , b)) @@ -1882,8 +1750,7 @@ module Variable = with Not_found -> DescrHash.add memo t (); - Iter.compute_bdd - ~typ:ignore + Iter.compute ~cup:ignore ~cap:ignore ~neg:ignore @@ -1908,15 +1775,11 @@ module Variable = loop t; true with Not_found -> false - - let collect_vars t = - let _extract = function Some e -> e | None -> Var.Set.empty in try DescrHash.find var_cache t with Not_found -> - let tlv, pos, neg = collect_vars2 t in -(* let tlv, pos, neg = extract tlv, extract pos, extract neg in *) + let tlv, pos, neg = collect_vars t in let res = tlv, pos, neg, Var.Set.cup pos neg in DescrHash.add var_cache t res; res @@ -1934,7 +1797,6 @@ module Variable = Not_found -> let b = no_var t in DescrHash.add h t b; b -(* let is_ground t = Var.Set.is_empty (all_vars t) *) let no_var = is_ground let is_closed delta t = @@ -1988,7 +1850,6 @@ let extract_variable = Variable.extract_variable let is_closed = Variable.is_closed - module Print = struct let rec pp_const ppf = function | Integer i -> Intervals.V.print ppf i @@ -2117,8 +1978,7 @@ module Print = struct b == VarRec.empty || (is_empty { empty with record = VarRec.diff VarRec.full b}) - let trivial (type atom) (module T : VarType with type Atom.t = atom - and type descr = Descr.t) t = + let trivial (type atom) (module T : VarType with type Atom.t = atom) t = let t1 = T.inj (T.proj t) in is_empty t1 || is_empty (diff (T.inj T.full) t1) @@ -2130,25 +1990,14 @@ module Print = struct && trivial (module VarArrow) d && trivial (module VarRec) d ) -(* let worth_abbrev d = - not (trivial_pair d.times && trivial_pair d.xml && - trivial_pair d.arrow && trivial_rec d.record) - *) let worth_complement d = - let dd = diff any d in - let aux x = if is_empty x then 1 else 0 in - let n = - aux { empty with atoms = dd.atoms } + - aux { empty with chars = dd.chars } + - aux { empty with ints = dd.ints } + - aux { empty with times = dd.times } + - aux { empty with xml = dd.xml } + - aux { empty with arrow = dd.arrow } + - aux { empty with record = dd.record } + - aux { empty with abstract = dd.abstract } + let c = + Iter.fold (fun (module V : VarType) t acc -> + if is_empty (V.inj (V.proj t)) then acc+1 + else acc) (diff any d) 0 in - n >= 5 + c >= 5 let proper_seq t = let memo = DescrHash.create 17 in @@ -2223,55 +2072,43 @@ module Print = struct | `Var x -> (Var.Set.add x acc_v, acc_a) ) (Var.Set.empty, init) l in - let fill_line (type atom) (module BV : Bool.V with type Atom.t = atom) - table get set t = + let fill_line table (module V : VarType) t = List.iter (fun (p, n) -> - let v1, a1 = split_var_atom (fun a b -> BV.(cap (atom a) b)) BV.full p in - let v2, a2 = split_var_atom (fun a b -> BV.(cup (atom a) b)) BV.empty n in - let a = BV.diff a1 a2 in - let key = v1, v2 in - let old_t = try VarTable.find table key with Not_found -> {empty with absent = t.absent } in - let new_a = BV.cup a (get old_t) in - VarTable.replace table key (set old_t new_a)) (BV.get (get t)) + let v1, a1 = + split_var_atom (fun a b -> V.(cap (atom a) b)) V.full p in + let v2, a2 = + split_var_atom (fun a b -> V.(cup (atom a) b)) V.empty n in + let a = V.diff a1 a2 in + let key = v1, v2 in + let old_t = + try VarTable.find table key with + Not_found -> { empty with absent = t.absent } + in + let new_a = V.cup a (V.proj old_t) in + VarTable.replace table key (V.update old_t new_a)) + (V.get (V.proj t)) in let h = VarTable.create 17 in let d = Iter.simplify d in - fill_line (module VarIntervals) h (fun t -> t.ints) (fun t u -> {t with ints = u }) d; - fill_line (module VarChars) h (fun t -> t.chars) (fun t u -> {t with chars = u }) d; - fill_line (module VarAtoms) h (fun t -> t.atoms) (fun t u -> {t with atoms = u }) d; - fill_line (module VarTimes) h (fun t -> t.times) (fun t u -> {t with times = u }) d; - fill_line (module VarXml) h (fun t -> t.xml) (fun t u -> {t with xml = u }) d; - fill_line (module VarArrow) h (fun t -> t.arrow) (fun t u -> {t with arrow = u }) d; - fill_line (module VarRec) h (fun t -> t.record) (fun t u -> {t with record = u }) d; - fill_line (module VarAbstracts) h (fun t -> t.abstract) (fun t u -> {t with abstract = u }) d; + Iter.iter (fill_line h) d; let h = try let no_var = VarTable.find h Key.empty in - let update_field - (type atom) (module BV : Bool.V with type Atom.t = atom) - get set d1 d2 = - let bdd = get d1 in - if BV.(is_empty (diff full bdd)) then set d2 bdd else d2 - in - let h' = VarTable.create 17 in + let update_field (module V : VarType) t = + let v_no_var = V.proj no_var in + if is_empty V.(inj (diff full v_no_var)) then V.update t v_no_var + else t + in + let h' = VarTable.create 17 in VarTable.iter (fun ((v1, v2) as k) t -> - let t = - if Var.Set.(is_empty v1 && is_empty v2) then t - else - let t = update_field (module VarIntervals) (fun t -> t.ints) (fun t u -> {t with ints = u }) no_var t in - let t = update_field (module VarChars) (fun t -> t.chars) (fun t u -> {t with chars = u }) no_var t in - let t = update_field (module VarAtoms) (fun t -> t.atoms) (fun t u -> {t with atoms = u }) no_var t in - let t = update_field (module VarTimes) (fun t -> t.times) (fun t u -> {t with times = u }) no_var t in - let t = update_field (module VarXml) (fun t -> t.xml) (fun t u -> {t with xml = u }) no_var t in - let t = update_field (module VarArrow) (fun t -> t.arrow) (fun t u -> {t with arrow = u }) no_var t in - let t = update_field (module VarRec) (fun t -> t.record) (fun t u -> {t with record = u }) no_var t in - let t = update_field (module VarAbstracts) (fun t -> t.abstract) (fun t u -> {t with abstract = u }) no_var t in t - in - VarTable.replace h' k t - ) h; h' + let t = + if Var.Set.(is_empty v1 && is_empty v2) then t else + Iter.map update_field t + in + VarTable.replace h' k t + ) h; h' with Not_found -> h in - let found_any, all_descrs = try let res = @@ -2286,8 +2123,11 @@ module Print = struct with Not_found -> true, [ Key.empty , any ] in if found_any then begin - (slot.def <- [Neg (alloc [])];slot) + (slot.def <- [Neg (alloc [])]; slot) end else + let all_descrs = List.map (fun (vars, t) -> (vars, Iter.clean_type t)) + all_descrs + in let merge_column_with (v1,t1) l = List.fold_left (fun (accv, accl) ((v2,t2) as x) -> if equal t1 t2 then (v2::accv, accl) else (accv,x::accl)) @@ -2866,12 +2706,12 @@ module Print = struct let module NodeSet = Set.Make(Node) in Format.fprintf ppf "@[%a@]@\n" Descr.dump t; let nodes = ref NodeSet.empty in - let ignore2 _ _ = () in let pair (n1, n2) = nodes := NodeSet.add n1 (NodeSet.add n2 !nodes) in - Iter.compute ~empty:() ~full:() ~cup:ignore2 ~cap:ignore2 ~diff:ignore2 - ~var:ignore ~atom:ignore ~int:ignore ~char:ignore ~abs:ignore ~opt:ignore + Iter.compute ~cup:ignore ~cap:ignore ~neg:ignore + ~var:ignore ~atoms:ignore ~ints:ignore ~chars:ignore ~abstract:ignore + ~absent:(fun _ -> []) ~times:pair ~xml:pair ~arrow:pair ~record:(fun (_,lm) -> LabelMap.iter (fun n -> nodes := NodeSet.add n !nodes) lm) t; match NodeSet.elements !nodes with @@ -3270,42 +3110,6 @@ module Positive = struct let get_opt = function Some t -> t | None -> T.any let decompose ?(stop=(fun _ -> None)) t = - let memo = DescrHash.create 17 in - let rec loop t = - let res = - try - DescrHash.find memo t - with - Not_found -> - let node_t = forward () in - let () = DescrHash.add memo t node_t in - let rhs = - match stop t with - | Some s -> s - | None -> loop_struct t - in - node_t.def <- (rhs).def; - node_t.descr <- Some t; - node_t - in - res.descr <- Some t; res - and loop_struct t = - Iter.compute ~empty:empty ~full:any - ~cup:(fun v1 v2 -> cup [v1;v2]) - ~cap:(fun v1 v2 -> cap [v1;v2]) - ~diff:diff - ~var ~int:interval ~char ~atom ~abs:abstract - ~xml:(fun (t1, t2) -> xml (loop (descr t1)) (loop (descr t2))) - ~times:(fun (t1, t2) -> times (loop (descr t1)) (loop (descr t2))) - ~arrow:(fun (t1, t2) -> arrow (loop (descr t1)) (loop (descr t2))) - ~record:(fun (b, lm) -> record b (List.map (fun (l,t) -> - let t = descr t in - t.absent, l, loop t) (LabelMap.get lm))) - ~opt:(function true -> ty Record.absent | _ -> empty) t - in - loop t - - let decompose2 ?(stop=(fun _ -> None)) t = let memo = DescrHash.create 17 in let rec loop t = let res = @@ -3326,12 +3130,8 @@ module Positive = struct in res.descr <- Some t; res and loop_struct t = - Iter.compute_bdd - ~typ:ty - ~cup - ~cap - ~neg - ~var + Iter.compute + ~cup ~cap ~neg ~var ~ints:interval ~chars:char ~atoms:atom @@ -3379,7 +3179,7 @@ struct let decompose t = let open Positive in - let res = decompose2 + let res = decompose ~stop:(fun x -> if Variable.no_var x then Some (ty x) else if Variable.is_var t then let v, p = extract_variable t in -- 2.18.1