Section EXPRS.
Variable e: env.
Variable w: world.
Fixpoint sem_cast_arguments (vtl: list (val * type)) (tl: typelist) (m: mem) : option (list val) :=
match vtl, tl with
| nil, Tnil => Some nil
| (v1,t1)::vtl, Tcons t1' tl =>
do v <- sem_cast v1 t1 t1' m; do vl <- sem_cast_arguments vtl tl m; Some(v::vl)
| _, _ => None
end.
(** The result of stepping an expression is a list [ll] of possible reducts. Each element of [ll] is a pair of a context and the result of reducing inside this context (see type [reduction] above). The list [ll] is empty if the expression is fully reduced (it's [Eval] for a r-value and [Eloc] for a l-value). *)
Definition reducts (A: Type): Type := list ((expr -> A) * reduction).
Definition topred (r: reduction) : reducts expr :=
((fun (x: expr) => x), r) :: nil.
Definition stuck : reducts expr :=
((fun (x: expr) => x), Stuckred) :: nil.
Definition incontext {A B: Type} (ctx: A -> B) (ll: reducts A) : reducts B :=
map (fun z => ((fun (x: expr) => ctx(fst z x)), snd z)) ll.
Definition incontext2 {A1 A2 B: Type}
(ctx1: A1 -> B) (ll1: reducts A1)
(ctx2: A2 -> B) (ll2: reducts A2) : reducts B :=
incontext ctx1 ll1 ++ incontext ctx2 ll2.
Notation "'do' X <- A ; B" := (match A with Some X => B | None => stuck end)
(at level 200, X ident, A at level 100, B at level 200)
: reducts_monad_scope.
Notation "'do' X , Y <- A ; B" := (match A with Some (X, Y) => B | None => stuck end)
(at level 200, X ident, Y ident, A at level 100, B at level 200)
: reducts_monad_scope.
Notation "'do' X , Y , Z <- A ; B" := (match A with Some (X, Y, Z) => B | None => stuck end)
(at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200)
: reducts_monad_scope.
Notation " 'check' A ; B" := (if A then B else stuck)
(at level 200, A at level 100, B at level 200)
: reducts_monad_scope.
Local Open Scope reducts_monad_scope.
Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr :=
match k, a with
| LV, Eloc b ofs ty =>
nil
| LV, Evar x ty =>
match e!x with
| Some(b, ty') =>
check type_eq ty ty';
topred (Lred "red_var_local" (Eloc b Ptrofs.zero ty) m)
| None =>
do b <- Genv.find_symbol ge x;
topred (Lred "red_var_global" (Eloc b Ptrofs.zero ty) m)
end
| LV, Ederef r ty =>
match is_val r with
| Some(Vptr b ofs, ty') =>
topred (Lred "red_deref" (Eloc b ofs ty) m)
| Some _ =>
stuck
| None =>
incontext (fun x => Ederef x ty) (step_expr RV r m)
end
| LV, Efield r f ty =>
match is_val r with
| Some(Vptr b ofs, ty') =>
match ty' with
| Tstruct id _ =>
do co <- ge.(genv_cenv)!id;
match field_offset ge f (co_members co) with
| Error _ => stuck
| OK delta => topred (Lred "red_field_struct" (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) ty) m)
end
| Tunion id _ =>
do co <- ge.(genv_cenv)!id;
topred (Lred "red_field_union" (Eloc b ofs ty) m)
| _ => stuck
end
| Some _ =>
stuck
| None =>
incontext (fun x => Efield x f ty) (step_expr RV r m)
end
| RV, Eval v ty =>
nil
| RV, Evalof l ty =>
match is_loc l with
| Some(b, ofs, ty') =>
check type_eq ty ty';
do w',t,v <- do_deref_loc w ty m b ofs;
topred (Rred "red_rvalof" (Eval v ty) m t)
| None =>
incontext (fun x => Evalof x ty) (step_expr LV l m)
end
| RV, Eaddrof l ty =>
match is_loc l with
| Some(b, ofs, ty') => topred (Rred "red_addrof" (Eval (Vptr b ofs) ty) m E0)
| None => incontext (fun x => Eaddrof x ty) (step_expr LV l m)
end
| RV, Eunop op r1 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do v <- sem_unary_operation op v1 ty1 m;
topred (Rred "red_unop" (Eval v ty) m E0)
| None =>
incontext (fun x => Eunop op x ty) (step_expr RV r1 m)
end
| RV, Ebinop op r1 r2 ty =>
match is_val r1, is_val r2 with
| Some(v1, ty1), Some(v2, ty2) =>
do v <- sem_binary_operation ge op v1 ty1 v2 ty2 m;
topred (Rred "red_binop" (Eval v ty) m E0)
| _, _ =>
incontext2 (fun x => Ebinop op x r2 ty) (step_expr RV r1 m)
(fun x => Ebinop op r1 x ty) (step_expr RV r2 m)
end
| RV, Ecast r1 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do v <- sem_cast v1 ty1 ty m;
topred (Rred "red_cast" (Eval v ty) m E0)
| None =>
incontext (fun x => Ecast x ty) (step_expr RV r1 m)
end
| RV, Eseqand r1 r2 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do b <- bool_val v1 ty1 m;
if b then topred (Rred "red_seqand_true" (Eparen r2 type_bool ty) m E0)
else topred (Rred "red_seqand_false" (Eval (Vint Int.zero) ty) m E0)
| None =>
incontext (fun x => Eseqand x r2 ty) (step_expr RV r1 m)
end
| RV, Eseqor r1 r2 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do b <- bool_val v1 ty1 m;
if b then topred (Rred "red_seqor_true" (Eval (Vint Int.one) ty) m E0)
else topred (Rred "red_seqor_false" (Eparen r2 type_bool ty) m E0)
| None =>
incontext (fun x => Eseqor x r2 ty) (step_expr RV r1 m)
end
| RV, Econdition r1 r2 r3 ty =>
match is_val r1 with
| Some(v1, ty1) =>
do b <- bool_val v1 ty1 m;
topred (Rred "red_condition" (Eparen (if b then r2 else r3) ty ty) m E0)
| None =>
incontext (fun x => Econdition x r2 r3 ty) (step_expr RV r1 m)
end
| RV, Esizeof ty' ty =>
topred (Rred "red_sizeof" (Eval (Vptrofs (Ptrofs.repr (sizeof ge ty'))) ty) m E0)
| RV, Ealignof ty' ty =>
topred (Rred "red_alignof" (Eval (Vptrofs (Ptrofs.repr (alignof ge ty'))) ty) m E0)
| RV, Eassign l1 r2 ty =>
match is_loc l1, is_val r2 with
| Some(b, ofs, ty1), Some(v2, ty2) =>
check type_eq ty1 ty;
do v <- sem_cast v2 ty2 ty1 m;
do w',t,m' <- do_assign_loc w ty1 m b ofs v;
topred (Rred "red_assign" (Eval v ty) m' t)
| _, _ =>
incontext2 (fun x => Eassign x r2 ty) (step_expr LV l1 m)
(fun x => Eassign l1 x ty) (step_expr RV r2 m)
end
| RV, Eassignop op l1 r2 tyres ty =>
match is_loc l1, is_val r2 with
| Some(b, ofs, ty1), Some(v2, ty2) =>
check type_eq ty1 ty;
do w',t,v1 <- do_deref_loc w ty1 m b ofs;
let r' := Eassign (Eloc b ofs ty1)
(Ebinop op (Eval v1 ty1) (Eval v2 ty2) tyres) ty1 in
topred (Rred "red_assignop" r' m t)
| _, _ =>
incontext2 (fun x => Eassignop op x r2 tyres ty) (step_expr LV l1 m)
(fun x => Eassignop op l1 x tyres ty) (step_expr RV r2 m)
end
| RV, Epostincr id l ty =>
match is_loc l with
| Some(b, ofs, ty1) =>
check type_eq ty1 ty;
do w',t, v1 <- do_deref_loc w ty m b ofs;
let op := match id with Incr => Oadd | Decr => Osub end in
let r' :=
Ecomma (Eassign (Eloc b ofs ty)
(Ebinop op (Eval v1 ty) (Eval (Vint Int.one) type_int32s) (incrdecr_type ty))
ty)
(Eval v1 ty) ty in
topred (Rred "red_postincr" r' m t)
| None =>
incontext (fun x => Epostincr id x ty) (step_expr LV l m)
end
| RV, Ecomma r1 r2 ty =>
match is_val r1 with
| Some _ =>
check type_eq (typeof r2) ty;
topred (Rred "red_comma" r2 m E0)
| None =>
incontext (fun x => Ecomma x r2 ty) (step_expr RV r1 m)
end
| RV, Eparen r1 tycast ty =>
match is_val r1 with
| Some (v1, ty1) =>
do v <- sem_cast v1 ty1 tycast m;
topred (Rred "red_paren" (Eval v ty) m E0)
| None =>
incontext (fun x => Eparen x tycast ty) (step_expr RV r1 m)
end
| RV, Ecall r1 rargs ty =>
match is_val r1, is_val_list rargs with
| Some(vf, tyf), Some vtl =>
match classify_fun tyf with
| fun_case_f tyargs tyres cconv =>
do fd <- Genv.find_funct ge vf;
do vargs <- sem_cast_arguments vtl tyargs m;
check type_eq (type_of_fundef fd) (Tfunction tyargs tyres cconv);
topred (Callred "red_call" fd vargs ty m)
| _ => stuck
end
| _, _ =>
incontext2 (fun x => Ecall x rargs ty) (step_expr RV r1 m)
(fun x => Ecall r1 x ty) (step_exprlist rargs m)
end
| RV, Ebuiltin ef tyargs rargs ty =>
match is_val_list rargs with
| Some vtl =>
do vargs <- sem_cast_arguments vtl tyargs m;
match do_external ef w vargs m with
| None => stuck
| Some(w',t,v,m') => topred (Rred "red_builtin" (Eval v ty) m' t)
end
| _ =>
incontext (fun x => Ebuiltin ef tyargs x ty) (step_exprlist rargs m)
end
| _, _ => stuck
end
with step_exprlist (rl: exprlist) (m: mem): reducts exprlist :=
match rl with
| Enil =>
nil
| Econs r1 rs =>
incontext2 (fun x => Econs x rs) (step_expr RV r1 m)
(fun x => Econs r1 x) (step_exprlist rs m)
end.
(** Technical properties on safe expressions. *)
Inductive imm_safe_t: kind -> expr -> mem -> Prop :=
| imm_safe_t_val: forall v ty m,
imm_safe_t RV (Eval v ty) m
| imm_safe_t_loc: forall b ofs ty m,
imm_safe_t LV (Eloc b ofs ty) m
| imm_safe_t_lred: forall to C l m l' m',
lred ge e l m l' m' ->
context LV to C ->
imm_safe_t to (C l) m
| imm_safe_t_rred: forall to C r m t r' m' w',
rred ge r m t r' m' -> possible_trace w t w' ->
context RV to C ->
imm_safe_t to (C r) m
| imm_safe_t_callred: forall to C r m fd args ty,
callred ge r m fd args ty ->
context RV to C ->
imm_safe_t to (C r) m.
Remark imm_safe_t_imm_safe:
forall k a m, imm_safe_t k a m -> imm_safe ge e k a m.
Fixpoint exprlist_all_values (rl: exprlist) : Prop :=
match rl with
| Enil => True
| Econs (Eval v ty) rl' => exprlist_all_values rl'
| Econs _ _ => False
end.
Definition invert_expr_prop (a: expr) (m: mem) : Prop :=
match a with
| Eloc b ofs ty => False
| Evar x ty =>
exists b,
e!x = Some(b, ty)
\/ (e!x = None /\ Genv.find_symbol ge x = Some b)
| Ederef (Eval v ty1) ty =>
exists b, exists ofs, v = Vptr b ofs
| Efield (Eval v ty1) f ty =>
exists b, exists ofs, v = Vptr b ofs /\
match ty1 with
| Tstruct id _ => exists co delta, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = OK delta
| Tunion  id _ => exists co, ge.(genv_cenv)!id = Some co
| _ => False
end
| Eval v ty => False
| Evalof (Eloc b ofs ty') ty =>
ty' = ty /\ exists t, exists v, exists w', deref_loc ge ty m b ofs t v /\ possible_trace w t w'
| Eunop op (Eval v1 ty1) ty =>
exists v, sem_unary_operation op v1 ty1 m = Some v
| Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty =>
exists v, sem_binary_operation ge op v1 ty1 v2 ty2 m = Some v
| Ecast (Eval v1 ty1) ty =>
exists v, sem_cast v1 ty1 ty m = Some v
| Eseqand (Eval v1 ty1) r2 ty =>
exists b, bool_val v1 ty1 m = Some b
| Eseqor (Eval v1 ty1) r2 ty =>
exists b, bool_val v1 ty1 m = Some b
| Econdition (Eval v1 ty1) r1 r2 ty =>
exists b, bool_val v1 ty1 m = Some b
| Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty =>
exists v, exists m', exists t, exists w',
ty = ty1 /\ sem_cast v2 ty2 ty1 m = Some v /\ assign_loc ge ty1 m b ofs v t m' /\ possible_trace w t w'
| Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty =>
exists t, exists v1, exists w',
ty = ty1 /\ deref_loc ge ty1 m b ofs t v1 /\ possible_trace w t w'
| Epostincr id (Eloc b ofs ty1) ty =>
exists t, exists v1, exists w',
ty = ty1 /\ deref_loc ge ty m b ofs t v1 /\ possible_trace w t w'
| Ecomma (Eval v ty1) r2 ty =>
typeof r2 = ty
| Eparen (Eval v1 ty1) tycast ty =>
exists v, sem_cast v1 ty1 tycast m = Some v
| Ecall (Eval vf tyf) rargs ty =>
exprlist_all_values rargs ->
exists tyargs tyres cconv fd vl,
classify_fun tyf = fun_case_f tyargs tyres cconv
/\ Genv.find_funct ge vf = Some fd
/\ cast_arguments m rargs tyargs vl
/\ type_of_fundef fd = Tfunction tyargs tyres cconv
| Ebuiltin ef tyargs rargs ty =>
exprlist_all_values rargs ->
exists vargs t vres m' w',
cast_arguments m rargs tyargs vargs
/\ external_call ef ge vargs m t vres m'
/\ possible_trace w t w'
| _ => True
end.
Scheme context_ind2 := Minimality for context Sort Prop
with contextlist_ind2 := Minimality for contextlist Sort Prop.
Combined Scheme context_contextlist_ind from context_ind2, contextlist_ind2.
(** Soundness: if [step_expr] returns [Some ll], then every element of [ll] is a reduct. *)
Local Hint Constructors context contextlist : core.
Local Hint Resolve context_compose contextlist_compose : core.
Definition reduction_ok (k: kind) (a: expr) (m: mem) (rd: reduction) : Prop :=
match k, rd with
| LV, Lred _ l' m' => lred ge e a m l' m'
| RV, Rred _ r' m' t => rred ge a m t r' m' /\ exists w', possible_trace w t w'
| RV, Callred _ fd args tyres m' => callred ge a m fd args tyres /\ m' = m
| LV, Stuckred => ~imm_safe_t k a m
| RV, Stuckred => ~imm_safe_t k a m
| _, _ => False
end.
Definition reducts_ok (k: kind) (a: expr) (m: mem) (ll: reducts expr) : Prop :=
(forall C rd,
In (C, rd) ll ->
exists a', exists k', context k' k C /\ a = C a' /\ reduction_ok k' a' m rd)
/\ (ll = nil -> match k with LV => is_loc a <> None | RV => is_val a <> None end).
Definition list_reducts_ok (al: exprlist) (m: mem) (ll: reducts exprlist) : Prop :=
(forall C rd,
In (C, rd) ll ->
exists a', exists k', contextlist k' C /\ al = C a' /\ reduction_ok k' a' m rd)
/\ (ll = nil -> is_val_list al <> None).
Ltac monadInv :=
match goal with
| [ H: match ?x with Some _ => _ | None => None end = Some ?y |- _ ] =>
destruct x eqn:?; [monadInv|discriminate]
| [ H: match ?x with left _ => _ | right _ => None end = Some ?y |- _ ] =>
destruct x; [monadInv|discriminate]
| _ => idtac
end.

Lemma wrong_kind_ok:
forall k a m,
k <> Cstrategy.expr_kind a ->
reducts_ok k a m stuck.