(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(** A deterministic evaluation strategy for C. *)
Section STRATEGY.
Variable ge: genv.
(** * Definition of the strategy *)
(** We now formalize a particular strategy for reducing expressions which is the one implemented by the CompCert compiler.  It evaluates effectful subexpressions first, in leftmost-innermost order, then finishes with the evaluation of the remaining simple expression. *)
(** Simple expressions are defined as follows. *)
Fixpoint simple (a: expr) : bool :=
match a with
| Eloc _ _ _ => true
| Evar _ _ => true
| Ederef r _ => simple r
| Efield r _ _ => simple r
| Eval _ _ => true
| Evalof l _ => simple l && negb(type_is_volatile (typeof l))
| Eaddrof l _ => simple l
| Eunop _ r1 _ => simple r1
| Ebinop _ r1 r2 _ => simple r1 && simple r2
| Ecast r1 _ => simple r1
| Eseqand _ _ _ => false
| Eseqor _ _ _ => false
| Econdition _ _ _ _ => false
| Esizeof _ _ => true
| Ealignof _ _ => true
| Eassign _ _ _ => false
| Eassignop _ _ _ _ _ => false
| Epostincr _ _ _ => false
| Ecomma _ _ _ => false
| Ecall _ _ _ => false
| Ebuiltin _ _ _ _ => false
| Eparen _ _ _ => false
end.
Fixpoint simplelist (rl: exprlist) : bool :=
match rl with Enil => true | Econs r rl' => simple r && simplelist rl' end.
(** Simple expressions have interesting properties: their evaluations always terminate, are deterministic, and preserve the memory state. We seize this opportunity to define a big-step semantics for simple expressions. *)
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)).

Lemma leftcontext_context:
forall k1 k2 C, leftcontext k1 k2 C -> context k1 k2 C
with leftcontextlist_contextlist:
forall k C, leftcontextlist k C -> contextlist k C.