(* *********************************************************************)
(*                                                                     *)
(*              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).
Hint Resolve new_reg_target_ok alloc_reg_target_ok
alloc_regs_target_ok: rtlg.
(** The following predicate is a variant of [target_reg_ok] used to characterize registers that are adequate for holding the return value of a function. *)
Inductive return_reg_ok: state -> mapping -> option reg -> Prop :=
| return_reg_ok_none:
forall s map,
return_reg_ok s map None
| return_reg_ok_some:
forall s map r,
~(reg_in_map map r) -> reg_valid r s ->
return_reg_ok s map (Some r).
Hint Resolve return_reg_ok_incr: rtlg.

Lemma new_reg_return_ok:
forall s1 r s2 map sig i,
new_reg s1 = OK r s2 i ->
map_valid map s1 ->
return_reg_ok s2 map (ret_reg sig r).