Section CORRECTNESS_EXPR_EFF.
Variable sp: val.
Variable e: env.
Variable m: mem.
Definition Efftransl_expr_prop
(le: letenv) (a: expr) (v: val) : Prop :=
forall j tm cs f map pr ns nd rd rs dst
(*NEW:*)(PG: meminj_preserves_globals ge j) sp' (SP: sp_preserved j sp sp')  (MWF: map_wf map) (TE: tr_expr f.(fn_code) map pr a ns nd rd dst) (ME: match_env j map e le rs) (EXT: Mem.inject j m tm), exists rs', exists tm', effstep_star rtl_eff_sem tge EmptyEffect (RTL_State cs f sp' ns rs) tm (RTL_State cs f sp' nd rs') tm' /\ match_env j map (set_optvar dst v e) le rs' /\ val_inject j v rs'#rd /\ (forall r, In r pr -> rs'#r = rs#r) /\ Mem.inject j m tm' /\ tm=tm'.  Definition Efftransl_exprlist_prop (le: letenv) (al: exprlist) (vl: list val) : Prop := forall j tm cs f map pr ns nd rl rs (*NEW:*)(PG: meminj_preserves_globals ge j) sp' (SP: sp_preserved j sp sp')  (MWF: map_wf map) (TE: tr_exprlist f.(fn_code) map pr al ns nd rl) (ME: match_env j map e le rs) (EXT: Mem.inject j m tm), exists rs', exists tm', effstep_star rtl_eff_sem tge EmptyEffect (RTL_State cs f sp' ns rs) tm (RTL_State cs f sp' nd rs') tm' /\ match_env j map e le rs' /\ val_list_inject j vl rs'##rl /\ (forall r, In r pr -> rs'#r = rs#r) /\ Mem.inject j m tm' /\ tm=tm'.  Definition Efftransl_condexpr_prop (le: letenv) (a: condexpr) (v: bool) : Prop := forall j tm cs f map pr ns ntrue nfalse rs (*NEW:*)(PG: meminj_preserves_globals ge j) sp' (SP: sp_preserved j sp sp')  (MWF: map_wf map) (TE: tr_condition f.(fn_code) map pr a ns ntrue nfalse) (ME: match_env j map e le rs) (EXT: Mem.inject j m tm), exists rs', exists tm', effstep_plus rtl_eff_sem tge EmptyEffect (RTL_State cs f sp' ns rs) tm (RTL_State cs f sp' (if v then ntrue else nfalse) rs') tm' /\ match_env j map e le rs' /\ (forall r, In r pr -> rs'#r = rs#r) /\ Mem.inject j m tm' /\ tm=tm'.  (** The correctness of the translation is a huge induction over the Cminor 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 Cminor evaluation rule. It takes as hypotheses the premises of the Cminor evaluation rule, plus the induction hypotheses, that is, the [transl_expr_prop], etc, corresponding to the evaluations of sub-expressions or sub-statements. *)
(*Proof. intros; red; intros. inv TE. exploit H0; eauto. intros [rs1 [tm1 [EX1 [ME1 [RR1 [RO1 EXT1]]]]]]. (*WAS: exploit external_call_mem_extends; eauto. intros [v' [tm2 [A [B [C [D E]]]]]].*)
exploit external_call_mem_inject; eauto.
intros [j' [v' [tm2 [A [B [C [D [E [F G]]]]]]]]].
exists (rs1#rd <- v'); exists tm2.
(* Exec *)
split. eapply effstep_star_trans. eexact EX1.
apply effstep_star_one. eapply rtl_effstep_exec_Ibuiltin; eauto.
eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved.
(* Match-env *)
split. eapply match_env_update_dest; try eassumption.
eapply val_inject_incr. eassumption. split; intros.  eexists. eauto with rtlg.
(* Result reg *)
split. intros. rewrite Regmap.gss. auto.
(* Other regs *)
split. intros. rewrite Regmap.gso. auto. intuition congruence.
(* Mem *)
auto.
Qed.
*)
(*LENB: Lemma should not be needed any more since external calls are handled by effsemantics interface now. We can probably eliminate external expressions from CminorSel.v, but that's a language definieiotn modification*)
(*Proof. intros; red; intros. inv TE. exploit H3; eauto. intros [rs1 [tm1 [EX1 [ME1 [RR1 [RO1 EXT1]]]]]]. exploit external_call_mem_extends; eauto. intros [v' [tm2 [A [B [C [D E]]]]]]. exploit function_ptr_translated; eauto. simpl. intros [tf [P Q]]. inv Q. exists (rs1#rd <- v'); exists tm2. (* Exec *)
split. eapply star_trans. eexact EX1.
eapply star_left. eapply exec_Icall; eauto.
simpl. rewrite symbols_preserved. rewrite H. eauto. auto.
eapply star_left. eapply exec_function_external.
eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved.
apply star_one. apply exec_return.
reflexivity. reflexivity. reflexivity.
(* Match-env *)
split. eauto with rtlg.
(* Result reg *)
split. rewrite Regmap.gss. auto.
(* Other regs *)
split. intros. rewrite Regmap.gso. auto. intuition congruence.
(* Mem *)
auto.
Qed.
*)
Proof
(eval_expr_ind3 ge sp e m
Efftransl_expr_prop
Efftransl_exprlist_prop
Efftransl_condexpr_prop
Efftransl_expr_Evar_correct
Efftransl_expr_Eop_correct
Efftransl_expr_Eload_correct
Efftransl_expr_Econdition_correct
Efftransl_expr_Elet_correct
Efftransl_expr_Eletvar_correct
Efftransl_expr_Ebuiltin_correct
Efftransl_expr_Eexternal_correct
Efftransl_exprlist_Enil_correct
Efftransl_exprlist_Econs_correct
Efftransl_condexpr_CEcond_correct
Efftransl_condexpr_CEcondition_correct
Efftransl_condexpr_CElet_correct).
Proof
(eval_exprlist_ind3 ge sp e m
Efftransl_expr_prop
Efftransl_exprlist_prop
Efftransl_condexpr_prop
Efftransl_expr_Evar_correct
Efftransl_expr_Eop_correct
Efftransl_expr_Eload_correct
Efftransl_expr_Econdition_correct
Efftransl_expr_Elet_correct
Efftransl_expr_Eletvar_correct
Efftransl_expr_Ebuiltin_correct
Efftransl_expr_Eexternal_correct
Efftransl_exprlist_Enil_correct
Efftransl_exprlist_Econs_correct
Efftransl_condexpr_CEcond_correct
Efftransl_condexpr_CEcondition_correct
Efftransl_condexpr_CElet_correct).
Proof
(eval_condexpr_ind3 ge sp e m
Efftransl_expr_prop
Efftransl_exprlist_prop
Efftransl_condexpr_prop
Efftransl_expr_Evar_correct
Efftransl_expr_Eop_correct
Efftransl_expr_Eload_correct
Efftransl_expr_Econdition_correct
Efftransl_expr_Elet_correct
Efftransl_expr_Eletvar_correct
Efftransl_expr_Ebuiltin_correct
Efftransl_expr_Eexternal_correct
Efftransl_exprlist_Enil_correct
Efftransl_exprlist_Econs_correct
Efftransl_condexpr_CEcond_correct
Efftransl_condexpr_CEcondition_correct
Efftransl_condexpr_CElet_correct).
End CORRECTNESS_EXPR_EFF.
(** ** Measure over CminorSel states *)
Open Local 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: CMinSel_core) :=
match S with
| CMinSel_State _ s k _ _ => (size_stmt s + size_cont k, size_stmt s)
| _                           => (0, 0)
end.
Definition lt_state (S1 S2: CMinSel_core) :=
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.
(*LENB: new: meminj parameter j*)
Inductive tr_cont (j:meminj): 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 j c map k n nexits ngoto nret rret cs ->
tr_cont j 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 j c map k nd nexits ngoto nret rret cs ->
tr_cont j 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 j Kstop cs ->
tr_cont j 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 j (Kcall optid f sp e k) cs ->
tr_cont j c map (Kcall optid f sp e k) nret nil ngoto nret rret cs
with match_stacks (j:meminj) : CminorSel.cont -> list RTL.stackframe -> Prop :=
| match_stacks_stop:
match_stacks j Kstop nil
| match_stacks_call: forall optid f sp e k r tf n rs cs map nexits ngoto nret rret sp',
map_wf map ->
tr_fun tf map f ngoto nret rret ->
match_env j map e nil rs ->
reg_map_ok map r optid ->
tr_cont j tf.(fn_code) map k n nexits ngoto nret rret cs ->
(*NEW:*) sp_preserved j sp sp' -> match_stacks j (Kcall optid f sp e k) (Stackframe r tf sp' n rs :: cs).  (*Derivation of induction scheme as explained her: http://coq.inria.fr/cocorico/Mutual%20Induction*)
Scheme tr_cont_ind_2 := Induction for tr_cont Sort Prop
with match_stacks_ind_2 := Induction for match_stacks Sort Prop.
Combined Scheme tr_cont_match_stacks_mutual_ind
from tr_cont_ind_2, match_stacks_ind_2.
Inductive match_states (j:meminj): CMinSel_core -> mem -> RTL_core -> mem -> Prop :=
| match_state:
forall f s k sp e m tm cs tf ns rs map ncont nexits ngoto nret rret sp'
(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 j tf.(fn_code) map k ncont nexits ngoto nret rret cs)
(ME: match_env j map e nil rs)
(*(MEXT: Mem.extends m tm)*)
(MINJ: Mem.inject j m tm)
(*NEW:*) (SP: sp_preserved j sp sp'), match_states j (CMinSel_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 j k cs) (*(LD: Val.lessdef_list args targs)*)
(AINJ: val_list_inject j args targs)
(*(MEXT: Mem.extends m tm)*)
(MINJ: Mem.inject j m tm),
match_states j (CMinSel_Callstate f args k) m
(RTL_Callstate cs tf targs) tm
| match_returnstate:
forall v tv k m tm cs
(MS: match_stacks j k cs)
(*(LD: Val.lessdef v tv)*)
(VINJ: val_inject j v tv)
(*(MEXT: Mem.extends m tm)*)
(MINJ: Mem.inject j m tm),
match_states j (CMinSel_Returnstate v k) m
(RTL_Returnstate cs tv) tm.
Definition MATCH (d:CMinSel_core) mu c1 m1 c2 m2:Prop :=
match_states (restrict (as_inj mu) (vis mu)) c1 m1 c2 m2 /\
REACH_closed m1 (vis mu) /\
meminj_preserves_globals ge (as_inj mu) /\
globalfunction_ptr_inject (as_inj mu) /\
(forall b, isGlobalBlock ge b = true -> frgnBlocksSrc mu b = true) /\
sm_valid mu m1 m2 /\ SM_wd mu /\ Mem.inject (as_inj mu) m1 m2.

Lemma MATCH_initial: forall v1 v2 sig entrypoints
(EP: In (v1, v2, sig) entrypoints)
(entry_points_ok : forall (v1 v2 : val) (sig : signature),
In (v1, v2, sig) entrypoints ->
exists b f1 f2,
v1 = Vptr b Int.zero /\
v2 = Vptr b Int.zero /\
Genv.find_funct_ptr ge b = Some f1 /\
Genv.find_funct_ptr tge b = Some f2)
vals1 c1 m1 j vals2 m2 (DomS DomT : block -> bool)
(Ini: initial_core cminsel_eff_sem ge v1 vals1 = Some c1)
(Inj: Mem.inject j m1 m2)
(VInj: Forall2 (val_inject j) vals1 vals2)
(PG:meminj_preserves_globals ge j)
(R : list_norepet (map fst (prog_defs prog)))
(J: forall b1 b2 delta, j b1 = Some (b2, delta) ->
(DomS b1 = true /\ DomT b2 = true))
(RCH: forall b, REACH m2
(fun b' : block => isGlobalBlock tge b' || getBlocks vals2 b') b = true ->
DomT b = true)
(InitMem : exists m0 : mem, Genv.init_mem prog = Some m0
/\ Ple (Mem.nextblock m0) (Mem.nextblock m1)
/\ Ple (Mem.nextblock m0) (Mem.nextblock m2))
(GDE: genvs_domain_eq ge tge)
(HDomS: forall b : block, DomS b = true -> Mem.valid_block m1 b)
(HDomT: forall b : block, DomT b = true -> Mem.valid_block m2 b),
exists c2,
initial_core rtl_eff_sem tge v2 vals2 = Some c2 /\
MATCH c1
(initial_SM DomS DomT
(REACH m1 (fun b : block => isGlobalBlock ge b || getBlocks vals1 b))
(REACH m2 (fun b : block => isGlobalBlock tge b || getBlocks vals2 b))
j) c1 m1 c2 m2.