Skip to content

GitLab

Commit b3a73a61 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

Mlw: local exceptions in the surface language 

current syntax is

    exception Return (int, ghost bool) in
    ...
    try
      ...
      raise Return (5, false)
      ...
    with
      Return (i, b) -> ...
    ...

These exceptions can carry mutable and non-monomorphic values.
They can be raised from local functions defined in the scope
of the exception declaration.
parent 53b3ec88
Hide whitespace changes
Inline Side-by-side
Showing with 137 additions and 58 deletions
src/mlw/dexpr.ml
View file @ b3a73a61
......@@ -372,7 +372,7 @@ type dbinder = preid option * ghost * dity
type register_old = pvsymbol -> string -> pvsymbol
type 'a later = pvsymbol Mstr.t -> register_old -> 'a
type 'a later = pvsymbol Mstr.t -> xsymbol Mstr.t -> register_old -> 'a
(* specification terms are parsed and typechecked after the program
expressions, when the types of locally bound program variables are
already established. *)
......@@ -397,6 +397,10 @@ type dspec = ity -> dspec_final
type dinvariant = term list
type dxsymbol =
| DElexn of string * dity
| DEgexn of xsymbol
type dexpr = {
de_node : dexpr_node;
de_dvty : dvty;
......@@ -421,9 +425,10 @@ and dexpr_node =
| DEassign of (dexpr * rsymbol * dexpr) list
| DEwhile of dexpr * dinvariant later * variant list later * dexpr
| DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr
| DEtry of dexpr * (xsymbol * dpattern * dexpr) list
| DEraise of xsymbol * dexpr
| DEtry of dexpr * (dxsymbol * dpattern * dexpr) list
| DEraise of dxsymbol * dexpr
| DEghost of dexpr
| DEexn of preid * dity * mask * dexpr
| DEassert of assertion_kind * term later
| DEpure of term later * dity
| DEabsurd
......@@ -446,11 +451,12 @@ and dfun_defn = preid * ghost * rs_kind *
type denv = {
frozen : dity list;
locals : (Stv.t option * dvty) Mstr.t;
excpts : dxsymbol Mstr.t
}
let denv_contents d = d.locals
let denv_empty = { frozen = []; locals = Mstr.empty }
let denv_empty = { frozen = []; locals = Mstr.empty; excpts = Mstr.empty }
let is_frozen frozen v =
try List.iter (occur_check v) frozen; false with Exit -> true
......@@ -473,25 +479,27 @@ let free_vars frozen (argl,res) =
| Dapp (_,tl,_) -> List.fold_left add s tl in
List.fold_left add (add Stv.empty res) argl
let denv_add_mono { frozen = frozen; locals = locals } id dvty =
let locals = Mstr.add id.pre_name (None, dvty) locals in
{ frozen = freeze_dvty frozen dvty; locals = locals }
let denv_add_exn { frozen = fz; locals = ls; excpts = xs } id dity =
let xs = Mstr.add id.pre_name (DElexn (id.pre_name, dity)) xs in
{ frozen = freeze_dvty fz ([], dity); locals = ls; excpts = xs }
let denv_add_mono { frozen = fz; locals = ls; excpts = xs } id dvty =
let ls = Mstr.add id.pre_name (None, dvty) ls in
{ frozen = freeze_dvty fz dvty; locals = ls; excpts = xs }
let denv_add_poly { frozen = frozen; locals = locals } id dvty =
let ftvs = free_vars frozen dvty in
let locals = Mstr.add id.pre_name (Some ftvs, dvty) locals in
{ frozen = frozen; locals = locals }
let denv_add_poly { frozen = fz; locals = ls; excpts = xs } id dvty =
let ls = Mstr.add id.pre_name (Some (free_vars fz dvty), dvty) ls in
{ frozen = fz; locals = ls; excpts = xs }
let denv_add_rec_mono { frozen = frozen; locals = locals } id dvty =
let locals = Mstr.add id.pre_name (Some Stv.empty, dvty) locals in
{ frozen = freeze_dvty frozen dvty; locals = locals }
let denv_add_rec_mono { frozen = fz; locals = ls; excpts = xs } id dvty =
let ls = Mstr.add id.pre_name (Some Stv.empty, dvty) ls in
{ frozen = freeze_dvty fz dvty; locals = ls; excpts = xs }
let denv_add_rec_poly { frozen = frozen; locals = locals } frozen0 id dvty =
let ftvs = free_vars frozen0 dvty in
let locals = Mstr.add id.pre_name (Some ftvs, dvty) locals in
{ frozen = frozen; locals = locals }
let denv_add_rec_poly { frozen = fz; locals = ls; excpts = xs } fz0 id dvty =
let ls = Mstr.add id.pre_name (Some (free_vars fz0 dvty), dvty) ls in
{ frozen = fz; locals = ls; excpts = xs }
let denv_add_rec denv frozen0 id ((argl,res) as dvty) =
let denv_add_rec denv fz0 id ((argl,res) as dvty) =
let rec is_explicit = function
| Dvar {contents = (Dval d|Dpur d|Dsim (d,_)|Dreg (d,_))}
| Durg (d,_) -> is_explicit d
......@@ -499,7 +507,7 @@ let denv_add_rec denv frozen0 id ((argl,res) as dvty) =
| Dutv _ -> true
| Dapp (_,tl,_) -> List.for_all is_explicit tl in
if List.for_all is_explicit argl && is_explicit res
then denv_add_rec_poly denv frozen0 id dvty
then denv_add_rec_poly denv fz0 id dvty
else denv_add_rec_mono denv id dvty
let denv_add_var denv id dity = denv_add_mono denv id ([], dity)
......@@ -514,19 +522,19 @@ let denv_add_let denv (id,_,_,({de_dvty = dvty} as de)) =
then denv_add_poly denv id dvty
else denv_add_mono denv id dvty
let denv_add_args { frozen = frozen; locals = locals } bl =
let l = List.fold_left (fun l (_,_,t) -> t::l) frozen bl in
let denv_add_args { frozen = fz; locals = ls; excpts = xs } bl =
let l = List.fold_left (fun l (_,_,t) -> t::l) fz bl in
let add s (id,_,t) = match id with
| Some {pre_name = n} ->
Mstr.add_new (Dterm.DuplicateVar n) n (None, ([],t)) s
| None -> s in
let s = List.fold_left add Mstr.empty bl in
{ frozen = l; locals = Mstr.set_union s locals }
{ frozen = l; locals = Mstr.set_union s ls; excpts = xs }
let denv_add_pat { frozen = frozen; locals = locals } dp =
let l = Mstr.fold (fun _ t l -> t::l) dp.dp_vars frozen in
let denv_add_pat { frozen = fz; locals = ls; excpts = xs } dp =
let l = Mstr.fold (fun _ t l -> t::l) dp.dp_vars fz in
let s = Mstr.map (fun t -> None, ([], t)) dp.dp_vars in
{ frozen = l; locals = Mstr.set_union s locals }
{ frozen = l; locals = Mstr.set_union s ls; excpts = xs }
let mk_node n = function
| Some tvs, dvty -> DEvar (n, specialize_scheme tvs dvty)
......@@ -538,6 +546,12 @@ let denv_get denv n =
let denv_get_opt denv n =
Opt.map (mk_node n) (Mstr.find_opt n denv.locals)
exception UnboundExn of string
let denv_get_exn denv n = Mstr.find_exn (UnboundExn n) n denv.excpts
let denv_get_exn_opt denv n = Mstr.find_opt n denv.excpts
let denv_pure denv get_dty =
let ht = Htv.create 3 in
let hi = Hint.create 3 in
......@@ -657,6 +671,10 @@ let dpattern ?loc node =
in
Loc.try1 ?loc dpat node
let specialize_dxs = function
| DEgexn xs -> specialize_xs xs
| DElexn (_,dity) -> dity
let dexpr ?loc node =
let get_dvty = function
| DEvar (_,dvty) ->
......@@ -749,12 +767,13 @@ let dexpr ?loc node =
let res = dity_fresh () in
dexpr_expected_type de res;
List.iter (fun (xs,dp,de) ->
dpat_expected_type dp (specialize_xs xs);
dpat_expected_type dp (specialize_dxs xs);
dexpr_expected_type de res) bl;
[], res
| DEraise (xs,de) ->
dexpr_expected_type de (specialize_xs xs);
dexpr_expected_type de (specialize_dxs xs);
[], dity_fresh ()
| DEexn (_,_,_,de)
| DEghost de ->
de.de_dvty
| DEassert _ ->
......@@ -902,10 +921,17 @@ let check_spec inr dsp ecty ({e_loc = loc} as e) =
let check_aliases recu c =
let rds_regs = c.cty_freeze.isb_reg in
let report r _ _ =
if Mreg.mem r rds_regs then let spv = Spv.filter
if Mreg.mem r rds_regs then
let spv = Spv.filter
(fun v -> ity_r_occurs r v.pv_ity) (cty_reads c) in
Loc.errorm "The type of this function contains an alias with \
external variable %a" print_pv (Spv.choose spv)
if not (Spv.is_empty spv) then Loc.errorm
"The type of this function contains an alias with \
external variable %a" print_pv (Spv.choose spv);
let sxs = Sxs.filter
(fun xs -> ity_r_occurs r xs.xs_ity) (c.cty_effect.eff_raises) in
Loc.errorm
"The type of this function contains an alias with \
external local exception %a" print_xs (Sxs.choose sxs)
else Loc.errorm "The type of this function contains an alias" in
(* we allow the value in a non-recursive function to contain
regions coming the function's arguments, but not from the
......@@ -938,6 +964,7 @@ let check_fun inr rsym dsp e =
type env = {
rsm : rsymbol Mstr.t;
pvm : pvsymbol Mstr.t;
xsm : xsymbol Mstr.t;
old : (pvsymbol Mstr.t * (let_defn * pvsymbol) Hpv.t) Mstr.t;
ghs : bool; (* we are under DEghost or in a ghost function *)
lgh : bool; (* we are under let ghost c = <cexp> *)
......@@ -948,6 +975,7 @@ type env = {
let env_empty = {
rsm = Mstr.empty;
pvm = Mstr.empty;
xsm = Mstr.empty;
old = Mstr.empty;
ghs = false;
lgh = false;
......@@ -978,7 +1006,7 @@ let find_old pvm (ovm,old) v =
let register_old env v l =
find_old env.pvm (Mstr.find_exn (UnboundLabel l) l env.old) v
let get_later env later = later env.pvm (register_old env)
let get_later env later = later env.pvm env.xsm (register_old env)
let add_label ({pvm = pvm; old = old} as env) l =
let ht = Hpv.create 3 in
......@@ -1064,6 +1092,10 @@ let rec strip uloc labs de = match de.de_node with
let get_pv env n = Mstr.find_exn (Dterm.UnboundVar n) n env.pvm
let get_rs env n = Mstr.find_exn (Dterm.UnboundVar n) n env.rsm
let get_xs env = function
| DElexn (n,_) -> Mstr.find_exn (UnboundExn n) n env.xsm
| DEgexn xs -> xs
let proxy_labels = Slab.singleton proxy_label
type let_prexix =
......@@ -1156,7 +1188,7 @@ and try_cexp uloc env ({de_dvty = argl,res} as de0) lpl =
we must ghostify the let-definitions down from here *)
cexp uloc {env with ghs = true; cgh = env.cgh || not env.ghs} de lpl
| DEfun (bl,msk,dsp,de) ->
let dvl _ _ = [] in
let dvl _ _ _ = [] in
let env = {env with ghs = env.ghs || env.lgh} in
let c, dsp, _ = lambda uloc env (binders env.ghs bl) msk dsp dvl de in
check_fun env.inr None dsp c;
......@@ -1174,8 +1206,12 @@ and try_cexp uloc env ({de_dvty = argl,res} as de0) lpl =
| DErec (drdf,de) ->
let ld, env = rec_defn uloc env drdf in
cexp uloc env de (LD ld :: lpl)
| DEexn _ ->
Loc.errorm "Local exception declarations are not allowed \
over higher-order expressions"
| DEmark _ ->
Loc.errorm "Marks are not allowed over higher-order expressions"
Loc.errorm "Label declarations are not allowed \
over higher-order expressions"
| DEsym _ | DEconst _ | DEnot _ | DEand _ | DEor _ | DEif _ | DEcase _
| DEassign _ | DEwhile _ | DEfor _ | DEtry _ | DEraise _ | DEassert _
| DEpure _ | DEabsurd | DEtrue | DEfalse -> assert false (* expr-only *)
......@@ -1187,8 +1223,8 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
e_var (get_pv env n)
| DEsym (PV v) ->
e_var v
| DEconst(c,dity) ->
e_const c (ity_of_dity dity)
| DEconst (c,dity) ->
e_const c (ity_of_dity dity)
| DEapp ({de_dvty = ([],_)} as de1, de2) ->
let e1 = expr uloc env de1 in
let e2 = expr uloc env de2 in
......@@ -1254,6 +1290,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
| DEtry (de1,bl) ->
let e1 = expr uloc env de1 in
let add_branch m (xs,dp,de) =
let xs = get_xs env xs in
let mask = if env.ghs then MaskGhost else xs.xs_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
......@@ -1309,7 +1346,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
vl, e_case e (List.rev bl) in
e_try e1 (Mxs.mapi mk_branch xsm)
| DEraise (xs,de) ->
e_raise xs (expr uloc env de) (ity_of_dity res)
e_raise (get_xs env xs) (expr uloc env de) (ity_of_dity res)
| DEghost de ->
e_ghostify true (expr uloc {env with ghs = true} de)
| DEassert (ak,f) ->
......@@ -1322,6 +1359,10 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
e_true
| DEfalse ->
e_false
| DEexn (id,dity,mask,de) ->
let xs = create_xsymbol id ~mask (ity_of_dity dity) in
let env = { env with xsm = Mstr.add id.pre_name xs env.xsm } in
e_exn xs (expr uloc env de)
| DEmark ({pre_name = l},de) ->
let env, old = add_label env l in
let put _ (ld,_) e = e_let ld e in
......@@ -1449,4 +1490,6 @@ let expr ?(keep_loc=true) de =
let () = Exn_printer.register (fun fmt e -> match e with
| UnboundLabel s ->
Format.fprintf fmt "unbound label %s" s
| UnboundExn s ->
Format.fprintf fmt "unbound exception %s" s
| _ -> raise e)
src/mlw/dexpr.mli
View file @ b3a73a61
......@@ -62,7 +62,7 @@ type register_old = pvsymbol -> string -> pvsymbol
(** Program variables occurring under [old] or [at] are passed to
a registrar function. The label string must be ["0"] for [old]. *)
type 'a later = pvsymbol Mstr.t -> register_old -> 'a
type 'a later = pvsymbol Mstr.t -> xsymbol Mstr.t -> register_old -> 'a
(** Specification terms are parsed and typechecked after the program
expressions, when the types of locally bound program variables are
already established. *)
......@@ -87,6 +87,10 @@ type dspec = ity -> dspec_final
type dinvariant = term list
type dxsymbol =
| DElexn of string * dity
| DEgexn of xsymbol
type dexpr = private {
de_node : dexpr_node;
de_dvty : dvty;
......@@ -111,9 +115,10 @@ and dexpr_node =
| DEassign of (dexpr * rsymbol * dexpr) list
| DEwhile of dexpr * dinvariant later * variant list later * dexpr
| DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr
| DEtry of dexpr * (xsymbol * dpattern * dexpr) list
| DEraise of xsymbol * dexpr
| DEtry of dexpr * (dxsymbol * dpattern * dexpr) list
| DEraise of dxsymbol * dexpr
| DEghost of dexpr
| DEexn of preid * dity * mask * dexpr
| DEassert of assertion_kind * term later
| DEpure of term later * dity
| DEabsurd
......@@ -145,10 +150,16 @@ val denv_add_args : denv -> dbinder list -> denv
val denv_add_pat : denv -> dpattern -> denv
val denv_add_exn : denv -> preid -> dity -> denv
val denv_get : denv -> string -> dexpr_node (** raises UnboundVar *)
val denv_get_opt : denv -> string -> dexpr_node option
val denv_get_exn : denv -> string -> dxsymbol (** raises Not_found *)
val denv_get_exn_opt : denv -> string -> dxsymbol option
val denv_contents : denv -> (Ty.Stv.t option * dvty) Mstr.t
val denv_pure : denv -> (Dterm.denv -> Dterm.dty) -> dity
......
src/parser/parser.mly
View file @ b3a73a61
......@@ -160,7 +160,7 @@
%nonassoc IN
%nonassoc below_SEMI
%nonassoc SEMICOLON
%nonassoc LET VAL
%nonassoc LET VAL EXCEPTION
%nonassoc prec_no_else
%nonassoc DOT ELSE GHOST
%nonassoc prec_named
......@@ -759,6 +759,10 @@ expr_:
{ Ematch ($2, $4) }
| MATCH comma_list2(expr) WITH match_cases(seq_expr) END
{ Ematch (mk_expr (Etuple $2) $startpos($2) $endpos($2), $4) }
| EXCEPTION labels(uident) IN seq_expr
{ Eexn ($2, PTtuple [], Ity.MaskVisible, $4) }
| EXCEPTION labels(uident) return IN seq_expr
{ Eexn ($2, fst $3, snd $3, $5) }
| LABEL labels(uident) IN seq_expr
{ Emark ($2, $4) }
| WHILE seq_expr DO loop_annotation seq_expr DONE
......
src/parser/ptree.ml
View file @ b3a73a61
......@@ -141,6 +141,7 @@ and expr_desc =
| Eabsurd
| Epure of term
| Eraise of qualid * expr option
| Eexn of ident * pty * Ity.mask * expr
| Etry of expr * (qualid * pattern option * expr) list
| Efor of ident * expr * Expr.for_direction * expr * invariant * expr
(* annotations *)
......
src/parser/typing.ml
View file @ b3a73a61
......@@ -486,9 +486,13 @@ let dpost muc ql lvm old ity =
v, Loc.try3 ~loc type_fmla muc lvm old f in
List.map dpost ql
let dxpost muc ql lvm old =
let dxpost muc ql lvm xsm old =
let add_exn (q,pf) m =
let xs = find_xsymbol muc q in
let xs = match q with
| Qident i ->
begin try Mstr.find i.id_str xsm with
| Not_found -> find_xsymbol muc q end
| _ -> find_xsymbol muc q in
Mxs.change (fun l -> match pf, l with
| Some pf, Some l -> Some (pf :: l)
| Some pf, None -> Some (pf :: [])
......@@ -519,23 +523,23 @@ let find_variant_ls muc q = match find_lsymbol muc.muc_theory q with
| { ls_args = [u;v]; ls_value = None } as ls when ty_equal u v -> ls
| s -> Loc.errorm ~loc:(qloc q) "Not an order relation: %a" Pretty.print_ls s
let dvariant muc varl lvm old =
let dvariant muc varl lvm _xsm old =
let dvar t = type_term muc lvm old t in
let dvar (t,q) = dvar t, Opt.map (find_variant_ls muc) q in
List.map dvar varl
let dspec muc sp lvm old ity = {
let dspec muc sp lvm xsm old ity = {
ds_pre = dpre muc sp.sp_pre lvm old;
ds_post = dpost muc sp.sp_post lvm old ity;
ds_xpost = dxpost muc sp.sp_xpost lvm old;
ds_xpost = dxpost muc sp.sp_xpost lvm xsm old;
ds_reads = dreads muc sp.sp_reads lvm;
ds_writes = dwrites muc sp.sp_writes lvm;
ds_checkrw = sp.sp_checkrw;
ds_diverge = sp.sp_diverge; }
let dassert muc f lvm old = type_fmla muc lvm old f
let dassert muc f lvm _xsm old = type_fmla muc lvm old f
let dinvariant muc f lvm old = dpre muc f lvm old
let dinvariant muc f lvm _xsm old = dpre muc f lvm old
(* abstract values *)
......@@ -588,6 +592,12 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
| None -> qualid_app loc q el)
| _ -> qualid_app loc q el
in
let find_dxsymbol q = match q with
| Qident {id_str = n} ->
(try denv_get_exn denv n with _
-> DEgexn (find_xsymbol muc q))
| _ -> DEgexn (find_xsymbol muc q)
in
Dexpr.dexpr ~loc begin match desc with
| Ptree.Eident q ->
qualid_app loc q []
......@@ -718,21 +728,25 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
dexpr muc denv e1, find_record_field muc q, dexpr muc denv e2 in
DEassign (List.map mk_assign asl)
| Ptree.Eraise (q, e1) ->
let xs = find_xsymbol muc q in
let xs = find_dxsymbol q in
let mb_unit = match xs with
| DEgexn xs -> ity_equal xs.xs_ity ity_unit
| DElexn _ -> true in
let e1 = match e1 with
| Some e1 -> dexpr muc denv e1
| None when ity_equal xs.xs_ity ity_unit ->
Dexpr.dexpr ~loc (DEsym (RS rs_void))
| None when mb_unit -> Dexpr.dexpr ~loc (DEsym (RS rs_void))
| _ -> Loc.errorm ~loc "exception argument expected" in
DEraise (xs, e1)
| Ptree.Etry (e1, cl) ->
let e1 = dexpr muc denv e1 in
let branch (q, pp, e) =
let xs = find_xsymbol muc q in
let xs = find_dxsymbol q in
let mb_unit = match xs with
| DEgexn xs -> ity_equal xs.xs_ity ity_unit
| DElexn _ -> true in
let pp = match pp with
| Some pp -> dpattern muc pp
| None when ity_equal xs.xs_ity ity_unit ->
Dexpr.dpattern ~loc (DPapp (rs_void, []))
| None when mb_unit -> Dexpr.dpattern ~loc (DPapp (rs_void, []))
| _ -> Loc.errorm ~loc "exception argument expected" in
let denv = denv_add_pat denv pp in
let e = dexpr muc denv e in
......@@ -740,9 +754,15 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
DEtry (e1, List.map branch cl)
| Ptree.Eghost e1 ->
DEghost (dexpr muc denv e1)
| Ptree.Eabsurd -> DEabsurd
| Ptree.Eexn (id, pty, mask, e1) ->
let id = create_user_id id in
let dity = dity_of_ity (ity_of_pty muc pty) in
let denv = denv_add_exn denv id dity in
DEexn (id, dity, mask, dexpr muc denv e1)
| Ptree.Eabsurd ->
DEabsurd
| Ptree.Epure t ->
let get_term lvm old = type_term muc lvm old t in
let get_term lvm _xsm old = type_term muc lvm old t in
let gvars _at q = try match find_prog_symbol muc q with
| PV v -> Some v | _ -> None with _ -> None in
let get_dty pure_denv =
......@@ -757,10 +777,10 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
DEuloc (dexpr muc denv e1, uloc)
| Ptree.Enamed (Lstr lab, e1) ->
DElabel (dexpr muc denv e1, Slab.singleton lab)
| Ptree.Ecast ({expr_desc = Ptree.Econst c},pty) ->
| Ptree.Ecast ({expr_desc = Ptree.Econst c}, pty) ->
let ity = ity_of_pty muc pty in
DEconst (c, dity_of_ity ity)
| Ptree.Ecast (e1,pty) ->
| Ptree.Ecast (e1, pty) ->
let d1 = dexpr muc denv e1 in
let ity = ity_of_pty muc pty in
DEcast (d1, ity)
......
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