Section TR_TOP.
Variable ge: genv.
Variable e: env.
Variable le: temp_env.
Variable m: mem.
Inductive tr_top: destination -> Csyntax.expr -> list statement -> expr -> list ident -> Prop :=
| tr_top_val_val: forall v ty a tmp,
typeof a = ty -> eval_expr ge e le m a v ->
tr_top For_val (Csyntax.Eval v ty) nil a tmp
| tr_top_base: forall dst r sl a tmp,
tr_expr le dst r sl a tmp ->
tr_top dst r sl a tmp.
End TR_TOP.
(** ** Translation of statements *)
Inductive tr_expression: Csyntax.expr -> statement -> expr -> Prop :=
| tr_expression_intro: forall r sl a tmps,
(forall ge e le m, tr_top ge e le m For_val r sl a tmps) ->
tr_expression r (makeseq sl) a.
Inductive tr_expr_stmt: Csyntax.expr -> statement -> Prop :=
| tr_expr_stmt_intro: forall r sl a tmps,
(forall ge e le m, tr_top ge e le m For_effects r sl a tmps) ->
tr_expr_stmt r (makeseq sl).
Inductive tr_if: Csyntax.expr -> statement -> statement -> statement -> Prop :=
| tr_if_intro: forall r s1 s2 sl a tmps,
(forall ge e le m, tr_top ge e le m For_val r sl a tmps) ->
tr_if r s1 s2 (makeseq (sl ++ makeif a s1 s2 :: nil)).
Inductive tr_stmt: Csyntax.statement -> statement -> Prop :=
| tr_skip:
tr_stmt Csyntax.Sskip Sskip
| tr_do: forall r s,
tr_expr_stmt r s ->
tr_stmt (Csyntax.Sdo r) s
| tr_seq: forall s1 s2 ts1 ts2,
tr_stmt s1 ts1 -> tr_stmt s2 ts2 ->
tr_stmt (Csyntax.Ssequence s1 s2) (Ssequence ts1 ts2)
| tr_ifthenelse_empty: forall r s' a,
tr_expression r s' a ->
tr_stmt (Csyntax.Sifthenelse r Csyntax.Sskip Csyntax.Sskip) (Ssequence s' Sskip)
| tr_ifthenelse: forall r s1 s2 s' a ts1 ts2,
tr_expression r s' a ->
tr_stmt s1 ts1 -> tr_stmt s2 ts2 ->
tr_stmt (Csyntax.Sifthenelse r s1 s2) (Ssequence s' (Sifthenelse a ts1 ts2))
| tr_while: forall r s1 s' ts1,
tr_if r Sskip Sbreak s' ->
tr_stmt s1 ts1 ->
tr_stmt (Csyntax.Swhile r s1)
(Sloop (Ssequence s' ts1) Sskip)
| tr_dowhile: forall r s1 s' ts1,
tr_if r Sskip Sbreak s' ->
tr_stmt s1 ts1 ->
tr_stmt (Csyntax.Sdowhile r s1)
(Sloop ts1 s')
| tr_for_1: forall r s3 s4 s' ts3 ts4,
tr_if r Sskip Sbreak s' ->
tr_stmt s3 ts3 ->
tr_stmt s4 ts4 ->
tr_stmt (Csyntax.Sfor Csyntax.Sskip r s3 s4)
(Sloop (Ssequence s' ts4) ts3)
| tr_for_2: forall s1 r s3 s4 s' ts1 ts3 ts4,
tr_if r Sskip Sbreak s' ->
s1 <> Csyntax.Sskip ->
tr_stmt s1 ts1 ->
tr_stmt s3 ts3 ->
tr_stmt s4 ts4 ->
tr_stmt (Csyntax.Sfor s1 r s3 s4)
(Ssequence ts1 (Sloop (Ssequence s' ts4) ts3))
| tr_break:
tr_stmt Csyntax.Sbreak Sbreak
| tr_continue:
tr_stmt Csyntax.Scontinue Scontinue
| tr_return_none:
tr_stmt (Csyntax.Sreturn None) (Sreturn None)
| tr_return_some: forall r s' a,
tr_expression r s' a ->
tr_stmt (Csyntax.Sreturn (Some r)) (Ssequence s' (Sreturn (Some a)))
| tr_switch: forall r ls s' a tls,
tr_expression r s' a ->
tr_lblstmts ls tls ->
tr_stmt (Csyntax.Sswitch r ls) (Ssequence s' (Sswitch a tls))
| tr_label: forall lbl s ts,
tr_stmt s ts ->
tr_stmt (Csyntax.Slabel lbl s) (Slabel lbl ts)
| tr_goto: forall lbl,
tr_stmt (Csyntax.Sgoto lbl) (Sgoto lbl)
with tr_lblstmts: Csyntax.labeled_statements -> labeled_statements -> Prop :=
| tr_ls_nil:
tr_lblstmts Csyntax.LSnil LSnil
| tr_ls_cons: forall c s ls ts tls,
tr_stmt s ts ->
tr_lblstmts ls tls ->
tr_lblstmts (Csyntax.LScons c s ls) (LScons c ts tls).
(** * Correctness proof with respect to the specification. *)
(** ** Properties of the monad *)
Remark bind_inversion:
forall (A B: Type) (f: mon A) (g: A -> mon B) (y: B) (z1 z3: generator) I,
bind f g z1 = Res y z3 I ->
exists x, exists z2, exists I1, exists I2,
f z1 = Res x z2 I1 /\ g x z2 = Res y z3 I2.
Remark bind2_inversion:
forall (A B Csyntax: Type) (f: mon (A*B)) (g: A -> B -> mon Csyntax) (y: Csyntax) (z1 z3: generator) I,
bind2 f g z1 = Res y z3 I ->
exists x1, exists x2, exists z2, exists I1, exists I2,
f z1 = Res (x1,x2) z2 I1 /\ g x1 x2 z2 = Res y z3 I2.
Ltac monadInv1 H :=
match type of H with
| (Res _ _ _ = Res _ _ _) =>
inversion H; clear H; try subst
| (@ret _ _ _ = Res _ _ _) =>
inversion H; clear H; try subst
| (@error _ _ _ = Res _ _ _) =>
inversion H
| (bind ?F ?G ?Z = Res ?X ?Z' ?I) =>
let x := fresh "x" in (
let z := fresh "z" in (
let I1 := fresh "I" in (
let I2 := fresh "I" in (
let EQ1 := fresh "EQ" in (
let EQ2 := fresh "EQ" in (
destruct (bind_inversion _ _ F G X Z Z' I H) as [x [z [I1 [I2 [EQ1 EQ2]]]]];
clear H;
try (monadInv1 EQ2)))))))
| (bind2 ?F ?G ?Z = Res ?X ?Z' ?I) =>
let x := fresh "x" in (
let y := fresh "y" in (
let z := fresh "z" in (
let I1 := fresh "I" in (
let I2 := fresh "I" in (
let EQ1 := fresh "EQ" in (
let EQ2 := fresh "EQ" in (
destruct (bind2_inversion _ _ _ F G X Z Z' I H) as [x [y [z [I1 [I2 [EQ1 EQ2]]]]]];
clear H;
try (monadInv1 EQ2))))))))
end.
Ltac monadInv H :=
match type of H with
| (@ret _ _ _ = Res _ _ _) => monadInv1 H
| (@error _ _ _ = Res _ _ _) => monadInv1 H
| (bind ?F ?G ?Z = Res ?X ?Z' ?I) => monadInv1 H
| (bind2 ?F ?G ?Z = Res ?X ?Z' ?I) => monadInv1 H
| (?F _ _ _ _ _ _ _ _ = Res _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ _ _ = Res _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ _ = Res _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ = Res _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ = Res _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ = Res _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ = Res _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ = Res _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
end.
(** ** Freshness and separation properties. *)
Definition within (id: ident) (g1 g2: generator) : Prop :=
Ple (gen_next g1) id /\ Plt id (gen_next g2).
Definition contained (l: list ident) (g1 g2: generator) : Prop :=
forall id, In id l -> within id g1 g2.
Definition dest_below (dst: destination) (g: generator) : Prop :=
match dst with
| For_set sd => Plt (sd_temp sd) g.(gen_next)
| _ => True
end.
Remark dest_for_val_below: forall g, dest_below For_val g.
Hint Resolve gensym_within within_widen contained_widen
contained_cons contained_app contained_disjoint
contained_notin contained_nil
dest_for_set_seqbool_val dest_for_set_seqbool_set
dest_for_set_condition_val dest_for_set_condition_set
sd_temp_notin dest_below_le
incl_refl incl_tl incl_app incl_appl incl_appr incl_same_head
in_eq in_cons
Ple_trans Ple_refl: gensym.
Local Hint Resolve dest_for_val_below dest_for_effect_below : core.
(** ** Correctness of the translation functions *)
Ltac UseFinish :=
match goal with
| [ H: finish _ _ _ = (_, _) |- _ ] =>
try (rewrite (finish_meets_spec_2 _ _ _ _ _ H));
try (rewrite (finish_meets_spec_1 _ _ _ _ _ H));
repeat rewrite app_ass
end.
(* Fixpoint add_set_dest (sd: set_destination) (tmps: list ident) := match sd with | SDbase ty tmp => tmp :: tmps | SDcons ty tmp sd' => tmp :: add_set_dest sd' tmps end. *)
Definition add_dest (dst: destination) (tmps: list ident) :=
match dst with
| For_set sd => sd_temp sd :: tmps
| _ => tmps
end.
Scheme expr_ind2 := Induction for Csyntax.expr Sort Prop
with exprlist_ind2 := Induction for Csyntax.exprlist Sort Prop.
Combined Scheme expr_exprlist_ind from expr_ind2, exprlist_ind2.

Lemma transl_meets_spec:
(forall r dst g sl a g' I,
transl_expr dst r g = Res (sl, a) g' I ->
dest_below dst g ->
exists tmps, (forall le, tr_expr le dst r sl a (add_dest dst tmps)) /\ contained tmps g g')
/\
(forall rl g sl al g' I,
transl_exprlist rl g = Res (sl, al) g' I ->
exists tmps, (forall le, tr_exprlist le rl sl al tmps) /\ contained tmps g g').