Commit 4c79348a authored by Andrei Paskevich's avatar Andrei Paskevich

Mlw: allow non-ghost expressions to return (partially) ghost values

this is still work in progress and no testing was done so far.

Highlights of this commit:

- "(ghost 42, 15)" is now a non-ghost expression that can be returned
  from a function and/or matched against a "(ghost x, y)" pattern.
  Only the tuple constructor and direct pattern matching are magical:
  "let z = (ghost 42, 15) in ..." still makes z ghost, and therefore
  "snd (ghost 42, 15)" is ghost, too.

- "if c then e1 else ghost e2" and "let z = e1 in ghost e2" are now
  non-ghost expressions with a ghost result. This means that e1 may
  have visible effects. Of course, if e2 raises exceptions, the whole
  expression is ghostified. Contamination is still done when possible,
  that is, when the contaminated expression has no visible effects.

- "let ghost x = e1 in e2" no longer ghostifies e1.

- "let f (ghost x) = ... in f e1" no longer ghostifies e1.

- new syntax: variables in program patterns may be marked ghost.
  In particular: "let x, ghost y = ...".

- new syntax: the function result type may be written as a partially
  ghost tuple: "val f ... : ghost int" or "any (int, ghost bool)".
  The ghostness annotation is required for top-level and recursive
  functions.

- exceptions can carry partially ghost tuples (API only, WIP)
parent fbedf74b
This diff is collapsed.
......@@ -36,10 +36,10 @@ type dpattern = private {
type dpattern_node =
| DPwild
| DPvar of preid
| DPvar of preid * bool
| DPapp of rsymbol * dpattern list
| DPas of dpattern * preid * bool
| DPor of dpattern * dpattern
| DPas of dpattern * preid
| DPcast of dpattern * ity
(** Binders *)
......@@ -94,8 +94,8 @@ and dexpr_node =
| DEls of lsymbol
| DEconst of Number.constant
| DEapp of dexpr * dexpr
| DEfun of dbinder list * dspec later * dexpr
| DEany of dbinder list * dspec later * dity
| DEfun of dbinder list * mask * dspec later * dexpr
| DEany of dbinder list * mask * dspec later * dity
| DElet of dlet_defn * dexpr
| DErec of drec_defn * dexpr
| DEnot of dexpr
......@@ -124,7 +124,7 @@ and dlet_defn = preid * ghost * rs_kind * dexpr
and drec_defn = private { fds : dfun_defn list }
and dfun_defn = preid * ghost * rs_kind *
dbinder list * dspec later * variant list later * dexpr
dbinder list * mask * dspec later * variant list later * dexpr
(** Environment *)
......@@ -151,7 +151,7 @@ val dpattern : ?loc:Loc.position -> dpattern_node -> dpattern
val dexpr : ?loc:Loc.position -> dexpr_node -> dexpr
type pre_fun_defn = preid * ghost * rs_kind * dbinder list *
dity * (denv -> dspec later * variant list later * dexpr)
dity * mask * (denv -> dspec later * variant list later * dexpr)
val drec_defn : denv -> pre_fun_defn list -> denv * drec_defn
......
This diff is collapsed.
......@@ -70,20 +70,21 @@ val rs_ghost : rsymbol -> bool
type prog_pattern = private {
pp_pat : pattern;
pp_ity : ity;
pp_mask : mask;
pp_ghost : bool;
}
type pre_pattern =
| PPwild
| PPvar of preid
| PPvar of preid * bool
| PPapp of rsymbol * pre_pattern list
| PPas of pre_pattern * preid * bool
| PPor of pre_pattern * pre_pattern
| PPas of pre_pattern * preid
exception ConstructorExpected of rsymbol
val create_prog_pattern :
pre_pattern -> ?ghost:bool -> ity -> pvsymbol Mstr.t * prog_pattern
pre_pattern -> ity -> mask -> pvsymbol Mstr.t * prog_pattern
(** {2 Program expressions} *)
......@@ -102,6 +103,7 @@ type assign = pvsymbol * rsymbol * pvsymbol (* region * field * value *)
type expr = private {
e_node : expr_node;
e_ity : ity;
e_mask : mask;
e_effect : effect;
e_label : Slab.t;
e_loc : Loc.position option;
......@@ -120,6 +122,7 @@ and expr_node = private
| Etry of expr * (xsymbol * pvsymbol * expr) list
| Eraise of xsymbol * expr
| Eassert of assertion_kind * term
| Eghost of expr
| Epure of term
| Eabsurd
......@@ -152,12 +155,6 @@ val e_label : ?loc:Loc.position -> Slab.t -> expr -> expr
val e_label_add : label -> expr -> expr
val e_label_copy : expr -> expr -> expr
val e_ghost : expr -> bool
val c_ghost : cexp -> bool
val e_ghostify : bool -> expr -> expr
val c_ghostify : bool -> cexp -> cexp
(** {2 Definitions} *)
val let_var :
......@@ -176,22 +173,13 @@ val ls_decr_of_rec_defn : rec_defn -> lsymbol option
(** {2 Callable expressions} *)
val c_app : rsymbol -> pvsymbol list -> ity list -> ity -> cexp
val c_pur : lsymbol -> pvsymbol list -> ity list -> ity -> cexp
val c_fun : pvsymbol list ->
val c_fun : ?mask:mask -> pvsymbol list ->
pre list -> post list -> post list Mexn.t -> pvsymbol Mpv.t -> expr -> cexp
val c_any : cty -> cexp
type ext_cexp = let_defn list * cexp
val ext_c_sym : rsymbol -> ext_cexp
val ext_c_app : ext_cexp -> expr list -> ity list -> ity -> ext_cexp
val ext_c_pur : lsymbol -> expr list -> ity list -> ity -> ext_cexp
(** {2 Expression constructors} *)
val e_var : pvsymbol -> expr
......@@ -202,6 +190,7 @@ val e_nat_const : int -> expr
val e_exec : cexp -> expr
val e_app : rsymbol -> expr list -> ity list -> ity -> expr
val e_pur : lsymbol -> expr list -> ity list -> ity -> expr
val e_let : let_defn -> expr -> expr
......@@ -232,10 +221,12 @@ val e_while : expr -> invariant list -> variant list -> expr -> expr
val e_for : pvsymbol ->
expr -> for_direction -> expr -> invariant list -> expr -> expr
val e_pure : term -> expr
val e_assert : assertion_kind -> term -> expr
val e_ghostify : bool -> expr -> expr
val e_pure : term -> expr
val e_absurd : ity -> expr
(** {2 Expression manipulation tools} *)
......@@ -255,6 +246,9 @@ val c_rs_subst : rsymbol Mrs.t -> cexp -> cexp
val term_of_expr : prop:bool -> expr -> term option
val post_of_expr : term -> expr -> term option
val e_ghost : expr -> bool
val c_ghost : cexp -> bool
(** {2 Built-in symbols} *)
val rs_true : rsymbol
......@@ -278,9 +272,6 @@ val e_func_app_l : expr -> expr list -> expr
(** {2 Pretty-printing} *)
val forget_rs : rsymbol -> unit (* flush id_unique for a program symbol *)
val print_rs : Format.formatter -> rsymbol -> unit (* program symbol *)
val print_expr : Format.formatter -> expr -> unit (* expression *)
val print_let_defn : Format.formatter -> let_defn -> unit
This diff is collapsed.
......@@ -292,9 +292,26 @@ val pvs_of_vss : Spv.t -> Svs.t -> Spv.t
(** {2 Exception symbols} *)
type mask =
| MaskVisible
| MaskTuple of mask list
| MaskGhost
val mask_ghost : mask -> bool
val mask_of_pv : pvsymbol -> mask
val mask_union : mask -> mask -> mask
val mask_equal : mask -> mask -> bool
val mask_spill : mask -> mask -> bool
type xsymbol = private {
xs_name : ident;
xs_ity : ity; (** closed and immutable *)
xs_mask : mask;
}
module Mexn : Extmap.S with type key = xsymbol
......@@ -302,9 +319,9 @@ module Sexn : Extset.S with module M = Mexn
val xs_compare : xsymbol -> xsymbol -> int
val xs_equal : xsymbol -> xsymbol -> bool
val xs_hash: xsymbol -> int
val xs_hash : xsymbol -> int
val create_xsymbol : preid -> ity -> xsymbol
val create_xsymbol : preid -> ?mask:mask -> ity -> xsymbol
(** {2 Effects} *)
......@@ -320,8 +337,8 @@ exception GhostDivergence
type effect = private {
eff_reads : Spv.t; (* known variables *)
eff_writes : Spv.t Mreg.t; (* modifications to specific fields *)
eff_taints : Sreg.t; (* ghost modifications *)
eff_writes : Spv.t Mreg.t; (* writes to fields *)
eff_taints : Sreg.t; (* ghost code writes *)
eff_covers : Sreg.t; (* surviving writes *)
eff_resets : Sreg.t; (* locked by covers *)
eff_raises : Sexn.t; (* raised exceptions *)
......@@ -347,16 +364,15 @@ val eff_read_single_pre : pvsymbol -> effect -> effect
val eff_read_single_post : effect -> pvsymbol -> effect
val eff_bind_single : pvsymbol -> effect -> effect
val eff_reset : effect -> Sreg.t -> effect (* confine to an empty cover *)
val eff_reset_overwritten : effect -> effect (* confine regions under writes *)
val eff_reset : effect -> Sreg.t -> effect (* confine to an empty cover *)
val eff_reset_overwritten : effect -> effect (* confine regions under writes *)
val eff_raise : effect -> xsymbol -> effect
val eff_catch : effect -> xsymbol -> effect
val eff_diverge : effect -> effect (* forbidden if ghost *)
val eff_ghostify : bool -> effect -> effect (* forbidden if diverges *)
val eff_contagious : effect -> bool (* ghost and raising exceptions *)
val eff_diverge : effect -> effect (* forbidden if ghost *)
val eff_ghostify : bool -> effect -> effect (* forbidden if diverges *)
val eff_ghostify_weak : bool -> effect -> effect (* only if has no effect *)
val eff_union_seq : effect -> effect -> effect (* checks for stale variables *)
val eff_union_par : effect -> effect -> effect (* no stale-variable check *)
......@@ -377,13 +393,15 @@ type cty = private {
cty_oldies : pvsymbol Mpv.t;
cty_effect : effect;
cty_result : ity;
cty_mask : mask;
cty_freeze : ity_subst;
}
val create_cty : pvsymbol list ->
val create_cty : ?mask:mask -> pvsymbol list ->
pre list -> post list -> post list Mexn.t ->
pvsymbol Mpv.t -> effect -> ity -> cty
(** [create_cty args pre post xpost oldies effect result] creates a cty.
(** [create_cty ?mask args pre post xpost oldies effect result] creates
a computation type. [post] and [mask] must be consistent with [result].
The [cty_xpost] field does not have to cover all raised exceptions.
[cty_effect.eff_reads] is completed wrt the specification and [args].
[cty_freeze] freezes every unbound pvsymbol in [cty_effect.eff_reads].
......@@ -400,17 +418,30 @@ val cty_apply : cty -> pvsymbol list -> ity list -> ity -> cty
and returns the computation type of the result, [rest -> res],
with every type variable and region in [pvl] being frozen. *)
val cty_tuple : pvsymbol list -> cty
(** [cty_tuple pvl] returns a nullary tuple-valued cty with
an appropriate [cty_mask]. *)
val cty_ghost : cty -> bool
(** [cty_ghost cty] returns [cty.cty_effect.eff_ghost] *)
val cty_pure : cty -> bool
(** [cty_pure cty] verifies that [cty] has no side effects
except allocations. *)
val cty_ghostify : bool -> cty -> cty
(** [cty_ghostify ghost cty] ghostifies the effect of [cty]. *)
val cty_reads : cty -> Spv.t
(** [cty_reads cty] returns the set of external dependencies of [cty]. *)
val cty_add_reads : cty -> Spv.t -> cty
(** [cty_add_reads cty pvs] adds [pvs] to [cty.cty_effect.eff_reads].
val cty_read_pre : Spv.t -> cty -> cty
(** [cty_read_pre pvs cty] adds [pvs] to [cty.cty_effect.eff_reads].
This function performs capture: if some variables in [pvs] occur
in [cty.cty_args], they are not frozen. *)
val cty_read_post : cty -> Spv.t -> cty
(** [cty_read_post cty pvs] adds [pvs] to [cty.cty_effect.eff_reads].
This function performs capture: if some variables in [pvs] occur
in [cty.cty_args], they are not frozen. *)
......
......@@ -186,6 +186,7 @@ let get_syms node pure =
let rec syms_expr syms e = match e.e_node with
| Evar _ | Econst _ | Eabsurd -> syms
| Eassert (_,t) | Epure t -> syms_term syms t
| Eghost e -> syms_expr syms e
| Eexec c -> syms_cexp syms c
| Eassign al ->
let syms_as syms (v,s,u) =
......
......@@ -691,6 +691,7 @@ let clone_varl cl sm varl = List.map (fun (t,r) ->
clone_term cl sm.sm_vs t, Opt.map (cl_find_ls cl) r) varl
let clone_cty cl sm cty =
let res = clone_ity cl cty.cty_result in
let args = List.map (clone_pv cl) cty.cty_args in
let sm_args = List.fold_left2 sm_save_pv sm cty.cty_args args in
let add_old o n (sm, olds) = let o' = clone_pv cl o in
......@@ -703,8 +704,9 @@ let clone_cty cl sm cty =
let fl = clone_invl cl sm_olds fl in
Mexn.add xs fl q) cty.cty_xpost Mexn.empty in
let add_read v s = Spv.add (sm_find_pv sm_args v) s in
let reads = Spv.fold add_read cty.cty_effect.eff_reads Spv.empty in
let reads = Spv.union reads (Mpv.map ignore olds) in
let reads = Spv.fold add_read (cty_reads cty) Spv.empty in
let reads = List.fold_right add_read cty.cty_args reads in
let reads = Spv.union reads (Mpv.domain olds) in
let add_write reg fs m =
let add_fd fd s = Spv.add (Mpv.find_def fd fd cl.fd_table) s in
Mreg.add (clone_reg cl reg) (Spv.fold add_fd fs Spv.empty) m in
......@@ -712,11 +714,11 @@ let clone_cty cl sm cty =
let add_reset reg s = Sreg.add (clone_reg cl reg) s in
let resets = Sreg.fold add_reset cty.cty_effect.eff_resets Sreg.empty in
let eff = eff_reset (eff_write reads writes) resets in
let eff = eff_ghostify cty.cty_effect.eff_ghost eff in
let add_raise xs eff = eff_raise eff (cl_find_xs cl xs) in
let eff = Sexn.fold add_raise cty.cty_effect.eff_raises eff in
let eff = if cty.cty_effect.eff_oneway then eff_diverge eff else eff in
create_cty args pre post xpost olds eff (clone_ity cl cty.cty_result)
let cty = create_cty ~mask:cty.cty_mask args pre post xpost olds eff res in
cty_ghostify (cty_ghost cty) cty
let sm_save_args sm c c' =
List.fold_left2 sm_save_pv sm c.cty_args c'.cty_args
......@@ -733,37 +735,21 @@ let rs_kind s = match s.rs_logic with
| RLls _ -> RKfunc
| RLlemma -> RKlemma
let clone_ppat cl sm ~ghost pp =
let clone_ppat cl sm pp mask =
let rec conv_pat p = match p.pat_node with
| Term.Pwild -> PPwild
| Term.Pvar v -> PPvar (id_clone v.vs_name)
| Term.Pvar v -> PPvar (id_clone v.vs_name, (restore_pv v).pv_ghost)
| Term.Pas (p,v) ->
PPas (conv_pat p, id_clone v.vs_name, (restore_pv v).pv_ghost)
| Term.Por (p1,p2) -> PPor (conv_pat p1, conv_pat p2)
| Term.Pas (p,v) -> PPas (conv_pat p, id_clone v.vs_name)
| Term.Papp (s,pl) ->
PPapp (restore_rs (cl_find_ls cl s), List.map conv_pat pl) in
let pre = conv_pat pp.pp_pat in
(* FIXME: if we clone pp using its own ghost status pp.pp_ghost,
we may ghostify too many variables. This may happen if we have
a match over a non-ghost expression with a single branch with
a ghostifying pattern (= some ghost subvalue is deep-matched).
Since there is only one branch, this match will be non-ghost,
and all non-ghost variables in the pattern must stay so, too.
To avoid the problem, we pass to create_prog_pattern the ghost
status of the matched expression. This, however, may also break,
if someone created a match over a non-ghost expression with a
single branch with an artificially ghostified pattern (that is,
by calling create_prog_pattern ~ghost:true). In this case, we
may not ghostify some variables which were ghost in the original
pattern, and perform unnecessary computations in the cloned code.
This exploit is only possible via API, since Dexpr always passes
to create_prog_pattern the ghost status of the matched expr. *)
let vm, pp' = create_prog_pattern pre ~ghost pp.pp_ity in
let vm, pp' = create_prog_pattern pre pp.pp_ity mask in
let save v sm = sm_save_vs sm v (Mstr.find v.vs_name.id_string vm) in
Svs.fold save pp.pp_pat.pat_vars sm, pp'
let rec clone_expr cl sm e = e_label_copy e (e_ghostify (e_ghost e)
(match e.e_node with
let rec clone_expr cl sm e = e_label_copy e (match e.e_node with
| Evar v -> e_var (sm_find_pv sm v)
| Econst c -> e_const c
| Eexec c -> e_exec (clone_cexp cl sm c)
......@@ -777,11 +763,11 @@ let rec clone_expr cl sm e = e_label_copy e (e_ghostify (e_ghost e)
| Eif (e1, e2, e3) ->
e_if (clone_expr cl sm e1) (clone_expr cl sm e2) (clone_expr cl sm e3)
| Ecase (d, bl) ->
let ghost = e_ghost d in
let d = clone_expr cl sm d in
let conv_br (pp, e) =
let sm, pp = clone_ppat cl sm ~ghost pp in
let sm, pp = clone_ppat cl sm pp d.e_mask in
pp, clone_expr cl sm e in
e_case (clone_expr cl sm d) (List.map conv_br bl)
e_case d (List.map conv_br bl)
| Ewhile (c,invl,varl,e) ->
e_while (clone_expr cl sm c) (clone_invl cl sm invl)
(clone_varl cl sm varl) (clone_expr cl sm e)
......@@ -800,11 +786,13 @@ let rec clone_expr cl sm e = e_label_copy e (e_ghostify (e_ghost e)
e_raise (cl_find_xs cl xs) (clone_expr cl sm e) (clone_ity cl e.e_ity)
| Eassert (k, f) ->
e_assert k (clone_term cl sm.sm_vs f)
| Eghost e ->
e_ghostify true (clone_expr cl sm e)
| Epure t ->
e_pure (clone_term cl sm.sm_vs t)
| Eabsurd -> e_absurd (clone_ity cl e.e_ity)))
| Eabsurd -> e_absurd (clone_ity cl e.e_ity))
and clone_cexp cl sm c = c_ghostify (cty_ghost c.c_cty) (match c.c_node with
and clone_cexp cl sm c = match c.c_node with
| Capp (s,vl) ->
let vl = List.map (fun v -> sm_find_pv sm v) vl in
let al = List.map (fun v -> clone_ity cl v.pv_ity) c.c_cty.cty_args in
......@@ -819,10 +807,10 @@ and clone_cexp cl sm c = c_ghostify (cty_ghost c.c_cty) (match c.c_node with
let cty = clone_cty cl sm c.c_cty in
let sm = sm_save_args sm c.c_cty cty in
let sm = sm_save_olds sm c.c_cty cty in
c_fun cty.cty_args cty.cty_pre cty.cty_post
cty.cty_xpost cty.cty_oldies (clone_expr cl sm e)
c_fun ~mask:cty.cty_mask cty.cty_args cty.cty_pre
cty.cty_post cty.cty_xpost cty.cty_oldies (clone_expr cl sm e)
| Cany ->
c_any (clone_cty cl sm c.c_cty))
c_any (clone_cty cl sm c.c_cty)
and clone_let_defn cl sm ld = match ld with
| LDvar (v,e) ->
......@@ -850,8 +838,8 @@ and clone_let_defn cl sm ld = match ld with
let e = match c.c_node with
| Cfun e -> clone_expr cl rsm e
| _ -> assert false (* can't be *) in
let c = c_fun cty.cty_args pre
cty.cty_post cty.cty_xpost cty.cty_oldies e in
let c = c_fun ~mask:c.c_cty.cty_mask cty.cty_args
pre cty.cty_post cty.cty_xpost cty.cty_oldies e in
rs, c, varl, rs_kind rd.rec_sym in
let ld, rdl' = let_rec (List.map2 conv_rd rdl rsyml) in
let sm = List.fold_left2 (fun sm d d' ->
......
......@@ -486,17 +486,15 @@ term_:
| IF term THEN term ELSE term
{ Tif ($2, $4, $6) }
| LET pattern EQUAL term IN term
{ match $2.pat_desc with
| Pvar id -> Tlet (id, $4, $6)
| Pwild -> Tlet (id_anonymous $2.pat_loc, $4, $6)
| Ptuple [] -> Tlet (id_anonymous $2.pat_loc,
{ $4 with term_desc = Tcast ($4, PTtuple []) }, $6)
| Pcast ({pat_desc = Pvar id}, ty) ->
Tlet (id, { $4 with term_desc = Tcast ($4, ty) }, $6)
| Pcast ({pat_desc = Pwild}, ty) ->
let id = id_anonymous $2.pat_loc in
Tlet (id, { $4 with term_desc = Tcast ($4, ty) }, $6)
| _ -> Tmatch ($4, [$2, $6]) }
{ let cast ty = { $4 with term_desc = Tcast ($4, ty) } in
let pat, def = match $2.pat_desc with
| Ptuple [] -> { $2 with pat_desc = Pwild }, cast (PTtuple [])
| Pcast ({pat_desc = (Pvar (_,false)|Pwild)} as p, ty) -> p, cast ty
| _ -> $2, $4 in
match pat.pat_desc with
| Pvar (id,false) -> Tlet (id, def, $6)
| Pwild -> Tlet (id_anonymous pat.pat_loc, def, $6)
| _ -> Tmatch (def, [pat, $6]) }
| LET labels(lident_op_id) EQUAL term IN term
{ Tlet ($2, $4, $6) }
| LET labels(lident) mk_term(lam_defn) IN term
......@@ -608,15 +606,16 @@ kind:
(* Function definitions *)
rec_defn:
| ghost kind labels(lident_rich) binders cast? spec EQUAL spec seq_expr
{ $3, $1, $2, $4, $5, spec_union $6 $8, $9 }
| ghost kind labels(lident_rich) binders ret_opt spec EQUAL spec seq_expr
{ $3, $1, $2, $4, fst $5, snd $5, spec_union $6 $8, $9 }
fun_defn:
| binders cast? spec EQUAL spec seq_expr
{ Efun ($1, $2, spec_union $3 $5, $6) }
| binders ret_opt spec EQUAL spec seq_expr
{ Efun ($1, fst $2, snd $2, spec_union $3 $5, $6) }
val_defn:
| params cast? spec { Eany ($1, Expr.RKnone, $2, $3) }
| params ret_opt spec
{ Eany ($1, Expr.RKnone, fst $2, snd $2, $3) }
(* Program expressions *)
......@@ -669,23 +668,33 @@ expr_:
| Etuple ll, Etuple rl -> Eassign (down ll rl)
| Etuple _, _ -> Loc.errorm ~loc "Invalid parallel assignment"
| _, _ -> Eassign (down [$1] [$3]) }
| LET ghost kind pattern EQUAL seq_expr IN seq_expr
{ match $4.pat_desc with
| Pvar id -> Elet (id, $2, $3, $6, $8)
| Pwild -> Elet (id_anonymous $4.pat_loc, $2, $3, $6, $8)
| Ptuple [] -> Elet (id_anonymous $4.pat_loc, $2, $3,
{ $6 with expr_desc = Ecast ($6, PTtuple []) }, $8)
| Pcast ({pat_desc = Pvar id}, ty) ->
Elet (id, $2, $3, { $6 with expr_desc = Ecast ($6, ty) }, $8)
| Pcast ({pat_desc = Pwild}, ty) ->
let id = id_anonymous $4.pat_loc in
Elet (id, $2, $3, { $6 with expr_desc = Ecast ($6, ty) }, $8)
| _ ->
let e = if $2 then { $6 with expr_desc = Eghost $6 } else $6 in
(match $3 with
| Expr.RKnone -> Ematch (e, [$4, $8])
| _ -> Loc.errorm ~loc:($4.pat_loc)
"`let <kind>' cannot be used with complex patterns") }
| LET ghost kind let_pattern EQUAL seq_expr IN seq_expr
{ let re_pat pat d = { pat with pat_desc = d } in
let rec ghostify pat = match pat.pat_desc with
(* let_pattern marks the opening variable with Ptuple [_] *)
| Ptuple [{pat_desc = Pvar (id,_)}] -> re_pat pat (Pvar (id,$2))
| Ptuple (p::pl) -> re_pat pat (Ptuple (ghostify p :: pl))
| Pas (p,id,gh) -> re_pat pat (Pas (ghostify p, id, gh))
| Por (p1,p2) -> re_pat pat (Por (ghostify p1, p2))
| Pcast (p,t) -> re_pat pat (Pcast (ghostify p, t))
| _ when $2 -> Loc.errorm ~loc:(floc $startpos($2) $endpos($2))
"illegal ghost qualifier" (* $4 does not start with a Pvar *)
| _ -> pat in
let pat = ghostify $4 in
let kind = match pat.pat_desc with
| _ when $3 = Expr.RKnone -> $3
| Pvar (_,_) | Pcast ({pat_desc = Pvar (_,_)},_) -> $3
| _ -> Loc.errorm ~loc:(floc $startpos($3) $endpos($3))
"illegal kind qualifier" in
let cast ty = { $6 with expr_desc = Ecast ($6, ty) } in
let pat, def = match pat.pat_desc with
| Ptuple [] -> re_pat pat Pwild, cast (PTtuple [])
| Pcast ({pat_desc = (Pvar _|Pwild)} as pat, ty) -> pat, cast ty
| _ -> pat, $6 in
match pat.pat_desc with
| Pvar (id, gh) -> Elet (id, gh, kind, def, $8)
| Pwild -> Elet (id_anonymous pat.pat_loc, false, kind, def, $8)
| _ -> Ematch (def, [pat, $8]) }
| LET ghost kind labels(lident_op_id) EQUAL seq_expr IN seq_expr
{ Elet ($4, $2, $3, $6, $8) }
| LET ghost kind labels(lident) mk_expr(fun_defn) IN seq_expr
......@@ -695,11 +704,11 @@ expr_:
| LET REC with_list1(rec_defn) IN seq_expr
{ Erec ($3, $5) }
| FUN binders spec ARROW spec seq_expr
{ Efun ($2, None, spec_union $3 $5, $6) }
{ Efun ($2, None, Ity.MaskVisible, spec_union $3 $5, $6) }
| ABSTRACT spec seq_expr END
{ Efun ([], None, $2, $3) }
| ANY ty spec
{ Eany ([], Expr.RKnone, Some $2, $3) }
{ Efun ([], None, Ity.MaskVisible, $2, $3) }
| ANY return spec
{ Eany ([], Expr.RKnone, Some (fst $2), snd $2, $3) }
| VAL ghost kind labels(lident_rich) mk_expr(val_defn) IN seq_expr
{ Elet ($4, $2, $3, $5, $7) }
| MATCH seq_expr WITH match_cases(seq_expr) END
......@@ -814,7 +823,7 @@ single_spec:
ensures:
| term
{ let id = mk_id "result" $startpos $endpos in
[mk_pat (Pvar id) $startpos $endpos, $1] }
[mk_pat (Pvar (id,false)) $startpos $endpos, $1] }
raises:
| uqualid ARROW term
......@@ -835,6 +844,30 @@ variant:
single_variant:
| term preceded(WITH,lqualid)? { $1, $2 }
ret_opt:
| (* epsilon *) { None, Ity.MaskVisible }
| COLON return { Some (fst $2), snd $2 }
return:
| ret_arg { $1 }
| lqualid ty_arg+ { PTtyapp ($1, $2), Ity.MaskVisible }
| ret_arg ARROW ty { PTarrow (fst $1, $3),
if Ity.mask_ghost (snd $1) then
raise Error else Ity.MaskVisible }
| GHOST ty { $2, Ity.MaskGhost }
ret_arg:
| lqualid { PTtyapp ($1, []), Ity.MaskVisible }
| quote_lident { PTtyvar $1, Ity.MaskVisible }
| LEFTPAR RIGHTPAR { PTtuple [], Ity.MaskVisible }
| LEFTPAR ret_sub RIGHTPAR { PTparen (fst $2), snd $2 }
| LEFTPAR comma_list2(ret_sub) RIGHTPAR { PTtuple (List.map fst $2),
Ity.MaskTuple (List.map snd $2) }
ret_sub:
| ty { $1, Ity.MaskVisible }
| GHOST ty { $2, Ity.MaskGhost }
(* Patterns *)
mk_pat(X): X { mk_pat $1 $startpos $endpos }
......@@ -853,17 +886,46 @@ pat_conj_:
pat_uni_:
| pat_arg_ { $1 }
| uqualid pat_arg+ { Papp ($1,$2) }
| mk_pat(pat_uni_) AS labels(lident) { Pas ($1,$3) }
| mk_pat(pat_uni_) cast { Pcast($1,$2) }
| mk_pat(pat_uni_) AS ghost labels(lident)
{ Pas ($1,$4,$3) }
| mk_pat(pat_uni_) cast { Pcast ($1,$2) }
pat_arg_:
| pat_arg_shared_ { $1 }
| labels(lident) { Pvar ($1,false) }
| GHOST labels(lident) { Pvar ($2,true) }
pat_arg_shared_:
| UNDERSCORE { Pwild }
| labels(lident) { Pvar $1 }
| uqualid { Papp ($1,[]) }
| LEFTPAR RIGHTPAR { Ptuple [] }
| LEFTPAR pattern_ RIGHTPAR { $2 }
| LEFTBRC field_list1(pattern) RIGHTBRC { Prec $2 }
(* let-patterns that cannot start with "ghost" *)
let_pattern: mk_pat(let_pattern_) { $1 }
let_pattern_:
| let_pat_conj_ { $1 }
| mk_pat(let_pat_conj_) BAR pattern { Por ($1,$3) }
let_pat_conj_:
| let_pat_uni_ { $1 }
| mk_pat(let_pat_uni_) COMMA comma_list1(mk_pat(pat_uni_))
{ Ptuple ($1::$3) }
let_pat_uni_:
| let_pat_arg_ { $1 }
| uqualid pat_arg+ { Papp ($1,$2) }
| mk_pat(let_pat_uni_) AS ghost labels(lident)
{ Pas ($1,$4,$3) }
| mk_pat(let_pat_uni_) cast { Pcast ($1,$2) }
let_pat_arg_:
| pat_arg_shared_ { $1 }
| labels(lident) { Ptuple [{pat_desc = Pvar ($1,false); pat_loc = $1.id_loc}] }
(* Idents *)
ident:
......
......@@ -36,6 +36,8 @@ type pty =
(*s Patterns *)
type ghost = bool
type pattern = {
pat_desc : pat_desc;
pat_loc : Loc.position;
......@@ -43,18 +45,16 @@ type pattern = {
and pat_desc =
| Pwild
| Pvar of ident
| Pvar of ident * ghost
| Papp of qualid * pattern list
| Prec of (qualid * pattern) list
| Ptuple of pattern list
| Pas of pattern * ident * ghost
| Por of pattern * pattern
| Pas of pattern * ident
| Pcast of pattern * pty
(*s Logical terms and formulas *)
type ghost = bool
type binder = Loc.position * ident option * ghost * pty option
type param = Loc.position * ident option * ghost * pty
......@@ -123,8 +123,8 @@ and expr_desc =
| Einnfix of expr * ident * expr
| Elet of ident * ghost * Expr.rs_kind * expr * expr
| Erec of fundef list * expr
| Efun of binder list * pty option * spec * expr
| Eany of param list * Expr.rs_kind * pty option * spec
| Efun of binder list * pty option * Ity.mask * spec * expr
| Eany of param list * Expr.rs_kind * pty option * Ity.mask * spec
| Etuple of expr list
| Erecord of (qualid * expr) list
| Eupdate of expr * (qualid * expr) list
......@@ -148,8 +148,8 @@ and expr_desc =
| Eghost of expr
| Enamed of label * expr
and fundef =
ident * ghost * Expr.rs_kind * binder list * pty option * spec * expr
and fundef = ident * ghost * Expr.rs_kind *
binder list * pty option * Ity.mask * spec * expr
(*s Declarations *)
......
......@@ -171,8 +171,8 @@ let parse_record ~loc tuc get_val fl =
let rec dpattern tuc { pat_desc = desc; pat_loc = loc } =
Dterm.dpattern ~loc (match desc with
| Ptree.Pwild -> DPwild
| Ptree.Pvar x -> DPvar (create_user_id x)
| Ptree.Papp (q,pl) ->
| Ptree.Pvar (x, false) -> DPvar (create_user_id x)
| Ptree.Papp (q, pl) ->
let pl = List.map (dpattern tuc) pl in
DPapp (find_lsymbol tuc q, pl)
| Ptree.Ptuple pl ->
......@@ -184,12 +184,14 @@ let rec dpattern tuc { pat_desc = desc; pat_loc = loc } =
| None -> Dterm.dpattern DPwild in
let cs,fl = parse_record ~loc tuc get_val fl in
DPapp (cs,fl)
| Ptree.Pas (p, x) -> DPas (dpattern tuc p, create_user_id x)
| Ptree.Pas (p, x, false) -> DPas (dpattern tuc p, create_user_id x)
| Ptree.Por (p, q) -> DPor (dpattern tuc p, dpattern tuc q)
| Ptree.Pcast (p, ty) -> DPcast (dpattern tuc p, ty_of_pty tuc ty))
| Ptree.Pcast (p, ty) -> DPcast (dpattern tuc p, ty_of_pty tuc ty)
| Ptree.Pvar (_, true) | Ptree.Pas (_, _, true) -> Loc.errorm ~loc