Attention une mise à jour du service Gitlab va être effectuée le mardi 30 novembre entre 17h30 et 18h00. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes. Cette mise à jour intermédiaire en version 14.0.12 nous permettra de rapidement pouvoir mettre à votre disposition une version plus récente.

Commit 18e0cb5a authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

whyml: fix cloning of letrec

parent 8e1e6d69
...@@ -323,6 +323,16 @@ type psymbol = { ...@@ -323,6 +323,16 @@ type psymbol = {
ps_subst : ity_subst; ps_subst : ity_subst;
} }
module Psym = WeakStructMake (struct
type t = psymbol
let tag ps = ps.ps_name.id_tag
end)
module Sps = Psym.S
module Mps = Psym.M
module Hps = Psym.H
module Wps = Psym.W
let ps_equal : psymbol -> psymbol -> bool = (==) let ps_equal : psymbol -> psymbol -> bool = (==)
let create_psymbol_real ~poly id vta varm = let create_psymbol_real ~poly id vta varm =
...@@ -339,10 +349,15 @@ let create_psymbol_mono = create_psymbol_real ~poly:false ...@@ -339,10 +349,15 @@ let create_psymbol_mono = create_psymbol_real ~poly:false
(** specification *) (** specification *)
let varmap_union = Mid.set_union
let add_pv_vars pv m = Mid.add pv.pv_vs.vs_name pv.pv_vars m let add_pv_vars pv m = Mid.add pv.pv_vs.vs_name pv.pv_vars m
let add_vs_vars vs _ m = add_pv_vars (restore_pv vs) m let add_vs_vars vs _ m = add_pv_vars (restore_pv vs) m
let add_t_vars vss m = Mvs.fold add_vs_vars vss m let add_t_vars vss m = Mvs.fold add_vs_vars vss m
let add_ps_vars ps m =
Mid.add ps.ps_name ps.ps_vars (varmap_union ps.ps_varm m)
let pre_vars f vsset = Mvs.set_union vsset f.t_vars let pre_vars f vsset = Mvs.set_union vsset f.t_vars
let post_vars f vsset = Mvs.set_union vsset f.t_vars let post_vars f vsset = Mvs.set_union vsset f.t_vars
let xpost_vars = Mexn.fold (fun _ -> post_vars) let xpost_vars = Mexn.fold (fun _ -> post_vars)
...@@ -394,6 +409,14 @@ let create_psymbol id vta = ...@@ -394,6 +409,14 @@ let create_psymbol id vta =
vta_check ps.ps_vars vta; vta_check ps.ps_vars vta;
ps ps
let create_psymbol_extra id vta pvs pss =
let varm = vta_varmap vta in
let varm = Spv.fold add_pv_vars pvs varm in
let varm = Sps.fold add_ps_vars pss varm in
let ps = create_psymbol_poly id vta varm in
vta_check ps.ps_vars vta;
ps
(** program expressions *) (** program expressions *)
type assertion_kind = Aassert | Aassume | Acheck type assertion_kind = Aassert | Aassume | Acheck
...@@ -483,7 +506,6 @@ let vta_of_expr e = match e.e_vty with ...@@ -483,7 +506,6 @@ let vta_of_expr e = match e.e_vty with
| VTvalue _ -> Loc.error ?loc:e.e_loc (ArrowExpected e) | VTvalue _ -> Loc.error ?loc:e.e_loc (ArrowExpected e)
| VTarrow vta -> vta | VTarrow vta -> vta
let varmap_union = Mid.set_union
let add_e_vars e m = varmap_union e.e_varm m let add_e_vars e m = varmap_union e.e_varm m
(* check admissibility of consecutive events *) (* check admissibility of consecutive events *)
...@@ -541,8 +563,8 @@ let e_value pv = ...@@ -541,8 +563,8 @@ let e_value pv =
mk_expr (Evalue pv) (VTvalue pv.pv_vtv) eff_empty varm mk_expr (Evalue pv) (VTvalue pv.pv_vtv) eff_empty varm
let e_arrow ps vta = let e_arrow ps vta =
let varm = add_ps_vars ps Mid.empty in
let sbs = vta_vars_match ps.ps_subst ps.ps_vta vta in let sbs = vta_vars_match ps.ps_subst ps.ps_vta vta in
let varm = Mid.add ps.ps_name ps.ps_vars ps.ps_varm in
let vta = vta_full_inst sbs ps.ps_vta in let vta = vta_full_inst sbs ps.ps_vta in
mk_expr (Earrow ps) (VTarrow vta) eff_empty varm mk_expr (Earrow ps) (VTarrow vta) eff_empty varm
......
...@@ -109,10 +109,17 @@ type psymbol = private { ...@@ -109,10 +109,17 @@ type psymbol = private {
in ps_vars to itself *) in ps_vars to itself *)
} }
module Mps : Map.S with type key = psymbol
module Sps : Mps.Set
module Hps : Hashtbl.S with type key = psymbol
module Wps : Hashweak.S with type key = psymbol
val ps_equal : psymbol -> psymbol -> bool val ps_equal : psymbol -> psymbol -> bool
val create_psymbol : preid -> vty_arrow -> psymbol val create_psymbol : preid -> vty_arrow -> psymbol
val create_psymbol_extra : preid -> vty_arrow -> Spv.t -> Sps.t -> psymbol
(** program expressions *) (** program expressions *)
type assertion_kind = Aassert | Aassume | Acheck type assertion_kind = Aassert | Aassume | Acheck
......
...@@ -446,39 +446,32 @@ let clone_export uc m inst = ...@@ -446,39 +446,32 @@ let clone_export uc m inst =
Hid.add psh ps.ps_name (PS nps); Hid.add psh ps.ps_name (PS nps);
add_pdecl uc (create_val_decl (LetA nps)) add_pdecl uc (create_val_decl (LetA nps))
| PDrec { rec_defn = rdl } -> | PDrec { rec_defn = rdl } ->
(* FIXME: the resulting psymbols are as polymorphic as let add_id id _ (pvs,pss) =
their ps_vta allow them to be. If the definition body try match Hid.find psh id with
brings in some external symbol S and fixes some region | PV pv -> Spv.add pv pvs, pss
in the psymbol's type, but S does not occur in the spec, | PS ps -> pvs, Sps.add ps pss
then the cloned psymbol will be overgeneralized. | _ -> assert false
Three fixes are possible: with Not_found ->
1. Prohibit global regions in psymbol type signatures. let exn = Invalid_argument "Mlw_module.clone_export" in
This is what previous implementation of WhyML did. begin match (Mid.find_exn exn id extras).pd_node with
2. Let Mlw_expr.create_psymbol take an additional varmap | PDval (LetV pv) | PDlet { let_sym = LetV pv } ->
as an argument and add those variables to ps.ps_varm. Spv.add pv pvs, pss
Can this be abused in any way? | PDval (LetA ps) | PDlet { let_sym = LetA ps } ->
3. Require that (vta_varmap ps.ps_vta) fixes exactly pvs, Sps.add ps pss
the same regions as ps.ps_varm. At the moment, we | PDrec { rec_defn = rdl } ->
only have inclusion, since ps.ps_varm is guaranteed let rec down = function
to be a superset of (vta_varmap ps.ps_vta). If this | { fun_ps = ps }::_ when id_equal ps.ps_name id -> ps
requirement is satisfied, we can always set ps_varm | _::rdl -> down rdl
to be the varmap of ps_vta. But what about resets? | [] -> assert false in
Consider: pvs, Sps.add (down rdl) pss
let r <rho> = ref 0 in | PDtype _ | PDdata _ | PDexn _ -> assert false
let f x = ... r <- x ... in end in
{ reset rho }
f 5
The reference r appears in f.ps_varm, and thus the
last expression (f 5) would be rejected as freshness
violation. This is correct, otherwise the effect of
(f 5) could modify the values of unrelated variables.
This is correct even if r does not occur in f.ps_vta,
and therefore we cannot forget about r in f.ps_varm.
We could require that r appears in the spec of f, as
we do for abstract parameters, but is this reasonable? *)
let conv_rd uc { fun_ps = ps } = let conv_rd uc { fun_ps = ps } =
let id = id_clone ps.ps_name in
let vta = conv_vta !mvs ps.ps_vta in let vta = conv_vta !mvs ps.ps_vta in
let nps = create_psymbol (id_clone ps.ps_name) vta in (* we must retrieve all pvsymbols and psymbols in ps.ps_varm *)
let pvs,pss = Mid.fold add_id ps.ps_varm (Spv.empty,Sps.empty) in
let nps = create_psymbol_extra id vta pvs pss in
Hid.add psh ps.ps_name (PS nps); Hid.add psh ps.ps_name (PS nps);
add_pdecl uc (create_val_decl (LetA nps)) in add_pdecl uc (create_val_decl (LetA nps)) in
List.fold_left conv_rd uc rdl List.fold_left conv_rd uc rdl
......
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