(* *********************************************************************)
(*                                                                     *)
(*              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 INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(** Abstract specification of RTL generation *)
(** In this module, we define inductive predicates that specify the translations from Cminor to RTL performed by the functions in module [RTLgen].  We then show that these functions satisfy these relational specifications.  The relational specifications will then be used instead of the actual functions to show semantic equivalence between the source Cminor code and the the generated RTL code (see module [RTLgenproof]). *)
Require Errors.
(** * Reasoning about monadic computations *)
(** The tactics below simplify hypotheses of the form [f ... = OK x s i] where [f] is a monadic computation.  For instance, the hypothesis [(do x <- a; b) s = OK y s' i] will generate the additional witnesses [x], [s1], [i1], [i'] and the additional hypotheses [a s = OK x s1 i1] and [b x s1 = OK y s' i'], reflecting the fact that both monadic computations [a] and [b] succeeded. *)
Remark bind_inversion:
forall (A B: Type) (f: mon A) (g: A -> mon B)
(y: B) (s1 s3: state) (i: state_incr s1 s3),
bind f g s1 = OK y s3 i ->
exists x, exists s2, exists i1, exists i2,
f s1 = OK x s2 i1 /\ g x s2 = OK y s3 i2.
Remark bind2_inversion:
forall (A B C: Type) (f: mon (A*B)) (g: A -> B -> mon C)
(z: C) (s1 s3: state) (i: state_incr s1 s3),
bind2 f g s1 = OK z s3 i ->
exists x, exists y, exists s2, exists i1, exists i2,
f s1 = OK (x, y) s2 i1 /\ g x y s2 = OK z s3 i2.
Ltac monadInv1 H :=
match type of H with
| (OK _ _ _ = OK _ _ _) =>
inversion H; clear H; try subst
| (Error _ _ = OK _ _ _) =>
discriminate
| (ret _ _ = OK _ _ _) =>
inversion H; clear H; try subst
| (error _ _ = OK _ _ _) =>
discriminate
| (bind ?F ?G ?S = OK ?X ?S' ?I) =>
let x := fresh "x" in (
let s := fresh "s" in (
let i1 := fresh "INCR" in (
let i2 := fresh "INCR" in (
let EQ1 := fresh "EQ" in (
let EQ2 := fresh "EQ" in (
destruct (bind_inversion _ _ F G X S S' I H) as [x [s [i1 [i2 [EQ1 EQ2]]]]];
clear H;
try (monadInv1 EQ2)))))))
| (bind2 ?F ?G ?S = OK ?X ?S' ?I) =>
let x1 := fresh "x" in (
let x2 := fresh "x" in (
let s := fresh "s" in (
let i1 := fresh "INCR" in (
let i2 := fresh "INCR" in (
let EQ1 := fresh "EQ" in (
let EQ2 := fresh "EQ" in (
destruct (bind2_inversion _ _ _ F G X S S' I H) as [x1 [x2 [s [i1 [i2 [EQ1 EQ2]]]]]];
clear H;
try (monadInv1 EQ2))))))))
end.
Ltac monadInv H :=
match type of H with
| (ret _ _ = OK _ _ _) => monadInv1 H
| (error _ _ = OK _ _ _) => monadInv1 H
| (bind ?F ?G ?S = OK ?X ?S' ?I) => monadInv1 H
| (bind2 ?F ?G ?S = OK ?X ?S' ?I) => monadInv1 H
| (?F _ _ _ _ _ _ _ _ = OK _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ _ _ = OK _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ _ = OK _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ _ = OK _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ _ = OK _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ _ = OK _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ _ = OK _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
| (?F _ = OK _ _ _) =>
((progress simpl in H) || unfold F in H); monadInv1 H
end.
(** * Monotonicity properties of the state *)
Hint Resolve state_incr_refl: rtlg.
Hint Resolve instr_at_incr: rtlg.
(** The following tactic saturates the hypotheses with [state_incr] properties that follow by transitivity from the known hypotheses. *)
Ltac saturateTrans :=
match goal with
| H1: state_incr ?x ?y, H2: state_incr ?y ?z |- _ =>
match goal with
| H: state_incr x z |- _  =>
fail 1
| _ =>
let i := fresh "INCR" in
(generalize (state_incr_trans x y z H1 H2); intro i;
saturateTrans)
end
| _ => idtac
end.
(** * Validity and freshness of registers *)
(** An RTL pseudo-register is valid in a given state if it was created earlier, that is, it is less than the next fresh register of the state. Otherwise, the pseudo-register is said to be fresh. *)
Definition reg_valid (r: reg) (s: state) : Prop :=
Plt r s.(st_nextreg).
Definition reg_fresh (r: reg) (s: state) : Prop :=
~(Plt r s.(st_nextreg)).
Hint Resolve valid_fresh_absurd: rtlg.
Hint Resolve valid_fresh_different: rtlg.
Hint Resolve reg_valid_incr: rtlg.
Hint Resolve reg_fresh_decr: rtlg.
(** Validity of a list of registers. *)
Definition regs_valid (rl: list reg) (s: state) : Prop :=
forall r, In r rl -> reg_valid r s.
Hint Resolve regs_valid_nil: rtlg.
Hint Resolve regs_valid_incr: rtlg.
(** A register is ``in'' a mapping if it is associated with a Cminor local or let-bound variable. *)
Definition reg_in_map (m: mapping) (r: reg) : Prop :=
(exists id, m.(map_vars)!id = Some r) \/ In r m.(map_letvars).
(** A compilation environment (mapping) is valid in a given state if the registers associated with Cminor local variables and let-bound variables are valid in the state. *)
Definition map_valid (m: mapping) (s: state) : Prop :=
forall r, reg_in_map m r -> reg_valid r s.
Hint Resolve map_valid_incr: rtlg.
(** * Properties of basic operations over the state *)
(** Properties of [add_instr]. *)
Hint Resolve add_instr_at: rtlg.
(** Properties of [update_instr]. *)
Hint Resolve update_instr_at: rtlg.
(** Properties of [new_reg]. *)
Hint Resolve new_reg_valid: rtlg.
Hint Resolve new_reg_fresh: rtlg.
Hint Resolve new_reg_not_in_map: rtlg.
(** * Properties of operations over compilation environments *)
(** Properties of [find_var]. *)
Hint Resolve find_var_in_map: rtlg.
Hint Resolve find_var_valid: rtlg.
(** Properties of [find_letvar]. *)
Hint Resolve find_letvar_in_map: rtlg.
Hint Resolve find_letvar_valid: rtlg.
(** Properties of [add_var]. *)

Lemma add_vars_valid:
forall namel s1 s2 map1 map2 rl i,
add_vars map1 namel s1 = OK (rl, map2) s2 i ->
map_valid map1 s1 ->
regs_valid rl s2 /\ map_valid map2 s2.