Commit 32780738 by Kim Nguyễn

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

parent ae31d5c7
......@@ -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 \
......
......@@ -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)
......
......@@ -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"
......
......@@ -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)
......
......@@ -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
......
......@@ -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) ->
......
......@@ -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
......
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)
......@@ -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)
......
......@@ -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)
......@@ -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) ->
......
......@@ -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)
......
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