(** ** Top-level translation *)
(** The "top-level" translation is equivalent to [tr_expr] above for source terms.  It brings additional flexibility in the matching between Csyntax values and Cminor expressions: in the case of [tr_expr], the Cminor expression must not depend on memory, while in the case of [tr_top] it can depend on the current memory state. *)
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).

Lemma within_widen:
forall id g1 g2 g1' g2',
within id g1 g2 ->
Ple (gen_next g1') (gen_next g1) ->
Ple (gen_next g2) (gen_next g2') ->
within id g1' g2'.