renamed Mexn -> Mxs

parent 4ba12926
...@@ -375,7 +375,7 @@ type 'a later = pvsymbol Mstr.t -> register_old -> 'a ...@@ -375,7 +375,7 @@ type 'a later = pvsymbol Mstr.t -> register_old -> 'a
type dspec_final = { type dspec_final = {
ds_pre : term list; ds_pre : term list;
ds_post : (pvsymbol * term) list; ds_post : (pvsymbol * term) list;
ds_xpost : (pvsymbol * term) list Mexn.t; ds_xpost : (pvsymbol * term) list Mxs.t;
ds_reads : pvsymbol list; ds_reads : pvsymbol list;
ds_writes : term list; ds_writes : term list;
ds_diverge : bool; ds_diverge : bool;
...@@ -775,7 +775,7 @@ let create_invariant pl = List.map to_fmla pl ...@@ -775,7 +775,7 @@ let create_invariant pl = List.map to_fmla pl
let create_post ity ql = List.map (fun (v,f) -> let create_post ity ql = List.map (fun (v,f) ->
ity_equal_check ity v.pv_ity; Ity.create_post v.pv_vs (to_fmla f)) ql ity_equal_check ity v.pv_ity; Ity.create_post v.pv_vs (to_fmla f)) ql
let create_xpost xql = Mexn.mapi (fun xs ql -> create_post xs.xs_ity ql) xql let create_xpost xql = Mxs.mapi (fun xs ql -> create_post xs.xs_ity ql) xql
(** User effects *) (** User effects *)
...@@ -815,7 +815,7 @@ let effect_of_dspec dsp = ...@@ -815,7 +815,7 @@ let effect_of_dspec dsp =
| _ -> | _ ->
Loc.errorm ?loc:t.t_loc "mutable expression expected" in Loc.errorm ?loc:t.t_loc "mutable expression expected" in
let wl, eff = List.fold_left add_write ([], eff_read pvs) dsp.ds_writes in let wl, eff = List.fold_left add_write ([], eff_read pvs) dsp.ds_writes in
let eff = Mexn.fold (fun xs _ eff -> eff_raise eff xs) dsp.ds_xpost eff in let eff = Mxs.fold (fun xs _ eff -> eff_raise eff xs) dsp.ds_xpost eff in
let eff = if dsp.ds_diverge then eff_diverge eff else eff in let eff = if dsp.ds_diverge then eff_diverge eff else eff in
wl, eff wl, eff
...@@ -824,8 +824,8 @@ let effect_of_dspec dsp = ...@@ -824,8 +824,8 @@ let effect_of_dspec dsp =
let check_spec inr dsp ecty ({e_loc = loc} as e) = let check_spec inr dsp ecty ({e_loc = loc} as e) =
let bad_read reff eff = not (Spv.subset reff.eff_reads eff.eff_reads) in let bad_read reff eff = not (Spv.subset reff.eff_reads eff.eff_reads) in
let bad_write weff eff = not (Mreg.submap (fun _ s1 s2 -> Spv.subset s1 s2) let bad_write weff eff = not (Mreg.submap (fun _ s1 s2 -> Spv.subset s1 s2)
weff.eff_writes eff.eff_writes) in weff.eff_writes eff.eff_writes) in
let bad_raise xeff eff = not (Sexn.subset xeff.eff_raises eff.eff_raises) in let bad_raise xeff eff = not (Sxs.subset xeff.eff_raises eff.eff_raises) in
(* computed effect vs user effect *) (* computed effect vs user effect *)
let uwrl, ue = effect_of_dspec dsp in let uwrl, ue = effect_of_dspec dsp in
let ucty = create_cty ecty.cty_args ecty.cty_pre ecty.cty_post let ucty = create_cty ecty.cty_args ecty.cty_pre ecty.cty_post
...@@ -847,7 +847,7 @@ let check_spec inr dsp ecty ({e_loc = loc} as e) = ...@@ -847,7 +847,7 @@ let check_spec inr dsp ecty ({e_loc = loc} as e) =
"this@ write@ effect@ does@ not@ happen@ in@ the@ expression") uwrl; "this@ write@ effect@ does@ not@ happen@ in@ the@ expression") uwrl;
if check_ue && bad_raise ueff eeff then Loc.errorm ?loc if check_ue && bad_raise ueff eeff then Loc.errorm ?loc
"this@ expression@ does@ not@ raise@ exception@ %a" "this@ expression@ does@ not@ raise@ exception@ %a"
print_xs (Sexn.choose (Sexn.diff ueff.eff_raises eeff.eff_raises)); print_xs (Sxs.choose (Sxs.diff ueff.eff_raises eeff.eff_raises));
if check_ue && ueff.eff_oneway && not eeff.eff_oneway then Loc.errorm ?loc if check_ue && ueff.eff_oneway && not eeff.eff_oneway then Loc.errorm ?loc
"this@ expression@ does@ not@ diverge"; "this@ expression@ does@ not@ diverge";
(* check that every computed effect is listed *) (* check that every computed effect is listed *)
...@@ -858,10 +858,10 @@ let check_spec inr dsp ecty ({e_loc = loc} as e) = ...@@ -858,10 +858,10 @@ let check_spec inr dsp ecty ({e_loc = loc} as e) =
if check_rw && bad_write eeff ueff then if check_rw && bad_write eeff ueff then
Loc.errorm ?loc:(e_locate_effect (fun eff -> bad_write eff ueff) e) Loc.errorm ?loc:(e_locate_effect (fun eff -> bad_write eff ueff) e)
"this@ expression@ produces@ an@ unlisted@ write@ effect"; "this@ expression@ produces@ an@ unlisted@ write@ effect";
if ecty.cty_args <> [] && bad_raise eeff ueff then Sexn.iter (fun xs -> if ecty.cty_args <> [] && bad_raise eeff ueff then Sxs.iter (fun xs ->
Loc.errorm ?loc:(e_locate_effect (fun eff -> Sexn.mem xs eff.eff_raises) e) Loc.errorm ?loc:(e_locate_effect (fun eff -> Sxs.mem xs eff.eff_raises) e)
"this@ expression@ raises@ unlisted@ exception@ %a" "this@ expression@ raises@ unlisted@ exception@ %a"
print_xs xs) (Sexn.diff eeff.eff_raises ueff.eff_raises); print_xs xs) (Sxs.diff eeff.eff_raises ueff.eff_raises);
if eeff.eff_oneway && not ueff.eff_oneway then if eeff.eff_oneway && not ueff.eff_oneway then
Loc.errorm ?loc:(e_locate_effect (fun eff -> eff.eff_oneway) e) Loc.errorm ?loc:(e_locate_effect (fun eff -> eff.eff_oneway) e)
"this@ expression@ may@ diverge,@ but@ this@ is@ not@ \ "this@ expression@ may@ diverge,@ but@ this@ is@ not@ \
...@@ -1210,8 +1210,8 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) = ...@@ -1210,8 +1210,8 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
let vm, pat = create_prog_pattern dp.dp_pat xs.xs_ity mask in let vm, pat = create_prog_pattern dp.dp_pat xs.xs_ity mask in
let e = expr uloc (add_pv_map env vm) de in let e = expr uloc (add_pv_map env vm) de in
Mstr.iter (fun _ v -> check_used_pv e v) vm; Mstr.iter (fun _ v -> check_used_pv e v) vm;
Mexn.add xs ((pat, e) :: Mexn.find_def [] xs m) m in Mxs.add xs ((pat, e) :: Mxs.find_def [] xs m) m in
let xsm = List.fold_left add_branch Mexn.empty bl in let xsm = List.fold_left add_branch Mxs.empty bl in
let is_simple p = match p.pat_node with let is_simple p = match p.pat_node with
| Papp (fs,[]) -> is_fs_tuple fs | Papp (fs,[]) -> is_fs_tuple fs
| Pvar _ | Pwild -> true | _ -> false in | Pvar _ | Pwild -> true | _ -> false in
...@@ -1259,7 +1259,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) = ...@@ -1259,7 +1259,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
let _,pp = create_prog_pattern PPwild xs.xs_ity mask in let _,pp = create_prog_pattern PPwild xs.xs_ity mask in
(pp, e_raise xs e (ity_of_dity res)) :: bl in (pp, e_raise xs e (ity_of_dity res)) :: bl in
vl, e_case e (List.rev bl) in vl, e_case e (List.rev bl) in
e_try e1 (Mexn.mapi mk_branch xsm) e_try e1 (Mxs.mapi mk_branch xsm)
| DEraise (xs,de) -> | DEraise (xs,de) ->
e_raise xs (expr uloc env de) (ity_of_dity res) e_raise xs (expr uloc env de) (ity_of_dity res)
| DEghost de -> | DEghost de ->
...@@ -1301,7 +1301,7 @@ and rec_defn uloc ({inr = inr} as env) {fds = dfdl} = ...@@ -1301,7 +1301,7 @@ and rec_defn uloc ({inr = inr} as env) {fds = dfdl} =
let ghost = env.ghs || gh || kind = RKlemma in let ghost = env.ghs || gh || kind = RKlemma in
let pvl = binders ghost bl in let pvl = binders ghost bl in
let ity = Loc.try1 ?loc:de.de_loc ity_of_dity (dity_of_dvty dvty) in let ity = Loc.try1 ?loc:de.de_loc ity_of_dity (dity_of_dvty dvty) in
let cty = create_cty ~mask pvl [] [] Mexn.empty Mpv.empty eff_empty ity in let cty = create_cty ~mask pvl [] [] Mxs.empty Mpv.empty eff_empty ity in
let rs = create_rsymbol id ~ghost ~kind:RKnone cty in let rs = create_rsymbol id ~ghost ~kind:RKnone cty in
add_rsymbol env rs, (rs, kind, mask, dsp, dvl, de) in add_rsymbol env rs, (rs, kind, mask, dsp, dvl, de) in
let env, fdl = Lists.map_fold_left step1 {env with inr = true} dfdl in let env, fdl = Lists.map_fold_left step1 {env with inr = true} dfdl in
...@@ -1374,7 +1374,7 @@ let let_defn ?(keep_loc=true) (id, ghost, kind, de) = ...@@ -1374,7 +1374,7 @@ let let_defn ?(keep_loc=true) (id, ghost, kind, de) =
let e = expr uloc env_empty de in let e = expr uloc env_empty de in
if mask_ghost e.e_mask && not ghost then Loc.errorm ?loc if mask_ghost e.e_mask && not ghost then Loc.errorm ?loc
"Function %s must be explicitly marked ghost" nm; "Function %s must be explicitly marked ghost" nm;
let c = c_fun [] [] [] Mexn.empty Mpv.empty e in let c = c_fun [] [] [] Mxs.empty Mpv.empty e in
(* the rsymbol will carry a single postcondition "the result (* the rsymbol will carry a single postcondition "the result
is equal to the logical constant". Any user-written spec is equal to the logical constant". Any user-written spec
will be checked once, in-place, under Eexec. Since kind will be checked once, in-place, under Eexec. Since kind
......
...@@ -64,7 +64,7 @@ type 'a later = pvsymbol Mstr.t -> register_old -> 'a ...@@ -64,7 +64,7 @@ type 'a later = pvsymbol Mstr.t -> register_old -> 'a
type dspec_final = { type dspec_final = {
ds_pre : term list; ds_pre : term list;
ds_post : (pvsymbol * term) list; ds_post : (pvsymbol * term) list;
ds_xpost : (pvsymbol * term) list Mexn.t; ds_xpost : (pvsymbol * term) list Mxs.t;
ds_reads : pvsymbol list; ds_reads : pvsymbol list;
ds_writes : term list; ds_writes : term list;
ds_diverge : bool; ds_diverge : bool;
......
...@@ -171,7 +171,7 @@ let create_projection s v = ...@@ -171,7 +171,7 @@ let create_projection s v =
let arg = create_pvsymbol (id_fresh "arg") ity in let arg = create_pvsymbol (id_fresh "arg") ity in
let ls = create_fsymbol id [arg.pv_vs.vs_ty] v.pv_vs.vs_ty in let ls = create_fsymbol id [arg.pv_vs.vs_ty] v.pv_vs.vs_ty in
let q = make_post (fs_app ls [t_var arg.pv_vs] v.pv_vs.vs_ty) in let q = make_post (fs_app ls [t_var arg.pv_vs] v.pv_vs.vs_ty) in
let c = create_cty [arg] [] [q] Mexn.empty Mpv.empty eff v.pv_ity in let c = create_cty [arg] [] [q] Mxs.empty Mpv.empty eff v.pv_ity in
mk_rs ls.ls_name c (RLls ls) (Some v) mk_rs ls.ls_name c (RLls ls) (Some v)
exception FieldExpected of rsymbol exception FieldExpected of rsymbol
...@@ -198,7 +198,7 @@ let create_constructor ~constr id s fl = ...@@ -198,7 +198,7 @@ let create_constructor ~constr id s fl =
let eff = match ity.ity_node with let eff = match ity.ity_node with
| Ityreg r -> eff_reset eff_empty (Sreg.singleton r) | Ityreg r -> eff_reset eff_empty (Sreg.singleton r)
| _ -> eff_empty in | _ -> eff_empty in
let c = create_cty fl [] [q] Mexn.empty Mpv.empty eff ity in let c = create_cty fl [] [q] Mxs.empty Mpv.empty eff ity in
mk_rs ls.ls_name c (RLls ls) None mk_rs ls.ls_name c (RLls ls) None
let rs_of_ls ls = let rs_of_ls ls =
...@@ -207,7 +207,7 @@ let rs_of_ls ls = ...@@ -207,7 +207,7 @@ let rs_of_ls ls =
let t_args = List.map (fun v -> t_var v.pv_vs) v_args in let t_args = List.map (fun v -> t_var v.pv_vs) v_args in
let q = make_post (t_app ls t_args ls.ls_value) in let q = make_post (t_app ls t_args ls.ls_value) in
let ity = ity_of_ty (t_type q) in let ity = ity_of_ty (t_type q) in
let c = create_cty v_args [] [q] Mexn.empty Mpv.empty eff_empty ity in let c = create_cty v_args [] [q] Mxs.empty Mpv.empty eff_empty ity in
mk_rs ls.ls_name c (RLls ls) None mk_rs ls.ls_name c (RLls ls) None
(** {2 Program patterns} *) (** {2 Program patterns} *)
...@@ -310,7 +310,7 @@ and expr_node = ...@@ -310,7 +310,7 @@ and expr_node =
| Ecase of expr * (prog_pattern * expr) list | Ecase of expr * (prog_pattern * expr) list
| Ewhile of expr * invariant list * variant list * expr | Ewhile of expr * invariant list * variant list * expr
| Efor of pvsymbol * for_bounds * invariant list * expr | Efor of pvsymbol * for_bounds * invariant list * expr
| Etry of expr * (pvsymbol list * expr) Mexn.t | Etry of expr * (pvsymbol list * expr) Mxs.t
| Eraise of xsymbol * expr | Eraise of xsymbol * expr
| Eassert of assertion_kind * term | Eassert of assertion_kind * term
| Eghost of expr | Eghost of expr
...@@ -375,7 +375,7 @@ let e_fold fn acc e = match e.e_node with ...@@ -375,7 +375,7 @@ let e_fold fn acc e = match e.e_node with
| Elet (LDvar (_,d), e) | Ewhile (d,_,_,e) -> fn (fn acc d) e | Elet (LDvar (_,d), e) | Ewhile (d,_,_,e) -> fn (fn acc d) e
| Eif (c,d,e) -> fn (fn (fn acc c) d) e | Eif (c,d,e) -> fn (fn (fn acc c) d) e
| Ecase (d,bl) -> List.fold_left (fun acc (_,e) -> fn acc e) (fn acc d) bl | Ecase (d,bl) -> List.fold_left (fun acc (_,e) -> fn acc e) (fn acc d) bl
| Etry (d,xl) -> Mexn.fold (fun _ (_,e) acc -> fn acc e) xl (fn acc d) | Etry (d,xl) -> Mxs.fold (fun _ (_,e) acc -> fn acc e) xl (fn acc d)
exception FoundExpr of Loc.position option * expr exception FoundExpr of Loc.position option * expr
...@@ -732,7 +732,7 @@ let c_pur s vl ityl ity = ...@@ -732,7 +732,7 @@ let c_pur s vl ityl ity =
let res = Opt.map (fun _ -> ty_of_ity ity) s.ls_value in let res = Opt.map (fun _ -> ty_of_ity ity) s.ls_value in
let q = make_post (t_app s t_args res) in let q = make_post (t_app s t_args res) in
let eff = eff_ghostify true eff_empty in let eff = eff_ghostify true eff_empty in
let cty = create_cty v_args [] [q] Mexn.empty Mpv.empty eff ity in let cty = create_cty v_args [] [q] Mxs.empty Mpv.empty eff ity in
mk_cexp (Cpur (s,vl)) cty mk_cexp (Cpur (s,vl)) cty
let mk_proxy ghost e hd = match e.e_node with let mk_proxy ghost e hd = match e.e_node with
...@@ -806,7 +806,7 @@ let rs_func_app = rs_of_ls fs_func_app ...@@ -806,7 +806,7 @@ let rs_func_app = rs_of_ls fs_func_app
let ld_func_app = let ld_func_app =
let v_args = rs_func_app.rs_cty.cty_args in let v_args = rs_func_app.rs_cty.cty_args in
let ity = rs_func_app.rs_cty.cty_result in let ity = rs_func_app.rs_cty.cty_result in
let c = create_cty v_args [] [] Mexn.empty Mpv.empty eff_empty ity in let c = create_cty v_args [] [] Mxs.empty Mpv.empty eff_empty ity in
LDsym (rs_func_app, c_any c) LDsym (rs_func_app, c_any c)
let e_func_app fn e = let e_func_app fn e =
...@@ -906,19 +906,19 @@ let e_try e xl = ...@@ -906,19 +906,19 @@ let e_try e xl =
| [v] -> v.pv_ity, mask_of_pv v | [v] -> v.pv_ity, mask_of_pv v
| vl -> ity_tuple (List.map (fun v -> v.pv_ity) vl), | vl -> ity_tuple (List.map (fun v -> v.pv_ity) vl),
MaskTuple (List.map mask_of_pv vl) in MaskTuple (List.map mask_of_pv vl) in
Mexn.iter (fun xs (vl,d) -> Mxs.iter (fun xs (vl,d) ->
let ity, mask = get_mask vl in let ity, mask = get_mask vl in
if mask_spill xs.xs_mask mask then if mask_spill xs.xs_mask mask then
Loc.errorm "Non-ghost pattern in a ghost position"; Loc.errorm "Non-ghost pattern in a ghost position";
ity_equal_check ity xs.xs_ity; ity_equal_check ity xs.xs_ity;
ity_equal_check d.e_ity e.e_ity) xl; ity_equal_check d.e_ity e.e_ity) xl;
let ghost = e.e_effect.eff_ghost in let ghost = e.e_effect.eff_ghost in
let eeff = Mexn.fold (fun xs _ eff -> let eeff = Mxs.fold (fun xs _ eff ->
eff_catch eff xs) xl e.e_effect in eff_catch eff xs) xl e.e_effect in
let dl = Mexn.fold (fun _ (_,d) l -> d::l) xl [] in let dl = Mxs.fold (fun _ (_,d) l -> d::l) xl [] in
let add_mask mask d = mask_union mask d.e_mask in let add_mask mask d = mask_union mask d.e_mask in
let mask = List.fold_left add_mask e.e_mask dl in let mask = List.fold_left add_mask e.e_mask dl in
let xeff = Mexn.fold (fun _ (vl,d) eff -> let xeff = Mxs.fold (fun _ (vl,d) eff ->
let add s v = Spv.add_new (Invalid_argument "Expr.e_try") v s in let add s v = Spv.add_new (Invalid_argument "Expr.e_try") v s in
let deff = eff_bind (List.fold_left add Spv.empty vl) d.e_effect in let deff = eff_bind (List.fold_left add Spv.empty vl) d.e_effect in
try_effect dl eff_union_par eff deff) xl eff_empty in try_effect dl eff_union_par eff deff) xl eff_empty in
...@@ -984,7 +984,7 @@ let rec e_rs_subst sm e = e_label_copy e (match e.e_node with ...@@ -984,7 +984,7 @@ let rec e_rs_subst sm e = e_label_copy e (match e.e_node with
| Ecase (d,bl) -> e_case (e_rs_subst sm d) | Ecase (d,bl) -> e_case (e_rs_subst sm d)
(List.map (fun (pp,e) -> pp, e_rs_subst sm e) bl) (List.map (fun (pp,e) -> pp, e_rs_subst sm e) bl)
| Etry (d,xl) -> e_try (e_rs_subst sm d) | Etry (d,xl) -> e_try (e_rs_subst sm d)
(Mexn.map (fun (v,e) -> v, e_rs_subst sm e) xl)) (Mxs.map (fun (v,e) -> v, e_rs_subst sm e) xl))
and c_rs_subst sm ({c_node = n; c_cty = c} as d) = match n with and c_rs_subst sm ({c_node = n; c_cty = c} as d) = match n with
| Cany | Cpur _ -> d | Cany | Cpur _ -> d
...@@ -1311,7 +1311,7 @@ and print_enode pri fmt e = match e.e_node with ...@@ -1311,7 +1311,7 @@ and print_enode pri fmt e = match e.e_node with
| Eraise (xs,e) -> | Eraise (xs,e) ->
fprintf fmt "raise (%a %a)" print_xs xs print_expr e fprintf fmt "raise (%a %a)" print_xs xs print_expr e
| Etry (e,bl) -> | Etry (e,bl) ->
let bl = Mexn.bindings bl in let bl = Mxs.bindings bl in
fprintf fmt "try %a with@\n@[<hov>%a@]@\nend" fprintf fmt "try %a with@\n@[<hov>%a@]@\nend"
print_expr e (Pp.print_list Pp.newline print_xbranch) bl print_expr e (Pp.print_list Pp.newline print_xbranch) bl
| Eabsurd -> | Eabsurd ->
......
...@@ -124,7 +124,7 @@ and expr_node = private ...@@ -124,7 +124,7 @@ and expr_node = private
| Ecase of expr * (prog_pattern * expr) list | Ecase of expr * (prog_pattern * expr) list
| Ewhile of expr * invariant list * variant list * expr | Ewhile of expr * invariant list * variant list * expr
| Efor of pvsymbol * for_bounds * invariant list * expr | Efor of pvsymbol * for_bounds * invariant list * expr
| Etry of expr * (pvsymbol list * expr) Mexn.t | Etry of expr * (pvsymbol list * expr) Mxs.t
| Eraise of xsymbol * expr | Eraise of xsymbol * expr
| Eassert of assertion_kind * term | Eassert of assertion_kind * term
| Eghost of expr | Eghost of expr
...@@ -182,7 +182,7 @@ val c_app : rsymbol -> pvsymbol list -> ity list -> ity -> cexp ...@@ -182,7 +182,7 @@ val c_app : rsymbol -> pvsymbol list -> ity list -> ity -> cexp
val c_pur : lsymbol -> pvsymbol list -> ity list -> ity -> cexp val c_pur : lsymbol -> pvsymbol list -> ity list -> ity -> cexp
val c_fun : ?mask:mask -> pvsymbol list -> val c_fun : ?mask:mask -> pvsymbol list ->
pre list -> post list -> post list Mexn.t -> pvsymbol Mpv.t -> expr -> cexp pre list -> post list -> post list Mxs.t -> pvsymbol Mpv.t -> expr -> cexp
val c_any : cty -> cexp val c_any : cty -> cexp
...@@ -218,7 +218,7 @@ val is_e_false : expr -> bool ...@@ -218,7 +218,7 @@ val is_e_false : expr -> bool
val e_raise : xsymbol -> expr -> ity -> expr val e_raise : xsymbol -> expr -> ity -> expr
val e_try : expr -> (pvsymbol list * expr) Mexn.t -> expr val e_try : expr -> (pvsymbol list * expr) Mxs.t -> expr
val e_case : expr -> (prog_pattern * expr) list -> expr val e_case : expr -> (prog_pattern * expr) list -> expr
......
...@@ -862,8 +862,8 @@ module Exn = MakeMSH (struct ...@@ -862,8 +862,8 @@ module Exn = MakeMSH (struct
let tag xs = Weakhtbl.tag_hash xs.xs_name.id_tag let tag xs = Weakhtbl.tag_hash xs.xs_name.id_tag
end) end)
module Sexn = Exn.S module Sxs = Exn.S
module Mexn = Exn.M module Mxs = Exn.M
(* effects *) (* effects *)
...@@ -883,7 +883,7 @@ type effect = { ...@@ -883,7 +883,7 @@ type effect = {
eff_taints : Sreg.t; (* ghost code writes *) eff_taints : Sreg.t; (* ghost code writes *)
eff_covers : Sreg.t; (* surviving writes *) eff_covers : Sreg.t; (* surviving writes *)
eff_resets : Sreg.t; (* locked by covers *) eff_resets : Sreg.t; (* locked by covers *)
eff_raises : Sexn.t; (* raised exceptions *) eff_raises : Sxs.t; (* raised exceptions *)
eff_oneway : bool; (* non-termination *) eff_oneway : bool; (* non-termination *)
eff_ghost : bool; (* ghost status *) eff_ghost : bool; (* ghost status *)
} }
...@@ -894,7 +894,7 @@ let eff_empty = { ...@@ -894,7 +894,7 @@ let eff_empty = {
eff_taints = Sreg.empty; eff_taints = Sreg.empty;
eff_covers = Sreg.empty; eff_covers = Sreg.empty;
eff_resets = Sreg.empty; eff_resets = Sreg.empty;
eff_raises = Sexn.empty; eff_raises = Sxs.empty;
eff_oneway = false; eff_oneway = false;
eff_ghost = false; eff_ghost = false;
} }
...@@ -905,13 +905,13 @@ let eff_equal e1 e2 = ...@@ -905,13 +905,13 @@ let eff_equal e1 e2 =
Sreg.equal e1.eff_taints e2.eff_taints && Sreg.equal e1.eff_taints e2.eff_taints &&
Sreg.equal e1.eff_covers e2.eff_covers && Sreg.equal e1.eff_covers e2.eff_covers &&
Sreg.equal e1.eff_resets e2.eff_resets && Sreg.equal e1.eff_resets e2.eff_resets &&
Sexn.equal e1.eff_raises e2.eff_raises && Sxs.equal e1.eff_raises e2.eff_raises &&
e1.eff_oneway = e2.eff_oneway && e1.eff_oneway = e2.eff_oneway &&
e1.eff_ghost = e2.eff_ghost e1.eff_ghost = e2.eff_ghost
let eff_pure e = let eff_pure e =
Mreg.is_empty e.eff_writes && Mreg.is_empty e.eff_writes &&
Sexn.is_empty e.eff_raises && Sxs.is_empty e.eff_raises &&
not e.eff_oneway not e.eff_oneway
let check_writes {eff_writes = wrt} pvs = let check_writes {eff_writes = wrt} pvs =
...@@ -951,7 +951,7 @@ let eff_ghostify gh e = ...@@ -951,7 +951,7 @@ let eff_ghostify gh e =
let eff_ghostify_weak gh e = let eff_ghostify_weak gh e =
if not gh || e.eff_ghost then e else if not gh || e.eff_ghost then e else
if e.eff_oneway || not (Sexn.is_empty e.eff_raises) then e else if e.eff_oneway || not (Sxs.is_empty e.eff_raises) then e else
if not (Sreg.equal e.eff_taints (visible_writes e)) then e else if not (Sreg.equal e.eff_taints (visible_writes e)) then e else
(* it is not enough to catch BadGhostWrite from eff_ghostify below, (* it is not enough to catch BadGhostWrite from eff_ghostify below,
because e may not have in eff_reads the needed visible variables because e may not have in eff_reads the needed visible variables
...@@ -1083,7 +1083,7 @@ let eff_assign asl = ...@@ -1083,7 +1083,7 @@ let eff_assign asl =
eff_taints = taint; eff_taints = taint;
eff_covers = Mreg.domain (Mreg.set_diff writes resets); eff_covers = Mreg.domain (Mreg.set_diff writes resets);
eff_resets = resets; eff_resets = resets;
eff_raises = Sexn.empty; eff_raises = Sxs.empty;
eff_oneway = false; eff_oneway = false;
eff_ghost = ghost } in eff_ghost = ghost } in
(* verify that we can rebuild every value *) (* verify that we can rebuild every value *)
...@@ -1108,8 +1108,8 @@ let eff_reset_overwritten ({eff_writes = wr} as e) = ...@@ -1108,8 +1108,8 @@ let eff_reset_overwritten ({eff_writes = wr} as e) =
let svv, rst = Mreg.fold add_write wr (Sreg.empty,Sreg.empty) in let svv, rst = Mreg.fold add_write wr (Sreg.empty,Sreg.empty) in
{ e with eff_resets = Sreg.diff rst svv } { e with eff_resets = Sreg.diff rst svv }
let eff_raise e x = { e with eff_raises = Sexn.add x e.eff_raises } let eff_raise e x = { e with eff_raises = Sxs.add x e.eff_raises }
let eff_catch e x = { e with eff_raises = Sexn.remove x e.eff_raises } let eff_catch e x = { e with eff_raises = Sxs.remove x e.eff_raises }
let merge_fields _ f1 f2 = Some (Spv.union f1 f2) let merge_fields _ f1 f2 = Some (Spv.union f1 f2)
...@@ -1123,7 +1123,7 @@ let eff_union e1 e2 = { ...@@ -1123,7 +1123,7 @@ let eff_union e1 e2 = {
eff_covers = Sreg.union (remove_stale e2 e1.eff_covers) eff_covers = Sreg.union (remove_stale e2 e1.eff_covers)
(remove_stale e1 e2.eff_covers); (remove_stale e1 e2.eff_covers);
eff_resets = Sreg.union e1.eff_resets e2.eff_resets; eff_resets = Sreg.union e1.eff_resets e2.eff_resets;
eff_raises = Sexn.union e1.eff_raises e2.eff_raises; eff_raises = Sxs.union e1.eff_raises e2.eff_raises;
eff_oneway = e1.eff_oneway || e2.eff_oneway; eff_oneway = e1.eff_oneway || e2.eff_oneway;
eff_ghost = e1.eff_ghost && e2.eff_ghost } eff_ghost = e1.eff_ghost && e2.eff_ghost }
...@@ -1142,12 +1142,12 @@ let eff_union e1 e2 = ...@@ -1142,12 +1142,12 @@ let eff_union e1 e2 =
let eff_contaminate e1 e2 = let eff_contaminate e1 e2 =
if not e1.eff_ghost then e2 else if not e1.eff_ghost then e2 else
if Sexn.is_empty e1.eff_raises then e2 else if Sxs.is_empty e1.eff_raises then e2 else
eff_ghostify true e2 eff_ghostify true e2
let eff_contaminate_weak e1 e2 = let eff_contaminate_weak e1 e2 =
if not e1.eff_ghost then e2 else if not e1.eff_ghost then e2 else
if Sexn.is_empty e1.eff_raises then eff_ghostify_weak true e2 else if Sxs.is_empty e1.eff_raises then eff_ghostify_weak true e2 else
eff_ghostify true e2 eff_ghostify true e2
let eff_union_par e1 e2 = let eff_union_par e1 e2 =
...@@ -1221,7 +1221,7 @@ type cty = { ...@@ -1221,7 +1221,7 @@ type cty = {
cty_args : pvsymbol list; cty_args : pvsymbol list;
cty_pre : pre list; cty_pre : pre list;
cty_post : post list; cty_post : post list;
cty_xpost : post list Mexn.t; cty_xpost : post list Mxs.t;
cty_oldies : pvsymbol Mpv.t; cty_oldies : pvsymbol Mpv.t;
cty_effect : effect; cty_effect : effect;
cty_result : ity; cty_result : ity;
...@@ -1256,7 +1256,7 @@ let cty_ghostify gh ({cty_effect = eff} as c) = ...@@ -1256,7 +1256,7 @@ let cty_ghostify gh ({cty_effect = eff} as c) =
let spec_t_fold fn_t acc pre post xpost = let spec_t_fold fn_t acc pre post xpost =
let fn_l a fl = List.fold_left fn_t a fl in let fn_l a fl = List.fold_left fn_t a fl in
let acc = fn_l (fn_l acc pre) post in let acc = fn_l (fn_l acc pre) post in
Mexn.fold (fun _ l a -> fn_l a l) xpost acc Mxs.fold (fun _ l a -> fn_l a l) xpost acc
let check_tvs reads result pre post xpost = let check_tvs reads result pre post xpost =
(* every type variable in spec comes either from a known vsymbol (* every type variable in spec comes either from a known vsymbol
...@@ -1284,7 +1284,7 @@ let create_cty ?(mask=MaskVisible) args pre post xpost oldies effect result = ...@@ -1284,7 +1284,7 @@ let create_cty ?(mask=MaskVisible) args pre post xpost oldies effect result =
let exn = Invalid_argument "Ity.create_cty" in let exn = Invalid_argument "Ity.create_cty" in
(* pre, post, and xpost are well-typed *) (* pre, post, and xpost are well-typed *)
check_pre pre; check_post exn result post; check_pre pre; check_post exn result post;
Mexn.iter (fun xs xq -> check_post exn xs.xs_ity xq) xpost; Mxs.iter (fun xs xq -> check_post exn xs.xs_ity xq) xpost;
(* mask is consistent with result *) (* mask is consistent with result *)
mask_check exn result mask; mask_check exn result mask;
let mask = mask_reduce mask in let mask = mask_reduce mask in
...@@ -1295,7 +1295,7 @@ let create_cty ?(mask=MaskVisible) args pre post xpost oldies effect result = ...@@ -1295,7 +1295,7 @@ let create_cty ?(mask=MaskVisible) args pre post xpost oldies effect result =
reads are forbidden, to simplify instantiation later. *) reads are forbidden, to simplify instantiation later. *)
Mpv.iter (fun {pv_ghost = gh; pv_ity = o} {pv_ity = t} -> Mpv.iter (fun {pv_ghost = gh; pv_ity = o} {pv_ity = t} ->
if not (gh && o == ity_purify t) then raise exn) oldies; if not (gh && o == ity_purify t) then raise exn) oldies;
let preads = spec_t_fold t_freepvs sarg pre [] Mexn.empty in let preads = spec_t_fold t_freepvs sarg pre [] Mxs.empty in
let qreads = spec_t_fold t_freepvs Spv.empty [] post xpost in let qreads = spec_t_fold t_freepvs Spv.empty [] post xpost in
let effect = eff_read_post effect qreads in let effect = eff_read_post effect qreads in
let oldies = Mpv.set_inter oldies effect.eff_reads in let oldies = Mpv.set_inter oldies effect.eff_reads in
...@@ -1311,7 +1311,7 @@ let create_cty ?(mask=MaskVisible) args pre post xpost oldies effect result = ...@@ -1311,7 +1311,7 @@ let create_cty ?(mask=MaskVisible) args pre post xpost oldies effect result =
| _, {t_node = Tfalse} -> true | _ -> false in | _, {t_node = Tfalse} -> true | _ -> false in
let filter _ () = function let filter _ () = function
| [q] when is_false q -> None | _ -> Some () in | [q] when is_false q -> None | _ -> Some () in
let raises = Mexn.diff filter effect.eff_raises xpost in let raises = Mxs.diff filter effect.eff_raises xpost in
let effect = { effect with eff_raises = raises } in let effect = { effect with eff_raises = raises } in
(* remove effects on unknown regions. We reset eff_taints (* remove effects on unknown regions. We reset eff_taints
instead of simply filtering the existing set in order instead of simply filtering the existing set in order
...@@ -1388,7 +1388,7 @@ let cty_apply c vl args res = ...@@ -1388,7 +1388,7 @@ let cty_apply c vl args res =
(fun t -> t_ty_subst tsb vsb t) in (fun t -> t_ty_subst tsb vsb t) in
let subst_l l = List.map subst_t l in let subst_l l = List.map subst_t l in
cty_unsafe (List.rev rargs) (subst_l c.cty_pre) cty_unsafe (List.rev rargs) (subst_l c.cty_pre)
(subst_l c.cty_post) (Mexn.map subst_l c.cty_xpost) (subst_l c.cty_post) (Mxs.map subst_l c.cty_xpost)
oldies eff res c.cty_mask freeze oldies eff res c.cty_mask freeze
let cty_tuple args = let cty_tuple args =
...@@ -1401,7 +1401,7 @@ let cty_tuple args = ...@@ -1401,7 +1401,7 @@ let cty_tuple args =
let eff = eff_read (Spv.of_list args) in let eff = eff_read (Spv.of_list args) in
let eff = eff_ghostify (mask = MaskGhost) eff in let eff = eff_ghostify (mask = MaskGhost) eff in
let frz = List.fold_right freeze_pv args isb_empty in let frz = List.fold_right freeze_pv args isb_empty in