(* *********************************************************************)
(*                                                                     *)
(*              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]. *)
(** Properties of [add_letvar]. *)
(** * Properties of [alloc_reg] and [alloc_regs] *)
Hint Resolve alloc_reg_valid: rtlg.
Hint Resolve alloc_regs_valid: rtlg.
Hint Resolve alloc_optreg_valid: rtlg.
(** A register is an adequate target for holding the value of an expression if - either the register is associated with a Cminor let-bound variable or a Cminor local variable; - or the register is not associated with any Cminor variable and does not belong to the preserved set [pr]. *)
Inductive target_reg_ok (map: mapping) (pr: list reg): expr -> reg -> Prop :=
| target_reg_var:
forall id r,
map.(map_vars)!id = Some r ->
target_reg_ok map pr (Evar id) r
| target_reg_letvar:
forall idx r,
nth_error map.(map_letvars) idx = Some r ->
target_reg_ok map pr (Eletvar idx) r
| target_reg_other:
forall a r,
~(reg_in_map map r) -> ~In r pr ->
target_reg_ok map pr a r.
Inductive target_regs_ok (map: mapping) (pr: list reg): exprlist -> list reg -> Prop :=
| target_regs_nil:
target_regs_ok map pr Enil nil
| target_regs_cons: forall a1 al r1 rl,
target_reg_ok map pr a1 r1 ->
target_regs_ok map (r1 :: pr) al rl ->
target_regs_ok map pr (Econs a1 al) (r1 :: rl).

Lemma alloc_regs_target_ok:
forall map al pr s1 rl s2 i,
map_valid map s1 ->
regs_valid pr s1 ->
alloc_regs map al s1 = OK rl s2 i ->
target_regs_ok map pr al rl.