Commit 92ada776 authored by Andrei Paskevich's avatar Andrei Paskevich

whyml: merge _tvs and _regs into one type "varset"

parent faf5d3e0
......@@ -58,6 +58,7 @@ module type S =
val diff : (key -> 'a -> 'b -> 'a option) -> 'a t -> 'b t -> 'a t
val submap : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool
val disjoint : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool
val set_union : 'a t -> 'a t -> 'a t
val set_inter : 'a t -> 'b t -> 'a t
val set_diff : 'a t -> 'b t -> 'a t
val set_submap : 'a t -> 'b t -> bool
......@@ -498,6 +499,7 @@ module Make(Ord: OrderedType) = struct
disjoint pr (Node (Empty, v1, d1, r1, 0)) r2 && disjoint pr l1 t2
let set_union m1 m2 = union (fun _ x _ -> Some x) m1 m2
let set_inter m1 m2 = inter (fun _ x _ -> Some x) m1 m2
let set_diff m1 m2 = diff (fun _ _ _ -> None) m1 m2
let set_submap m1 m2 = submap (fun _ _ _ -> true) m1 m2
......
......@@ -212,6 +212,9 @@ module type S =
(** [disjoint pr m1 m2] verifies that for every common key in m1
and m2, pr is verified. *)
val set_union : 'a t -> 'a t -> 'a t
(** [set_union = union (fun _ x _ -> Some x)] *)
val set_inter : 'a t -> 'b t -> 'a t
(** [set_inter = inter (fun _ x _ -> Some x)] *)
......
This diff is collapsed.
......@@ -43,9 +43,8 @@ val create_pvsymbol : preid -> vty_value -> pvsymbol
type pasymbol = private {
pa_name : ident;
pa_vta : vty_arrow;
pa_tvs : Stv.t;
pa_regs : Sreg.t;
(* these sets contain pa_vta.vta_tvs/regs together with all type
pa_vars : varset;
(* this varset contains pa_vta.vta_vars together with all type
variables and regions of the defining expression, in order to
cover effects and specification and not overgeneralize *)
}
......@@ -61,14 +60,13 @@ val pa_equal : pasymbol -> pasymbol -> bool
type psymbol = private {
ps_name : ident;
ps_vta : vty_arrow;
ps_tvs : Stv.t;
ps_regs : Sreg.t;
(* these sets cover the type variables and regions of the defining
ps_vars : varset;
(* this varset covers the type variables and regions of the defining
lambda that cannot be instantiated. Every other type variable
and region in ps_vty is generalized and can be instantiated. *)
ps_subst : ity_subst;
(* this substitution instantiates every type variable and region
in ps_tvs and ps_regs to itself *)
in ps_vars to itself *)
}
val ps_equal : psymbol -> psymbol -> bool
......@@ -123,8 +121,7 @@ type expr = private {
e_node : expr_node;
e_vty : vty;
e_effect : effect;
e_tvs : Stv.t Mid.t;
e_regs : Sreg.t Mid.t;
e_vars : varset Mid.t;
e_label : Slab.t;
e_loc : Loc.position option;
}
......@@ -138,7 +135,7 @@ and expr_node = private
| Elet of let_defn * expr
| Erec of rec_defn list * expr
| Eif of pvsymbol * expr * expr
| Ecase of pvsymbol * (pattern * expr) list
| Ecase of pvsymbol * (ppattern * expr) list
| Eassign of pvsymbol * region * pvsymbol (* mutable pv <- expr *)
and let_defn = private {
......@@ -153,8 +150,7 @@ and let_var =
and rec_defn = private {
rec_ps : psymbol;
rec_lambda : lambda;
rec_tvs : Stv.t Mid.t;
rec_regs : Sreg.t Mid.t;
rec_vars : varset Mid.t;
}
and lambda = {
......@@ -202,6 +198,7 @@ val e_let : let_defn -> expr -> expr
val e_rec : rec_defn list -> expr -> expr
val e_if : expr -> expr -> expr -> expr
val e_case : expr -> (ppattern * expr) list -> expr
exception Immutable of pvsymbol
......
......@@ -385,6 +385,33 @@ let ity_int = ity_of_ty Ty.ty_int
let ity_bool = ity_of_ty Ty.ty_bool
let ity_unit = ity_of_ty (Ty.ty_tuple [])
type varset = {
vars_tv : Stv.t;
vars_reg : Sreg.t;
}
let vars_empty = { vars_tv = Stv.empty ; vars_reg = Sreg.empty }
let ity_vars s ity = {
vars_tv = ity_freevars s.vars_tv ity;
vars_reg = ity_topregions s.vars_reg ity;
}
let vs_vars s vs = {
vars_tv = ty_freevars s.vars_tv vs.vs_ty;
vars_reg = s.vars_reg;
}
let vars_union s1 s2 = {
vars_tv = Stv.union s1.vars_tv s2.vars_tv;
vars_reg = Sreg.union s1.vars_reg s2.vars_reg;
}
let vars_freeze s =
let sbs = Stv.fold (fun v -> Mtv.add v (ity_var v)) s.vars_tv Mtv.empty in
let sbs = { ity_subst_tv = sbs ; ity_subst_reg = Mreg.empty } in
Sreg.fold (fun r s -> reg_match s r r) s.vars_reg sbs
(** computation types (with effects) *)
(* exception symbols *)
......@@ -495,8 +522,7 @@ type vty_value = {
vtv_ity : ity;
vtv_ghost : bool;
vtv_mut : region option;
vtv_tvs : Stv.t;
vtv_regs : Sreg.t;
vtv_vars : varset;
}
type vty =
......@@ -508,38 +534,33 @@ and vty_arrow = {
vta_result : vty;
vta_effect : effect;
vta_ghost : bool;
vta_tvs : Stv.t;
vta_regs : Sreg.t;
(* these sets cover every type variable and region in vta_arg
vta_vars : varset;
(* this varset covers every type variable and region in vta_arg
and vta_result, but may skip some type variables and regions
in vta_effect *)
}
(* smart constructors *)
let vty_freevars s = function
| VTvalue vtv -> Stv.union s vtv.vtv_tvs
| VTarrow vta -> Stv.union s vta.vta_tvs
let vty_topregions s = function
| VTvalue vtv -> Sreg.union s vtv.vtv_regs
| VTarrow vta -> Sreg.union s vta.vta_regs
let vty_vars s = function
| VTvalue vtv -> vars_union s vtv.vtv_vars
| VTarrow vta -> vars_union s vta.vta_vars
let vty_value ?(ghost=false) ?mut ity =
let regs = match mut with
let vars = ity_vars vars_empty ity in
let vars = match mut with
| Some r ->
if r.reg_ghost && not ghost then
Loc.errorm "Ghost region in a non-ghost vty_value";
ity_equal_check ity r.reg_ity;
Sreg.singleton r
{ vars with vars_reg = Sreg.add r vars.vars_reg }
| None ->
Sreg.empty
vars
in {
vtv_ity = ity;
vtv_ghost = ghost;
vtv_mut = mut;
vtv_tvs = ity_freevars Stv.empty ity;
vtv_regs = ity_topregions regs ity;
vtv_vars = vars;
}
let vty_arrow vtv ?(effect=eff_empty) ?(ghost=false) vty =
......@@ -549,17 +570,16 @@ let vty_arrow vtv ?(effect=eff_empty) ?(ghost=false) vty =
(* we accept a mutable vty_value for the result to simplify Mlw_expr,
but erase it in the signature: only projections return mutables *)
let vty = match vty with
| VTvalue ({ vtv_mut = Some r } as vtv) ->
let regs = Sreg.remove r vtv.vtv_regs in
VTvalue { vtv with vtv_mut = None ; vtv_regs = regs }
| VTvalue ({ vtv_mut = Some r ; vtv_vars = vars } as vtv) ->
let vars = { vars with vars_reg = Sreg.remove r vars.vars_reg } in
VTvalue { vtv with vtv_mut = None ; vtv_vars = vars }
| _ -> vty
in {
vta_arg = vtv;
vta_result = vty;
vta_effect = effect;
vta_ghost = ghost;
vta_tvs = vty_freevars vtv.vtv_tvs vty;
vta_regs = vty_topregions vtv.vtv_regs vty;
vta_vars = vty_vars vtv.vtv_vars vty;
}
let vty_ghost = function
......
......@@ -153,6 +153,21 @@ val ity_full_inst : ity_subst -> ity -> ity
val reg_full_inst : ity_subst -> region -> region
type varset = private {
vars_tv : Stv.t;
vars_reg : Sreg.t;
}
val vars_empty : varset
val vars_union : varset -> varset -> varset
val vars_freeze : varset -> ity_subst
val ity_vars : varset -> ity -> varset
val vs_vars : varset -> vsymbol -> varset
(* exception symbols *)
type xsymbol = private {
xs_name : ident;
......@@ -194,8 +209,7 @@ type vty_value = private {
vtv_ity : ity;
vtv_ghost : bool;
vtv_mut : region option;
vtv_tvs : Stv.t;
vtv_regs : Sreg.t;
vtv_vars : varset;
}
type vty =
......@@ -207,9 +221,8 @@ and vty_arrow = private {
vta_result : vty;
vta_effect : effect;
vta_ghost : bool;
vta_tvs : Stv.t;
vta_regs : Sreg.t;
(* these sets cover every type variable and region in vta_arg
vta_vars : varset;
(* this varset covers every type variable and region in vta_arg
and vta_result, but may skip some type variables and regions
in vta_effect *)
}
......@@ -222,8 +235,7 @@ val vty_arrow : vty_value -> ?effect:effect -> ?ghost:bool -> vty -> vty_arrow
val vty_app_arrow : vty_arrow -> vty_value -> effect * vty
val vty_freevars : Stv.t -> vty -> Stv.t
val vty_topregions : Sreg.t -> vty -> Sreg.t
val vty_vars : varset -> vty -> varset
val vty_ghost : vty -> bool
val vty_ghostify : vty -> vty
......
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