Section SIMPLE_EXPRS.
Variable e: env.
Variable m: mem.
Inductive eval_simple_lvalue: expr -> block -> ptrofs -> Prop :=
| esl_loc: forall b ofs ty,
eval_simple_lvalue (Eloc b ofs ty) b ofs
| esl_var_local: forall x ty b,
e!x = Some(b, ty) ->
eval_simple_lvalue (Evar x ty) b Ptrofs.zero
| esl_var_global: forall x ty b,
e!x = None ->
Genv.find_symbol ge x = Some b ->
eval_simple_lvalue (Evar x ty) b Ptrofs.zero
| esl_deref: forall r ty b ofs,
eval_simple_rvalue r (Vptr b ofs) ->
eval_simple_lvalue (Ederef r ty) b ofs
| esl_field_struct: forall r f ty b ofs id co a delta,
eval_simple_rvalue r (Vptr b ofs) ->
typeof r = Tstruct id a ->
ge.(genv_cenv)!id = Some co ->
field_offset ge f (co_members co) = OK delta ->
eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta))
| esl_field_union: forall r f ty b ofs id co a,
eval_simple_rvalue r (Vptr b ofs) ->
typeof r = Tunion id a ->
ge.(genv_cenv)!id = Some co ->
eval_simple_lvalue (Efield r f ty) b ofs
with eval_simple_rvalue: expr -> val -> Prop :=
| esr_val: forall v ty,
eval_simple_rvalue (Eval v ty) v
| esr_rvalof: forall b ofs l ty v,
eval_simple_lvalue l b ofs ->
ty = typeof l -> type_is_volatile ty = false ->
deref_loc ge ty m b ofs E0 v ->
eval_simple_rvalue (Evalof l ty) v
| esr_addrof: forall b ofs l ty,
eval_simple_lvalue l b ofs ->
eval_simple_rvalue (Eaddrof l ty) (Vptr b ofs)
| esr_unop: forall op r1 ty v1 v,
eval_simple_rvalue r1 v1 ->
sem_unary_operation op v1 (typeof r1) m = Some v ->
eval_simple_rvalue (Eunop op r1 ty) v
| esr_binop: forall op r1 r2 ty v1 v2 v,
eval_simple_rvalue r1 v1 -> eval_simple_rvalue r2 v2 ->
sem_binary_operation ge op v1 (typeof r1) v2 (typeof r2) m = Some v ->
eval_simple_rvalue (Ebinop op r1 r2 ty) v
| esr_cast: forall ty r1 v1 v,
eval_simple_rvalue r1 v1 ->
sem_cast v1 (typeof r1) ty m = Some v ->
eval_simple_rvalue (Ecast r1 ty) v
| esr_sizeof: forall ty1 ty,
eval_simple_rvalue (Esizeof ty1 ty) (Vptrofs (Ptrofs.repr (sizeof ge ty1)))
| esr_alignof: forall ty1 ty,
eval_simple_rvalue (Ealignof ty1 ty) (Vptrofs (Ptrofs.repr (alignof ge ty1))).
Inductive eval_simple_list: exprlist -> typelist -> list val -> Prop :=
| esrl_nil:
eval_simple_list Enil Tnil nil
| esrl_cons: forall r rl ty tyl v vl v',
eval_simple_rvalue r v' -> sem_cast v' (typeof r) ty m = Some v ->
eval_simple_list rl tyl vl ->
eval_simple_list (Econs r rl) (Tcons ty tyl) (v :: vl).
Scheme eval_simple_rvalue_ind2 := Minimality for eval_simple_rvalue Sort Prop
with eval_simple_lvalue_ind2 := Minimality for eval_simple_lvalue Sort Prop.
Combined Scheme eval_simple_rvalue_lvalue_ind from eval_simple_rvalue_ind2, eval_simple_lvalue_ind2.
End SIMPLE_EXPRS.
(** Left reduction contexts. These contexts allow reducing to the right of a binary operator only if the left subexpression is simple. *)
Inductive leftcontext: kind -> kind -> (expr -> expr) -> Prop :=
| lctx_top: forall k,
leftcontext k k (fun x => x)
| lctx_deref: forall k C ty,
leftcontext k RV C -> leftcontext k LV (fun x => Ederef (C x) ty)
| lctx_field: forall k C f ty,
leftcontext k RV C -> leftcontext k LV (fun x => Efield (C x) f ty)
| lctx_rvalof: forall k C ty,
leftcontext k LV C -> leftcontext k RV (fun x => Evalof (C x) ty)
| lctx_addrof: forall k C ty,
leftcontext k LV C -> leftcontext k RV (fun x => Eaddrof (C x) ty)
| lctx_unop: forall k C op ty,
leftcontext k RV C -> leftcontext k RV (fun x => Eunop op (C x) ty)
| lctx_binop_left: forall k C op e2 ty,
leftcontext k RV C -> leftcontext k RV (fun x => Ebinop op (C x) e2 ty)
| lctx_binop_right: forall k C op e1 ty,
simple e1 = true -> leftcontext k RV C ->
leftcontext k RV (fun x => Ebinop op e1 (C x) ty)
| lctx_cast: forall k C ty,
leftcontext k RV C -> leftcontext k RV (fun x => Ecast (C x) ty)
| lctx_seqand: forall k C r2 ty,
leftcontext k RV C -> leftcontext k RV (fun x => Eseqand (C x) r2 ty)
| lctx_seqor: forall k C r2 ty,
leftcontext k RV C -> leftcontext k RV (fun x => Eseqor (C x) r2 ty)
| lctx_condition: forall k C r2 r3 ty,
leftcontext k RV C -> leftcontext k RV (fun x => Econdition (C x) r2 r3 ty)
| lctx_assign_left: forall k C e2 ty,
leftcontext k LV C -> leftcontext k RV (fun x => Eassign (C x) e2 ty)
| lctx_assign_right: forall k C e1 ty,
simple e1 = true -> leftcontext k RV C ->
leftcontext k RV (fun x => Eassign e1 (C x) ty)
| lctx_assignop_left: forall k C op e2 tyres ty,
leftcontext k LV C -> leftcontext k RV (fun x => Eassignop op (C x) e2 tyres ty)
| lctx_assignop_right: forall k C op e1 tyres ty,
simple e1 = true -> leftcontext k RV C ->
leftcontext k RV (fun x => Eassignop op e1 (C x) tyres ty)
| lctx_postincr: forall k C id ty,
leftcontext k LV C -> leftcontext k RV (fun x => Epostincr id (C x) ty)
| lctx_call_left: forall k C el ty,
leftcontext k RV C -> leftcontext k RV (fun x => Ecall (C x) el ty)
| lctx_call_right: forall k C e1 ty,
simple e1 = true -> leftcontextlist k C ->
leftcontext k RV (fun x => Ecall e1 (C x) ty)
| lctx_builtin: forall k C ef tyargs ty,
leftcontextlist k C ->
leftcontext k RV (fun x => Ebuiltin ef tyargs (C x) ty)
| lctx_comma: forall k C e2 ty,
leftcontext k RV C -> leftcontext k RV (fun x => Ecomma (C x) e2 ty)
| lctx_paren: forall k C tycast ty,
leftcontext k RV C -> leftcontext k RV (fun x => Eparen (C x) tycast ty)
with leftcontextlist: kind -> (expr -> exprlist) -> Prop :=
| lctx_list_head: forall k C el,
leftcontext k RV C -> leftcontextlist k (fun x => Econs (C x) el)
| lctx_list_tail: forall k C e1,
simple e1 = true -> leftcontextlist k C ->
leftcontextlist k (fun x => Econs e1 (C x)).
Hint Resolve leftcontext_context.
(** Strategy for reducing expressions. We reduce the leftmost innermost non-simple subexpression, evaluating its arguments (which are necessarily simple expressions) with the big-step semantics. If there are none, the whole expression is simple and is evaluated in one big step. *)
Inductive estep: state -> trace -> state -> Prop :=
| step_expr: forall f r k e m v ty,
eval_simple_rvalue e m r v ->
match r with Eval _ _ => False | _ => True end ->
ty = typeof r ->
estep (ExprState f r k e m)
E0 (ExprState f (Eval v ty) k e m)
| step_rvalof_volatile: forall f C l ty k e m b ofs t v,
leftcontext RV RV C ->
eval_simple_lvalue e m l b ofs ->
deref_loc ge ty m b ofs t v ->
ty = typeof l -> type_is_volatile ty = true ->
estep (ExprState f (C (Evalof l ty)) k e m)
t (ExprState f (C (Eval v ty)) k e m)
| step_seqand_true: forall f C r1 r2 ty k e m v,
leftcontext RV RV C ->
eval_simple_rvalue e m r1 v ->
bool_val v (typeof r1) m = Some true ->
estep (ExprState f (C (Eseqand r1 r2 ty)) k e m)
E0 (ExprState f (C (Eparen r2 type_bool ty)) k e m)
| step_seqand_false: forall f C r1 r2 ty k e m v,
leftcontext RV RV C ->
eval_simple_rvalue e m r1 v ->
bool_val v (typeof r1) m = Some false ->
estep (ExprState f (C (Eseqand r1 r2 ty)) k e m)
E0 (ExprState f (C (Eval (Vint Int.zero) ty)) k e m)
| step_seqor_true: forall f C r1 r2 ty k e m v,
leftcontext RV RV C ->
eval_simple_rvalue e m r1 v ->
bool_val v (typeof r1) m = Some true ->
estep (ExprState f (C (Eseqor r1 r2 ty)) k e m)
E0 (ExprState f (C (Eval (Vint Int.one) ty)) k e m)
| step_seqor_false: forall f C r1 r2 ty k e m v,
leftcontext RV RV C ->
eval_simple_rvalue e m r1 v ->
bool_val v (typeof r1) m = Some false ->
estep (ExprState f (C (Eseqor r1 r2 ty)) k e m)
E0 (ExprState f (C (Eparen r2 type_bool ty)) k e m)
| step_condition: forall f C r1 r2 r3 ty k e m v b,
leftcontext RV RV C ->
eval_simple_rvalue e m r1 v ->
bool_val v (typeof r1) m = Some b ->
estep (ExprState f (C (Econdition r1 r2 r3 ty)) k e m)
E0 (ExprState f (C (Eparen (if b then r2 else r3) ty ty)) k e m)
| step_assign: forall f C l r ty k e m b ofs v v' t m',
leftcontext RV RV C ->
eval_simple_lvalue e m l b ofs ->
eval_simple_rvalue e m r v ->
sem_cast v (typeof r) (typeof l) m = Some v' ->
assign_loc ge (typeof l) m b ofs v' t m' ->
ty = typeof l ->
estep (ExprState f (C (Eassign l r ty)) k e m)
t (ExprState f (C (Eval v' ty)) k e m')
| step_assignop: forall f C op l r tyres ty k e m b ofs v1 v2 v3 v4 t1 t2 m' t,
leftcontext RV RV C ->
eval_simple_lvalue e m l b ofs ->
deref_loc ge (typeof l) m b ofs t1 v1 ->
eval_simple_rvalue e m r v2 ->
sem_binary_operation ge op v1 (typeof l) v2 (typeof r) m = Some v3 ->
sem_cast v3 tyres (typeof l) m = Some v4 ->
assign_loc ge (typeof l) m b ofs v4 t2 m' ->
ty = typeof l ->
t = t1 ** t2 ->
estep (ExprState f (C (Eassignop op l r tyres ty)) k e m)
t (ExprState f (C (Eval v4 ty)) k e m')
| step_assignop_stuck: forall f C op l r tyres ty k e m b ofs v1 v2 t,
leftcontext RV RV C ->
eval_simple_lvalue e m l b ofs ->
deref_loc ge (typeof l) m b ofs t v1 ->
eval_simple_rvalue e m r v2 ->
match sem_binary_operation ge op v1 (typeof l) v2 (typeof r) m with
| None => True
| Some v3 =>
match sem_cast v3 tyres (typeof l) m with
| None => True
| Some v4 => forall t2 m', ~(assign_loc ge (typeof l) m b ofs v4 t2 m')
end
end ->
ty = typeof l ->
estep (ExprState f (C (Eassignop op l r tyres ty)) k e m)
t Stuckstate
| step_postincr: forall f C id l ty k e m b ofs v1 v2 v3 t1 t2 m' t,
leftcontext RV RV C ->
eval_simple_lvalue e m l b ofs ->
deref_loc ge ty m b ofs t1 v1 ->
sem_incrdecr ge id v1 ty m = Some v2 ->
sem_cast v2 (incrdecr_type ty) ty m = Some v3 ->
assign_loc ge ty m b ofs v3 t2 m' ->
ty = typeof l ->
t = t1 ** t2 ->
estep (ExprState f (C (Epostincr id l ty)) k e m)
t (ExprState f (C (Eval v1 ty)) k e m')
| step_postincr_stuck: forall f C id l ty k e m b ofs v1 t,
leftcontext RV RV C ->
eval_simple_lvalue e m l b ofs ->
deref_loc ge ty m b ofs t v1 ->
match sem_incrdecr ge id v1 ty m with
| None => True
| Some v2 =>
match sem_cast v2 (incrdecr_type ty) ty m with
| None => True
| Some v3 => forall t2 m', ~(assign_loc ge (typeof l) m b ofs v3 t2 m')
end
end ->
ty = typeof l ->
estep (ExprState f (C (Epostincr id l ty)) k e m)
t Stuckstate
| step_comma: forall f C r1 r2 ty k e m v,
leftcontext RV RV C ->
eval_simple_rvalue e m r1 v ->
ty = typeof r2 ->
estep (ExprState f (C (Ecomma r1 r2 ty)) k e m)
E0 (ExprState f (C r2) k e m)
| step_paren: forall f C r tycast ty k e m v1 v,
leftcontext RV RV C ->
eval_simple_rvalue e m r v1 ->
sem_cast v1 (typeof r) tycast m = Some v ->
estep (ExprState f (C (Eparen r tycast ty)) k e m)
E0 (ExprState f (C (Eval v ty)) k e m)
| step_call: forall f C rf rargs ty k e m targs tres cconv vf vargs fd,
leftcontext RV RV C ->
classify_fun (typeof rf) = fun_case_f targs tres cconv ->
eval_simple_rvalue e m rf vf ->
eval_simple_list e m rargs targs vargs ->
Genv.find_funct ge vf = Some fd ->
type_of_fundef fd = Tfunction targs tres cconv ->
estep (ExprState f (C (Ecall rf rargs ty)) k e m)
E0 (Callstate fd vargs (Kcall f e C ty k) m)
| step_builtin: forall f C ef tyargs rargs ty k e m vargs t vres m',
leftcontext RV RV C ->
eval_simple_list e m rargs tyargs vargs ->
external_call ef ge vargs m t vres m' ->
estep (ExprState f (C (Ebuiltin ef tyargs rargs ty)) k e m)
t (ExprState f (C (Eval vres ty)) k e m').
Definition step (S: state) (t: trace) (S': state) : Prop :=
estep S t S' \/ sstep ge S t S'.
(** Properties of contexts *)

Lemma context_compose:
forall k2 k3 C2, context k2 k3 C2 ->
forall k1 C1, context k1 k2 C1 ->
context k1 k3 (fun x => C2(C1 x))
with contextlist_compose:
forall k2 C2, contextlist k2 C2 ->
forall k1 C1, context k1 k2 C1 ->
contextlist k1 (fun x => C2(C1 x)).