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

src/util/stdlib.ml

@@ -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

src/util/stdlib.mli

@@ -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)] *)
 

src/whyml/mlw_expr.mli

@@ -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
 

src/whyml/mlw_ty.ml

@@ -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

src/whyml/mlw_ty.mli

@@ -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