Mise à jour terminée. Pour connaître les apports de la version 13.8.4 par rapport à notre ancienne version vous pouvez lire les "Release Notes" suivantes :
https://about.gitlab.com/releases/2021/02/11/security-release-gitlab-13-8-4-released/
https://about.gitlab.com/releases/2021/02/05/gitlab-13-8-3-released/

Commit c8288aaa authored by Andrei Paskevich's avatar Andrei Paskevich

Mlw: exceptions with partially ghost values

parent e12222bc
......@@ -1153,30 +1153,58 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
e_for v e_from dir e_to (create_invariant inv) e
| DEtry (de1,bl) ->
let e1 = expr uloc env de1 in
let add_branch (m,l) (xs,dp,de) =
let vm, pat = create_prog_pattern dp.dp_pat xs.xs_ity MaskVisible in
let add_branch m (xs,dp,de) =
let vm, pat = create_prog_pattern dp.dp_pat xs.xs_ity xs.xs_mask in
let e = expr uloc (add_pv_map env vm) de in
Mstr.iter (fun _ v -> check_used_pv e v) vm;
try Mexn.add xs ((pat,e) :: Mexn.find xs m) m, l
with Not_found -> Mexn.add xs [pat,e] m, (xs::l) in
let xsm, xsl = List.fold_left add_branch (Mexn.empty,[]) bl in
let mk_branch xs = match Mexn.find xs xsm with
Mexn.add xs ((pat, e) :: Mexn.find_def [] xs m) m in
let xsm = List.fold_left add_branch Mexn.empty bl in
let is_simple p = match p.pat_node with
| Papp (fs,[]) -> is_fs_tuple fs
| Pvar _ | Pwild -> true | _ -> false in
let conv_simple p (ity,ghost) = match p.pat_node with
| Pvar v -> Ity.restore_pv v
| _ -> create_pvsymbol (id_fresh "_") ~ghost ity in
let mk_branch xs = function
| [{ pp_pat = { pat_node = Pvar v }}, e] ->
xs, Ity.restore_pv v, e
[Ity.restore_pv v], e
| [{ pp_pat = { pat_node = (Pwild | Papp (_,[])) }}, e]
when ity_equal xs.xs_ity ity_unit ->
[], e
| [{ pp_pat = { pat_node = Pwild }}, e] ->
xs, create_pvsymbol (id_fresh "_") xs.xs_ity, e
| [{ pp_pat = { pat_node = Papp (fs,[]) }}, e]
when ls_equal fs (Term.fs_tuple 0) ->
xs, create_pvsymbol (id_fresh "_") xs.xs_ity, e
let ghost = mask_ghost xs.xs_mask in
[create_pvsymbol (id_fresh "_") ~ghost xs.xs_ity], e
| [{ pp_pat = { pat_node = Papp (fs,(_::_::_ as pl)) }}, e]
when is_fs_tuple fs && List.for_all is_simple pl ->
let tyl = match xs.xs_ity.ity_node with (* tuple *)
| Ityapp (_,tyl,_) -> tyl | _ -> assert false in
let ghl = match xs.xs_mask with
| MaskTuple ml -> List.map mask_ghost ml
| MaskVisible -> List.map Util.ffalse pl
| MaskGhost -> List.map Util.ttrue pl in
List.map2 conv_simple pl (List.combine tyl ghl), e
| bl ->
let v = create_pvsymbol (id_fresh "res") xs.xs_ity in
let id = id_fresh "q" in
let vl = match xs.xs_mask with
| _ when ity_equal xs.xs_ity ity_unit -> []
| MaskGhost -> [create_pvsymbol id ~ghost:true xs.xs_ity]
| MaskVisible -> [create_pvsymbol id ~ghost:false xs.xs_ity]
| MaskTuple ml ->
let mk_var ity m =
create_pvsymbol id ~ghost:(mask_ghost m) ity in
let tyl = match xs.xs_ity.ity_node with (* tuple *)
| Ityapp (_,tyl,_) -> tyl | _ -> assert false in
List.map2 mk_var tyl ml in
let t, e = match vl with
| [] -> t_void, e_void | [v] -> t_var v.pv_vs, e_var v
| vl -> t_tuple (List.map (fun v -> t_var v.pv_vs) vl),
e_tuple (List.map e_var vl) in
let pl = List.rev_map (fun (p,_) -> [p.pp_pat]) bl in
let bl = if Pattern.is_exhaustive [t_var v.pv_vs] pl then bl
else let _,pp = create_prog_pattern PPwild v.pv_ity MaskVisible in
(pp, e_raise xs (e_var v) (ity_of_dity res)) :: bl in
xs, v, e_case (e_var v) (List.rev bl)
in
e_try e1 (List.rev_map mk_branch xsl)
let bl = if Pattern.is_exhaustive [t] pl then bl else
let _,pp = create_prog_pattern PPwild xs.xs_ity xs.xs_mask in
(pp, e_raise xs e (ity_of_dity res)) :: bl in
vl, e_case e (List.rev bl) in
e_try e1 (Mexn.mapi mk_branch xsm)
| DEraise (xs,de) ->
e_raise xs (expr uloc env de) (ity_of_dity res)
| DEghost de ->
......
......@@ -310,7 +310,7 @@ and expr_node =
| Ecase of expr * (prog_pattern * expr) list
| Ewhile of expr * invariant list * variant list * expr
| Efor of pvsymbol * for_bounds * invariant list * expr
| Etry of expr * (xsymbol * pvsymbol * expr) list
| Etry of expr * (pvsymbol list * expr) Mexn.t
| Eraise of xsymbol * expr
| Eassert of assertion_kind * term
| Eghost of expr
......@@ -363,7 +363,7 @@ let e_fold fn acc e = match e.e_node with
| Elet (LDvar (_,d), e) | Ewhile (d,_,_,e) -> fn (fn acc 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
| Etry (d,xl) -> List.fold_left (fun acc (_,_,e) -> fn acc e) (fn acc d) xl
| Etry (d,xl) -> Mexn.fold (fun _ (_,e) acc -> fn acc e) xl (fn acc d)
exception FoundExpr of Loc.position option * expr
......@@ -863,25 +863,34 @@ let e_case e bl =
let mask = List.fold_left add_mask MaskVisible dl in
let eff = List.fold_left (fun eff (p,d) ->
let pvs = pvs_of_vss Spv.empty p.pp_pat.pat_vars in
let dff = eff_bind pvs d.e_effect in
try_effect dl eff_union_par eff dff) eff_empty bl in
let deff = eff_bind pvs d.e_effect in
try_effect dl eff_union_par eff deff) eff_empty bl in
let eff = try_effect (e::dl) eff_union_seq e.e_effect eff in
let eff = try_effect (e::dl) eff_ghostify ghost eff in
mk_expr (Ecase (e,bl)) ity mask eff
let e_try e xl =
List.iter (fun (xs,v,d) ->
ity_equal_check v.pv_ity xs.xs_ity;
let get_mask = function
| [] -> ity_unit, MaskVisible
| [v] -> v.pv_ity, mask_of_pv v
| vl -> ity_tuple (List.map (fun v -> v.pv_ity) vl),
MaskTuple (List.map mask_of_pv vl) in
Mexn.iter (fun xs (vl,d) ->
let ity, mask = get_mask vl in
if mask_spill xs.xs_mask mask then
Loc.errorm "Non-ghost pattern in a ghost position";
ity_equal_check ity xs.xs_ity;
ity_equal_check d.e_ity e.e_ity) xl;
let ghost = e.e_effect.eff_ghost in
let eeff = List.fold_left (fun eff (xs,_,_) ->
eff_catch eff xs) e.e_effect xl in
let dl = List.map (fun (_,_,d) -> d) xl in
let eeff = Mexn.fold (fun xs _ eff ->
eff_catch eff xs) xl e.e_effect in
let dl = Mexn.fold (fun _ (_,d) l -> d::l) xl [] 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 xeff = List.fold_left (fun eff (_,v,d) ->
let dff = eff_bind_single v d.e_effect in
try_effect dl eff_union_par eff dff) eff_empty xl in
let xeff = Mexn.fold (fun _ (vl,d) eff ->
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
try_effect dl eff_union_par eff deff) xl eff_empty in
let eff = try_effect (e::dl) eff_union_seq eeff xeff in
let eff = try_effect (e::dl) eff_ghostify ghost eff in
mk_expr (Etry (e,xl)) e.e_ity mask eff
......@@ -944,7 +953,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)
(List.map (fun (pp,e) -> pp, e_rs_subst sm e) bl)
| Etry (d,xl) -> e_try (e_rs_subst sm d)
(List.map (fun (xs,v,e) -> xs, v, e_rs_subst sm e) xl))
(Mexn.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
| Cany | Cpur _ -> d
......@@ -1275,6 +1284,7 @@ and print_enode pri fmt e = match e.e_node with
| Eraise (xs,e) ->
fprintf fmt "raise (%a %a)" print_xs xs print_expr e
| Etry (e,bl) ->
let bl = Mexn.bindings bl in
fprintf fmt "try %a with@\n@[<hov>%a@]@\nend"
print_expr e (Pp.print_list Pp.newline print_xbranch) bl
| Eabsurd ->
......@@ -1294,14 +1304,14 @@ and print_branch fmt ({pp_pat = p},e) =
fprintf fmt "@[<hov 4>| %a ->@ %a@]" print_pat p print_expr e;
Svs.iter forget_var p.pat_vars
and print_xbranch fmt (xs,v,e) =
if Spv.mem v e.e_effect.eff_reads then begin
fprintf fmt "@[<hov 4>| %a %a ->@ %a@]" print_xs xs print_pv v print_expr e;
forget_pv v
end else if ity_equal v.pv_ity ity_unit then
fprintf fmt "@[<hov 4>| %a ->@ %a@]" print_xs xs print_expr e
else
fprintf fmt "@[<hov 4>| %a _ ->@ %a@]" print_xs xs print_expr e
and print_xbranch fmt (xs,(vl,e)) =
let pvs = Spv.inter (Spv.of_list vl) e.e_effect.eff_reads in
let print_var fmt v =
if Spv.mem v pvs then fprintf fmt " %a" print_pv v
else pp_print_string fmt " _" in
fprintf fmt "@[<hov 4>| %a%a ->@ %a@]" print_xs xs
(Pp.print_list Pp.nothing print_var) vl print_expr e;
Spv.iter forget_pv pvs
and print_let_defn fmt = function
| LDvar (v,e) ->
......
......@@ -124,7 +124,7 @@ and expr_node = private
| Ecase of expr * (prog_pattern * expr) list
| Ewhile of expr * invariant list * variant list * expr
| Efor of pvsymbol * for_bounds * invariant list * expr
| Etry of expr * (xsymbol * pvsymbol * expr) list
| Etry of expr * (pvsymbol list * expr) Mexn.t
| Eraise of xsymbol * expr
| Eassert of assertion_kind * term
| Eghost of expr
......@@ -217,7 +217,7 @@ val is_e_false : expr -> bool
val e_raise : xsymbol -> expr -> ity -> expr
val e_try : expr -> (xsymbol * pvsymbol * expr) list -> expr
val e_try : expr -> (pvsymbol list * expr) Mexn.t -> expr
val e_case : expr -> (prog_pattern * expr) list -> expr
......
......@@ -159,17 +159,20 @@ let get_news node pure =
List.fold_left news_pure news pure
let get_syms node pure =
let syms_ts s ts = Sid.add ts.ts_name s in
let syms_ls s ls = Sid.add ls.ls_name s in
let syms_ty s ty = ty_s_fold syms_ts s ty in
let syms_term s t = t_s_fold syms_ty syms_ls s t in
let syms_ts syms s = Sid.add s.ts_name syms in
let syms_ls syms s = Sid.add s.ls_name syms in
let syms_ty syms ty = ty_s_fold syms_ts syms ty in
let syms_term syms t = t_s_fold syms_ty syms_ls syms t in
let syms_tl syms tl = List.fold_left syms_term syms tl in
let syms_pure syms d = Sid.union syms d.d_syms in
let syms_vari syms (t,r) = Opt.fold syms_ls (syms_term syms t) r in
let syms_varl syms varl = List.fold_left syms_vari syms varl in
let syms = List.fold_left syms_pure Sid.empty pure in
let syms_its syms s = Sid.add s.its_ts.ts_name syms in
let syms_ity syms ity = ity_s_fold syms_its syms ity in
let syms_xs xs syms = Sid.add xs.xs_name syms in
let syms_pv syms v = syms_ity syms v.pv_ity in
let syms_pvl syms vl = List.fold_left syms_pv syms vl in
let rec syms_pat syms p = match p.pat_node with
| Pwild | Pvar _ -> syms
| Papp (s,pl) ->
......@@ -178,7 +181,7 @@ let get_syms node pure =
| Por (p,q) -> syms_pat (syms_pat syms p) q
| Pas (p,_) -> syms_pat syms p in
let syms_cty syms c =
let add_tl syms tl = List.fold_left syms_term syms tl in
let add_tl syms tl = syms_tl syms tl in
let add_xq xs ql syms = syms_xs xs (add_tl syms ql) in
let syms = add_tl (add_tl syms c.cty_pre) c.cty_post in
let syms = Mexn.fold add_xq c.cty_xpost syms in
......@@ -202,10 +205,10 @@ let get_syms node pure =
List.fold_left del_rd esms rdl in
syms_let_defn (Sid.union syms esms) ld
| Efor (i,_,invl,e) ->
syms_pv (List.fold_left syms_term (syms_expr syms e) invl) i
syms_pv (syms_tl (syms_expr syms e) invl) i
| Ewhile (d,invl,varl,e) ->
let syms = List.fold_left syms_vari (syms_expr syms e) varl in
List.fold_left syms_term (syms_eity syms d) invl
let syms = syms_varl (syms_expr syms e) varl in
syms_tl (syms_eity syms d) invl
| Eif (c,d,e) ->
syms_expr (syms_expr (syms_eity syms c) d) e
| Ecase (d,bl) ->
......@@ -213,22 +216,23 @@ let get_syms node pure =
syms_pat (syms_expr syms e) p.pp_pat in
List.fold_left add_branch (syms_eity syms d) bl
| Etry (d,xl) ->
let add_branch syms (xs,v,e) =
syms_xs xs (syms_pv (syms_expr syms e) v) in
List.fold_left add_branch (syms_expr syms d) xl
let add_branch xs (vl,e) syms =
syms_xs xs (syms_pvl (syms_expr syms e) vl) in
Mexn.fold add_branch xl (syms_expr syms d)
| Eraise (xs,e) ->
syms_xs xs (syms_eity syms e)
and syms_eity syms e =
syms_expr (syms_ity syms e.e_ity) e
and syms_city syms c =
let syms = syms_ity (syms_cexp syms c) c.c_cty.cty_result in
List.fold_left syms_pv syms c.c_cty.cty_args
let syms = syms_cexp syms c in
let syms = syms_pvl syms c.c_cty.cty_args in
syms_ity syms c.c_cty.cty_result
and syms_cexp syms c = match c.c_node with
| Capp (s,vl) ->
let syms = List.fold_left syms_pv syms vl in
syms_cty (Sid.add s.rs_name syms) s.rs_cty
let syms = syms_cty syms s.rs_cty in
syms_pvl (Sid.add s.rs_name syms) vl
| Cpur (s,vl) ->
List.fold_left syms_pv (Sid.add s.ls_name syms) vl
syms_pvl (Sid.add s.ls_name syms) vl
| Cfun e -> syms_cty (syms_expr syms e) c.c_cty
| Cany -> syms_cty syms c.c_cty
and syms_let_defn syms = function
......@@ -240,7 +244,7 @@ let get_syms node pure =
syms_city syms c
| LDrec rdl ->
let add_rd syms rd =
let syms = List.fold_left syms_vari syms rd.rec_varl in
let syms = syms_varl syms rd.rec_varl in
let syms = match rd.rec_sym.rs_logic with
| RLpv _ -> syms_ls (syms_ts syms ts_func) fs_func_app
| _ -> syms in
......@@ -259,7 +263,7 @@ let get_syms node pure =
(* the syms of the invariants are already in [pure] *)
let syms = Opt.fold syms_ity syms d.itd_its.its_def in
let add_fd syms s = syms_ity syms s.rs_cty.cty_result in
let add_cs syms s = List.fold_left syms_pv syms s.rs_cty.cty_args in
let add_cs syms s = syms_pvl syms s.rs_cty.cty_args in
let syms = List.fold_left add_fd syms d.itd_fields in
List.fold_left add_cs syms d.itd_constructors in
List.fold_left syms_itd syms dl
......
......@@ -778,10 +778,11 @@ let rec clone_expr cl sm e = e_label_copy e (match e.e_node with
(e_var (sm_find_pv sm f)) dir (e_var (sm_find_pv sm t))
(clone_invl cl ism invl) (clone_expr cl ism e)
| Etry (d, xl) ->
let conv_br (xs, v, e) =
let v' = clone_pv cl v in
cl_find_xs cl xs, v', clone_expr cl (sm_save_pv sm v v') e in
e_try (clone_expr cl sm d) (List.map conv_br xl)
let conv_br xs (vl, e) m =
let vl' = List.map (clone_pv cl) vl in
let sm = List.fold_left2 sm_save_pv sm vl vl' in
Mexn.add (cl_find_xs cl xs) (vl', clone_expr cl sm e) m in
e_try (clone_expr cl sm d) (Mexn.fold conv_br xl Mexn.empty)
| Eraise (xs, e) ->
e_raise (cl_find_xs cl xs) (clone_expr cl sm e) (clone_ity cl e.e_ity)
| Eassert (k, f) ->
......@@ -815,7 +816,8 @@ and clone_cexp cl sm c = match c.c_node with
and clone_let_defn cl sm ld = match ld with
| LDvar (v,e) ->
let e' = clone_expr cl sm e in
let ld, v' = let_var (id_clone v.pv_vs.vs_name) ~ghost:v.pv_ghost e' in
let id = id_clone v.pv_vs.vs_name in
let ld, v' = let_var id ~ghost:v.pv_ghost e' in
sm_save_pv sm v v', ld
| LDsym (s,c) ->
let c' = clone_cexp cl sm c in
......@@ -867,8 +869,9 @@ let clone_pdecl inst cl uc d = match d.pd_node with
cl.pv_table <- sm.sm_pv; cl.rs_table <- sm.sm_rs;
add_pdecl ~vc:false uc (create_let_decl ld)
| PDexn xs ->
let id = id_clone xs.xs_name in
let ity = clone_ity cl xs.xs_ity in
let xs' = create_xsymbol (id_clone xs.xs_name) ity in
let xs' = create_xsymbol id ~mask:xs.xs_mask ity in
cl.xs_table <- Mexn.add xs xs' cl.xs_table;
add_pdecl ~vc:false uc (create_exn_decl xs')
| PDpure ->
......
......@@ -589,8 +589,8 @@ prog_decl:
| LET ghost kind labels(lident_rich) mk_expr(fun_defn) { Dlet ($4, $2, $3, $5) }
| LET ghost kind labels(lident_rich) EQUAL seq_expr { Dlet ($4, $2, $3, $6) }
| LET REC with_list1(rec_defn) { Drec $3 }
| EXCEPTION labels(uident) { Dexn ($2, PTtuple []) }
| EXCEPTION labels(uident) ty { Dexn ($2, $3) }
| EXCEPTION labels(uident) { Dexn ($2, PTtuple [], Ity.MaskVisible) }
| EXCEPTION labels(uident) return { Dexn ($2, fst $3, snd $3) }
ghost:
| (* epsilon *) { false }
......
......@@ -219,7 +219,7 @@ type decl =
| Dprop of Decl.prop_kind * ident * term
| Dlet of ident * ghost * Expr.rs_kind * expr
| Drec of fundef list
| Dexn of ident * pty
| Dexn of ident * pty * Ity.mask
| Dmeta of ident * metarg list
| Dclone of qualid * clone_subst list
| Duse of qualid
......@@ -1085,9 +1085,9 @@ let add_decl muc env file d =
| Ptree.Drec fdl ->
let _, rd = drec_defn muc denv_empty fdl in
add_pdecl ~vc muc (create_let_decl (rec_defn ~keep_loc:true rd))
| Ptree.Dexn (id, pty) ->
| Ptree.Dexn (id, pty, mask) ->
let ity = ity_of_pty muc pty in
let xs = create_xsymbol (create_user_id id) ity in
let xs = create_xsymbol (create_user_id id) ~mask ity in
add_pdecl ~vc muc (create_exn_decl xs)
| Ptree.Duse use ->
use_export muc (find_module env file use)
......
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