Section CORRECTNESS_EXPR.
Variable sp: val.
Variable e: env.
Variable m: mem.
(** The proof of semantic preservation for the translation of expressions is a simulation argument based on diagrams of the following form: << I /\ P e, le, m, a ------------- State cs code sp ns rs tm ||                      | ||                      |* ||                      | \/                      v e, le, m, v ------------ State cs code sp nd rs' tm' I /\ Q >> where [tr_expr code map pr a ns nd rd] is assumed to hold. The left vertical arrow represents an evaluation of the expression [a]. The right vertical arrow represents the execution of zero, one or several instructions in the generated RTL flow graph [code].  The invariant [I] is the agreement between Cminor environments and RTL register environment, as captured by [match_envs].  The precondition [P] includes the well-formedness of the compilation environment [mut].  The postconditions [Q] state that in the final register environment [rs'], register [rd] contains value [v], and the registers in the set of preserved registers [pr] are unchanged, as are the registers in the codomain of [map].  We formalize this simulation property by the following predicate parameterized by the CminorSel evaluation (left arrow).  *)
Definition transl_expr_prop
(le: letenv) (a: expr) (v: val) : Prop :=
forall tm cs f map pr ns nd rd rs dst
(MWF: map_wf map)
(TE: tr_expr f.(fn_code) map pr a ns nd rd dst)
(ME: match_env map e le rs)
(EXT: Mem.extends m tm),
exists rs', exists tm',
star step tge (State cs f sp ns rs tm) E0 (State cs f sp nd rs' tm')
/\ match_env map (set_optvar dst v e) le rs'
/\ Val.lessdef v rs'#rd
/\ (forall r, In r pr -> rs'#r = rs#r)
/\ Mem.extends m tm'.
Definition transl_exprlist_prop
(le: letenv) (al: exprlist) (vl: list val) : Prop :=
forall tm cs f map pr ns nd rl rs
(MWF: map_wf map)
(TE: tr_exprlist f.(fn_code) map pr al ns nd rl)
(ME: match_env map e le rs)
(EXT: Mem.extends m tm),
exists rs', exists tm',
star step tge (State cs f sp ns rs tm) E0 (State cs f sp nd rs' tm')
/\ match_env map e le rs'
/\ Val.lessdef_list vl rs'##rl
/\ (forall r, In r pr -> rs'#r = rs#r)
/\ Mem.extends m tm'.
Definition transl_condexpr_prop
(le: letenv) (a: condexpr) (v: bool) : Prop :=
forall tm cs f map pr ns ntrue nfalse rs
(MWF: map_wf map)
(TE: tr_condition f.(fn_code) map pr a ns ntrue nfalse)
(ME: match_env map e le rs)
(EXT: Mem.extends m tm),
exists rs', exists tm',
plus step tge (State cs f sp ns rs tm) E0 (State cs f sp (if v then ntrue else nfalse) rs' tm')
/\ match_env map e le rs'
/\ (forall r, In r pr -> rs'#r = rs#r)
/\ Mem.extends m tm'.
(** The correctness of the translation is a huge induction over the CminorSel evaluation derivation for the source program.  To keep the proof manageable, we put each case of the proof in a separate lemma.  There is one lemma for each CminorSel evaluation rule. It takes as hypotheses the premises of the CminorSel evaluation rule, plus the induction hypotheses, that is, the [transl_expr_prop], etc, corresponding to the evaluations of sub-expressions or sub-statements. *)
Remark eval_builtin_args_trivial:
forall (ge: RTL.genv) (rs: regset) sp m rl,
eval_builtin_args ge (fun r => rs#r) sp m (List.map (@BA reg) rl) rs##rl.
Proof
(eval_expr_ind3 ge sp e m
transl_expr_prop
transl_exprlist_prop
transl_condexpr_prop
transl_expr_Evar_correct
transl_expr_Eop_correct
transl_expr_Eload_correct
transl_expr_Econdition_correct
transl_expr_Elet_correct
transl_expr_Eletvar_correct
transl_expr_Ebuiltin_correct
transl_expr_Eexternal_correct
transl_exprlist_Enil_correct
transl_exprlist_Econs_correct
transl_condexpr_CEcond_correct
transl_condexpr_CEcondition_correct
transl_condexpr_CElet_correct).
Proof
(eval_exprlist_ind3 ge sp e m
transl_expr_prop
transl_exprlist_prop
transl_condexpr_prop
transl_expr_Evar_correct
transl_expr_Eop_correct
transl_expr_Eload_correct
transl_expr_Econdition_correct
transl_expr_Elet_correct
transl_expr_Eletvar_correct
transl_expr_Ebuiltin_correct
transl_expr_Eexternal_correct
transl_exprlist_Enil_correct
transl_exprlist_Econs_correct
transl_condexpr_CEcond_correct
transl_condexpr_CEcondition_correct
transl_condexpr_CElet_correct).
Proof
(eval_condexpr_ind3 ge sp e m
transl_expr_prop
transl_exprlist_prop
transl_condexpr_prop
transl_expr_Evar_correct
transl_expr_Eop_correct
transl_expr_Eload_correct
transl_expr_Econdition_correct
transl_expr_Elet_correct
transl_expr_Eletvar_correct
transl_expr_Ebuiltin_correct
transl_expr_Eexternal_correct
transl_exprlist_Enil_correct
transl_exprlist_Econs_correct
transl_condexpr_CEcond_correct
transl_condexpr_CEcondition_correct
transl_condexpr_CElet_correct).
(** Exit expressions. *)
Definition transl_exitexpr_prop
(le: letenv) (a: exitexpr) (x: nat) : Prop :=
forall tm cs f map ns nexits rs
(MWF: map_wf map)
(TE: tr_exitexpr f.(fn_code) map a ns nexits)
(ME: match_env map e le rs)
(EXT: Mem.extends m tm),
exists nd, exists rs', exists tm',
star step tge (State cs f sp ns rs tm) E0 (State cs f sp nd rs' tm')
/\ nth_error nexits x = Some nd
/\ match_env map e le rs'
/\ Mem.extends m tm'.
(** Builtin arguments. *)
End CORRECTNESS_EXPR.
(** ** Measure over CminorSel states *)
Local Open Scope nat_scope.
Fixpoint size_stmt (s: stmt) : nat :=
match s with
| Sskip => 0
| Sseq s1 s2 => (size_stmt s1 + size_stmt s2 + 1)
| Sifthenelse c s1 s2 => (size_stmt s1 + size_stmt s2 + 1)
| Sloop s1 => (size_stmt s1 + 1)
| Sblock s1 => (size_stmt s1 + 1)
| Sexit n => 0
| Slabel lbl s1 => (size_stmt s1 + 1)
| _ => 1
end.
Fixpoint size_cont (k: cont) : nat :=
match k with
| Kseq s k1 => (size_stmt s + size_cont k1 + 1)
| Kblock k1 => (size_cont k1 + 1)
| _ => 0%nat
end.
Definition measure_state (S: CminorSel.state) :=
match S with
| CminorSel.State _ s k _ _ _ => (size_stmt s + size_cont k, size_stmt s)
| _                           => (0, 0)
end.
Definition lt_state (S1 S2: CminorSel.state) :=
lex_ord lt lt (measure_state S1) (measure_state S2).
Ltac Lt_state :=
apply lt_state_intro; simpl; try omega.
(** ** Semantic preservation for the translation of statements *)
(** The simulation diagram for the translation of statements and functions is a "star" diagram of the form: << I                         I S1 ------- R1             S1 ------- R1 |          |              |          | t |        + | t      or  t |        * | t    and |S2| < |S1| v          v              v          | S2 ------- R2             S2 ------- R2 I                         I >> where [I] is the [match_states] predicate defined below.  It includes: - Agreement between the Cminor statement under consideration and the current program point in the RTL control-flow graph, as captured by the [tr_stmt] predicate. - Agreement between the Cminor continuation and the RTL control-flow graph and call stack, as captured by the [tr_cont] predicate below. - Agreement between Cminor environments and RTL register environments, as captured by [match_envs].  *)
Inductive tr_fun (tf: function) (map: mapping) (f: CminorSel.function)
(ngoto: labelmap) (nret: node) (rret: option reg) : Prop :=
| tr_fun_intro: forall nentry r,
rret = ret_reg f.(CminorSel.fn_sig) r ->
tr_stmt tf.(fn_code) map f.(fn_body) nentry nret nil ngoto nret rret ->
tf.(fn_stacksize) = f.(fn_stackspace) ->
tr_fun tf map f ngoto nret rret.
Inductive tr_cont: RTL.code -> mapping ->
CminorSel.cont -> node -> list node -> labelmap -> node -> option reg ->
list RTL.stackframe -> Prop :=
| tr_Kseq: forall c map s k nd nexits ngoto nret rret cs n,
tr_stmt c map s nd n nexits ngoto nret rret ->
tr_cont c map k n nexits ngoto nret rret cs ->
tr_cont c map (Kseq s k) nd nexits ngoto nret rret cs
| tr_Kblock: forall c map k nd nexits ngoto nret rret cs,
tr_cont c map k nd nexits ngoto nret rret cs ->
tr_cont c map (Kblock k) nd (nd :: nexits) ngoto nret rret cs
| tr_Kstop: forall c map ngoto nret rret cs,
c!nret = Some(Ireturn rret) ->
match_stacks Kstop cs ->
tr_cont c map Kstop nret nil ngoto nret rret cs
| tr_Kcall: forall c map optid f sp e k ngoto nret rret cs,
c!nret = Some(Ireturn rret) ->
match_stacks (Kcall optid f sp e k) cs ->
tr_cont c map (Kcall optid f sp e k) nret nil ngoto nret rret cs
with match_stacks: CminorSel.cont -> list RTL.stackframe -> Prop :=
| match_stacks_stop:
match_stacks Kstop nil
| match_stacks_call: forall optid f sp e k r tf n rs cs map nexits ngoto nret rret,
map_wf map ->
tr_fun tf map f ngoto nret rret ->
match_env map e nil rs ->
reg_map_ok map r optid ->
tr_cont tf.(fn_code) map k n nexits ngoto nret rret cs ->
match_stacks (Kcall optid f sp e k) (Stackframe r tf sp n rs :: cs).
Inductive match_states: CminorSel.state -> RTL.state -> Prop :=
| match_state:
forall f s k sp e m tm cs tf ns rs map ncont nexits ngoto nret rret
(MWF: map_wf map)
(TS: tr_stmt tf.(fn_code) map s ns ncont nexits ngoto nret rret)
(TF: tr_fun tf map f ngoto nret rret)
(TK: tr_cont tf.(fn_code) map k ncont nexits ngoto nret rret cs)
(ME: match_env map e nil rs)
(MEXT: Mem.extends m tm),
match_states (CminorSel.State f s k sp e m)
(RTL.State cs tf sp ns rs tm)
| match_callstate:
forall f args targs k m tm cs tf
(TF: transl_fundef f = OK tf)
(MS: match_stacks k cs)
(LD: Val.lessdef_list args targs)
(MEXT: Mem.extends m tm),
match_states (CminorSel.Callstate f args k m)
(RTL.Callstate cs tf targs tm)
| match_returnstate:
forall v tv k m tm cs
(MS: match_stacks k cs)
(LD: Val.lessdef v tv)
(MEXT: Mem.extends m tm),
match_states (CminorSel.Returnstate v k m)
(RTL.Returnstate cs tv tm).

Theorem transf_program_correct:
forward_simulation (CminorSel.semantics prog) (RTL.semantics tprog).