Code refactoring. Move the Tallying code outside of the Types module.

Makefile.distrib

@@ -167,7 +167,7 @@ OBJECTS = \
  \
  types/compunit.cmo types/sortedList.cmo types/ident.cmo types/var.cmo types/bool.cmo  \
  types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
- types/types.cmo compile/auto_pat.cmo \
+ types/types.cmo compile/auto_pat.cmo types/type_tallying.cmo \
  types/sequence.cmo types/builtin_defs.cmo \
  \
  runtime/value.cmo \

compile/compile.ml

@@ -75,13 +75,13 @@ let enter_global_cu cu env x =
 
 let rec domain = function 
   |Identity -> Var.Set.empty
-  |List l -> Types.Tallying.domain l
+  |List l -> Type_tallying.domain l
   |Comp (s1,s2) -> Var.Set.cup (domain s1) (domain s2)
   |Sel(_,_,sigma) -> (domain sigma)
 
 let rec codomain = function
   | Identity -> Var.Set.empty
-  | List(l) -> Types.Tallying.codomain l
+  | List(l) -> Type_tallying.codomain l
   | Comp(s1,s2) -> Var.Set.cup (codomain s1) (codomain s2)
   | Sel(_,_,sigma) -> (codomain sigma)
 

compile/lambda.ml

@@ -26,7 +26,7 @@ type iface = (Types.descr * Types.descr) list
 
 type sigma = 
   | Identity (* this is basically as Types.Tallying.CS.sat *)
-  | List of Types.Tallying.CS.sl
+  | List of Type_tallying.CS.sl
   | Comp of (sigma * sigma)
   | Sel of (var_loc * iface * sigma) 
 
@@ -104,7 +104,7 @@ module Print = struct
       ) ppf
     in
     function
-      |List ll -> Types.Tallying.CS.pp_sl ppf ll
+      |List ll -> Type_tallying.CS.pp_sl ppf ll
       |Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
       |Sel(x,iface,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_vloc x pp_aux iface pp_sigma s
       |Identity -> Format.fprintf ppf "Id"

compile/lambda.mli

@@ -26,7 +26,7 @@ type iface = (Types.t * Types.t) list
 
 type sigma = 
   | Identity
-  | List of Types.Tallying.CS.sl
+  | List of Type_tallying.CS.sl
   | Comp of (sigma * sigma)
   | Sel of (var_loc * iface * sigma) 
 

runtime/run_dispatch.ml

@@ -201,7 +201,7 @@ let rec eval_sigma env =
         List.fold_left (fun acc sigma_j ->
           let exists_sub =
             List.exists (fun (_,s_i) ->
-              inzero env env.(x) (Types.Tallying.(s_i >> sigma_j))
+              inzero env env.(x) (Type_tallying.(s_i >> sigma_j))
             ) iface
           in
           if exists_sub then sigma_j::acc else acc
@@ -219,7 +219,7 @@ and inzero env v t =
   | Abstraction (Some iface,_,sigma) ->
       let s = List.fold_left (fun acc t -> Types.cap acc (snd t)) Types.any iface in
       List.for_all (fun si ->
-        Types.subtype (Types.Tallying.(s >> si)) t
+        Types.subtype (Type_tallying.(s >> si)) t
       ) (eval_sigma env sigma)
   | _ -> true
 

runtime/value.ml

@@ -3,7 +3,7 @@ open Encodings
 
 type iface = (Types.t * Types.t) list
 type sigma =
-  | List of Types.Tallying.CS.sl
+  | List of Type_tallying.CS.sl
   | Comp of (sigma * sigma)
   | Sel of (int * iface * sigma)
   | Identity
@@ -26,13 +26,13 @@ and t =
 
 let rec domain = function
   | Identity | Mono -> Var.Set.empty
-  | List(l) -> Types.Tallying.domain l
+  | List(l) -> Type_tallying.domain l
   | Comp(s1,s2) -> Var.Set.cup (domain s1) (domain s2)
   | Sel(_,_,sigma) -> (domain sigma)
 
 let rec codomain = function
   | Identity | Mono -> Var.Set.empty
-  | List(l) -> Types.Tallying.codomain l
+  | List(l) -> Type_tallying.codomain l
   | Comp(s1,s2) -> Var.Set.cup (codomain s1) (codomain s2)
   | Sel(_,_,sigma) -> (codomain sigma)
 
@@ -313,7 +313,7 @@ module Print = struct
       ) ppf
     in
     function
-    |List ll -> Types.Tallying.CS.pp_sl ppf ll
+    |List ll -> Type_tallying.CS.pp_sl ppf ll
     |Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
     |Sel(x,iface,s) -> Format.fprintf ppf "Sel(%d,%a,%a)" x pp_aux iface pp_sigma s
     |Identity -> Format.fprintf ppf "Id"
@@ -506,7 +506,7 @@ let rec compare_sigma x y =
 
     | List(sl1), List(sl2) ->
         if List.for_all2 (fun v1 v2 ->
-          Types.Tallying.E.comparea v1 v2 ) sl1 sl2 = 0 then 0
+          Type_tallying.E.comparea v1 v2 ) sl1 sl2 = 0 then 0
         else (List.length sl1) - (List.length sl2)
     | Sel(t1,if1,s1), Sel(t2,if2,s2) ->
 

runtime/value.mli

@@ -3,7 +3,7 @@ open Encodings
 
 type iface = (Types.t * Types.t) list
 type sigma =
-  | List of Types.Tallying.CS.sl
+  | List of Type_tallying.CS.sl
   | Comp of (sigma * sigma)
   | Sel of (int * iface * sigma)
   | Identity

types/type_tallying.mli

+open Types
+
+type constr =
+  | Pos of (Var.var * t) (** alpha <= t | alpha \in P *)
+  | Neg of (t * Var.var) (** t <= alpha | alpha \in N *)
+
+exception UnSatConstr of string
+exception Step1Fail
+exception Step2Fail
+
+module CS : sig
+  module M : sig
+    type key = Var.var
+    type t
+    val compare  : t -> t -> int
+    val empty : t
+    val add : Var.Set.t -> key -> descr*descr -> t -> t
+    val singleton : key -> descr*descr -> t
+    val pp : Format.formatter -> t -> unit
+    val inter : Var.Set.t -> t -> t -> t
+  end
+  module E : sig
+    include Map.S with type key = Var.var
+    val pp : Format.formatter -> descr t -> unit
+  end
+  module ES : sig
+    include Set.S with type elt = descr E.t
+    val pp : Format.formatter -> t -> unit
+  end
+  module S : sig
+    type t = M.t list
+    val empty : t
+    val add : M.t -> t -> t
+    val singleton : M.t -> t
+    val union : t -> t -> t
+    val elements : t -> M.t list
+    val fold : (M.t -> 'b -> 'b) -> M.t list -> 'b -> 'b
+    val pp : Format.formatter -> t -> unit
+  end
+
+  type s = S.t
+  type m =  M.t
+  type es = ES.t
+  type sigma = t E.t
+  type sl = sigma list
+
+  val pp_s  : Format.formatter -> s -> unit
+  val pp_m  : Format.formatter -> m -> unit
+  val pp_e  : Format.formatter -> sigma -> unit
+  val pp_sl : Format.formatter -> sl -> unit
+
+    (* val merge : m -> m -> m *)
+  val singleton : constr -> s
+  val sat : s
+  val unsat : s
+  val union : s -> s -> s
+  val prod : Var.Set.t -> s -> s -> s
+end
+
+val norm : Var.Set.t -> t -> CS.s
+val merge : Var.Set.t -> CS.m -> CS.s
+val solve : Var.Set.t -> CS.s -> CS.es
+val unify : CS.sigma -> CS.sigma
+
+  (* [s1 ... sn] . si is a solution for tallying problem
+     if si # delta and for all (s,t) in C si @ s < si @ t *)
+val tallying : Var.Set.t -> (t * t) list -> CS.sl
+
+val (>>) : t -> CS.sigma -> t
+
+  (** Symbolic Substitution Set *)
+type symsubst =
+  |I (** Identity *)
+  |S of CS.sigma (** Substitution *)
+  |A of (symsubst * symsubst) (** Composition si (sj t) *)
+
+  (** Cartesian Product of two symbolic substitution sets *)
+val ( ++ ) : symsubst list -> symsubst list -> symsubst list
+
+  (** Evaluation of a substitution *)
+val (@@) : t -> symsubst -> t
+
+val domain : CS.sl -> Var.Set.t
+val codomain : CS.sl -> Var.Set.t
+val is_identity : CS.sl -> bool
+val identity : CS.sl
+val filter : (Var.t -> bool) -> CS.sl -> CS.sl
+
+(** 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 -> CS.sl
+val is_squaresubtype : Var.Set.t -> t -> t -> bool
+
+(** apply_raw s t returns the 4-tuple (subst,ss, tt, res) where
+   subst is the set of substitution that make the application succeed,
+   ss and tt are the expansions of s and t corresponding to that substitution
+   and res is the type of the result of the application *)
+val apply_full : Var.Set.t -> t -> t -> t
+
+val apply_raw : Var.Set.t -> t -> t -> CS.sl * t * t * t
+
+val squareapply : Var.Set.t -> t -> t -> (CS.sl * t)

types/types.ml

@@ -397,7 +397,7 @@ and VarRec : VarTypeSig with module Atom = Rec
 end
 
 module type VarType = VarTypeSig with type descr = Descr.t
-
+type var_type = (module VarType)
 
 module DescrHash = Hashtbl.Make(Descr)
 module DescrMap = Map.Make(Descr)

types/types.mli

@@ -69,20 +69,43 @@ end
 
 (** Algebra **)
 
-module VarAtoms : Bool.V with type Atom.t = Atoms.t
 
-module VarIntervals : Bool.V with type Atom.t = Intervals.t
+module Descr : Custom.T
 
-module VarChars : Bool.V with type Atom.t = Chars.t
+include Custom.T with type t = Descr.t
 
-module VarAbstracts: Bool.V with type Atom.t = Abstracts.t
-
-
-include Custom.T
 module Node : Custom.T
 
 type descr = t
 
+module type VarType = sig
+    include Bool.V
+    type descr = Descr.t
+    val inj : t -> descr
+    val proj : descr -> t
+    val update : descr -> t -> descr
+end
+
+type var_type = (module VarType)
+
+module VarAtoms : VarType with type Atom.t = Atoms.t
+
+module VarIntervals : VarType with type Atom.t = Intervals.t
+
+module VarChars : VarType with type Atom.t = Chars.t
+
+module VarAbstracts : VarType with type Atom.t = Abstracts.t
+
+module Pair : Bool.S with type elem = Node.t * Node.t
+module Rec : Bool.S with type elem = bool * Node.t Ident.LabelMap.map
+
+module VarTimes : VarType with module Atom = Pair
+module VarXml : VarType with module Atom = Pair
+module VarArrow : VarType with module Atom = Pair
+module VarRec : VarType with module Atom = Rec
+
+
+
 val make: unit -> Node.t
 val define: Node.t -> t -> unit
 
@@ -139,6 +162,15 @@ val rec_of_list: bool -> (bool * Ns.Label.t * t) list -> t
 val empty_closed_record: t
 val empty_open_record: t
 
+
+
+module Iter : sig
+    val simplify : t -> t
+    val map : ?abs:(bool -> bool) -> (var_type -> t -> t) -> t -> t
+    val iter : ?abs:(bool -> unit) ->(var_type -> t -> unit) -> t -> unit
+    val fold : ?abs:(bool -> 'a -> 'a) -> (var_type -> t -> 'a -> 'a) -> t -> 'a -> 'a
+end
+
 (** Positive systems and least solutions **)
 
 module Positive : sig
@@ -152,11 +184,18 @@ module Positive : sig
   val solve: v -> Node.t
 end
 
+module Variable : sig
+    val extract : t -> Var.var * bool
+end
+
 module Substitution : sig
   val full : t -> (Var.var * t) list -> t
   val single : t -> (Var.var * t) -> t
   val freshen : Var.Set.t -> t -> t
   val hide_vars : t -> t
+  val solve_rectype : t -> Var.var -> t
+  val kind : Var.Set.t -> Var.kind -> t -> t
+  val clean_type : Var.Set.t -> t -> t
 end
 
 
@@ -310,6 +349,13 @@ val subtype  : t -> t -> bool
 val disjoint : t -> t -> bool
 val equiv : t -> t -> bool
 
+(** intermediary representation for records *)
+
+(*** TODO : SEAL OFF *)
+
+val get_record : Rec.t -> (Label.t list * (bool * t array) * ((bool * t array) list)) list
+
+
 (** Tools for compilation of PM **)
 
 val cond_partition: t -> (t * t) list -> t list
@@ -352,112 +398,7 @@ module Cache : sig
   type 'a cache
   val emp: 'a cache
   val find: (t -> 'a) -> t -> 'a cache -> 'a cache * 'a
-
+  val lookup : t -> 'a cache -> 'a option
   val memo: (t -> 'a) -> (t -> 'a)
 end
 
-module Tallying : sig
-
-  type constr =
-  |Pos of (Var.var * t) (** alpha <= t | alpha \in P *)
-  |Neg of (t * Var.var) (** t <= alpha | alpha \in N *)
-
-  exception UnSatConstr of string
-  exception Step1Fail
-  exception Step2Fail
-
-  module CS : sig
-    module M : sig
-      type key = Var.var
-      type t
-      val compare  : t -> t -> int
-      val empty : t
-      val add : Var.Set.t -> key -> descr*descr -> t -> t
-      val singleton : key -> descr*descr -> t
-      val pp : Format.formatter -> t -> unit
-      val inter : Var.Set.t -> t -> t -> t
-    end
-    module E : sig
-      include Map.S with type key = Var.var
-      val pp : Format.formatter -> descr t -> unit
-    end
-    module ES : sig
-      include Set.S with type elt = descr E.t
-      val pp : Format.formatter -> t -> unit
-    end
-    module S : sig
-      type t = M.t list
-      val empty : t
-      val add : M.t -> t -> t
-      val singleton : M.t -> t
-      val union : t -> t -> t
-      val elements : t -> M.t list
-      val fold : (M.t -> 'b -> 'b) -> M.t list -> 'b -> 'b
-      val pp : Format.formatter -> t -> unit
-    end
-
-    type s = S.t
-    type m =  M.t
-    type es = ES.t
-    type sigma = t E.t
-    type sl = sigma list
-
-    val pp_s  : Format.formatter -> s -> unit
-    val pp_m  : Format.formatter -> m -> unit
-    val pp_e  : Format.formatter -> sigma -> unit
-    val pp_sl : Format.formatter -> sl -> unit
-
-    (* val merge : m -> m -> m *)
-    val singleton : constr -> s
-    val sat : s
-    val unsat : s
-    val union : s -> s -> s
-    val prod : Var.Set.t -> s -> s -> s
-  end
-
-  val norm : Var.Set.t -> t -> CS.s
-  val merge : Var.Set.t -> CS.m -> CS.s
-  val solve : Var.Set.t -> CS.s -> CS.es
-  val unify : CS.sigma -> CS.sigma
-
-  (* [s1 ... sn] . si is a solution for tallying problem
-     if si # delta and for all (s,t) in C si @ s < si @ t *)
-  val tallying : Var.Set.t -> (t * t) list -> CS.sl
-
-  val (>>) : t -> CS.sigma -> t
-
-  (** Symbolic Substitution Set *)
-  type symsubst =
-    |I (** Identity *)
-    |S of CS.sigma (** Substitution *)
-    |A of (symsubst * symsubst) (** Composition si (sj t) *)
-
-  (** Cartesian Product of two symbolic substitution sets *)
-  val ( ++ ) : symsubst list -> symsubst list -> symsubst list
-
-  (** Evaluation of a substitution *)
-  val (@@) : t -> symsubst -> t
-
-  val domain : CS.sl -> Var.Set.t
-  val codomain : CS.sl -> Var.Set.t
-  val is_identity : CS.sl -> bool
-  val identity : CS.sl
-  val filter : (Var.t -> bool) -> CS.sl -> CS.sl
-
-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
-val is_squaresubtype : Var.Set.t -> t -> t -> bool
-
-(** apply_raw s t returns the 4-tuple (subst,ss, tt, res) where
-   subst is the set of substitution that make the application succeed,
-   ss and tt are the expansions of s and t corresponding to that substitution
-   and res is the type of the result of the application *)
-val apply_full : Var.Set.t -> t -> t -> t
-
-val apply_raw : Var.Set.t -> t -> t -> Tallying.CS.sl * t * t * t
-
-val squareapply : Var.Set.t -> t -> t -> (Tallying.CS.sl * t)

typing/typed.ml

@@ -15,7 +15,7 @@ open Ident
 type tpat = Patterns.node
 type ttyp = Types.Node.t
 
-type sigma = Types.Tallying.CS.sl
+type sigma = Type_tallying.CS.sl
 
 type texpr  = 
     { exp_loc : loc; 
@@ -108,7 +108,7 @@ module Print = struct
 
   and pp_aux ppf e =
     match e.exp_descr with
-      | Subst(e,sl) -> Format.fprintf ppf "%a @@ %a" pp e Types.Tallying.CS.pp_sl sl
+      | Subst(e,sl) -> Format.fprintf ppf "%a @@ %a" pp e Type_tallying.CS.pp_sl sl
       | Forget(e, _) -> Format.fprintf ppf "Forget(%a)" pp e
       | Check(_, e, _) -> Format.fprintf ppf "Check(%a)" pp e
       | TVar(id, name) ->

typing/typer.ml

@@ -1078,7 +1078,7 @@ let verify loc t s =
   t
 
 let squareverify loc delta t s =
-  if not (Types.is_squaresubtype delta t s) then
+  if not (Type_tallying.is_squaresubtype delta t s) then
     raise_loc loc (Constraint (t, s));
   t
 
@@ -1147,7 +1147,7 @@ and type_check' loc env ed constr precise = match ed with
     in
     let t =
       (* try Types.Arrow.check_strenghten a.fun_typ constr *)
-      if Types.is_squaresubtype env.delta a.fun_typ constr then a.fun_typ
+      if Type_tallying.is_squaresubtype env.delta a.fun_typ constr then a.fun_typ
       else
         should_have loc constr
           "but the interface of the abstraction is not compatible"
@@ -1174,14 +1174,14 @@ and type_check' loc env ed constr precise = match ed with
           raise_loc loc (NonExhaustive (Types.diff t1 acc));
         let t = type_check_branches loc env t1 a.fun_body t2 true in
         try
-          (Types.squaresubtype env.delta t t2)::tacc (* H_j *)
+          (Type_tallying.squaresubtype env.delta t t2)::tacc (* H_j *)
         with
-          Types.Tallying.UnSatConstr _ ->
+          Type_tallying.UnSatConstr _ ->
             raise_loc loc (Constraint (t, t2))
       ) [] a.fun_iface
     in
     List.iter (fun sl ->
-      if not(Types.Tallying.is_identity sl) then
+      if not(Type_tallying.is_identity sl) then
         List.iter (fun br ->
           let e = br.br_body in
           let loc = br.br_body.exp_loc in
@@ -1220,8 +1220,8 @@ and type_check' loc env ed constr precise = match ed with
     let t1 = Types.Substitution.freshen env.delta t1 in
       (* t [_delta 0 -> 1 *)
     begin try
-            ignore(Types.Tallying.tallying env.delta [(t1,Types.Arrow.any)])
-      with Types.Tallying.UnSatConstr _ ->
+            ignore(Type_tallying.tallying env.delta [(t1,Types.Arrow.any)])
+      with Type_tallying.UnSatConstr _ ->
         raise_loc loc (Constraint (t1, Types.Arrow.any))
     end;
 
@@ -1233,12 +1233,12 @@ and type_check' loc env ed constr precise = match ed with
         not (Types.no_var t2) then
           (* get t2 without constraint check *)
           (* s [_delta dom(t) *)
-        try Types.squareapply env.delta t1 t2
-        with Types.Tallying.UnSatConstr msg ->
+        try Type_tallying.squareapply env.delta t1 t2
+        with Type_tallying.UnSatConstr msg ->
           raise_loc loc (Constraint (t2,dom))
       else begin
           (* Monomorphic case as before *)
-        let sl = Types.Tallying.identity in
+        let sl = Type_tallying.identity in
         if Types.Arrow.need_arg t1arrow then
           let t2 = type_check env e2 dom true in
           (sl,Types.Arrow.apply t1arrow t2)