(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris                                  *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(** Assertions on memory states, in the style of separation logic *)
(** This library defines a number of useful logical assertions about CompCert memory states, such as "block [b] at offset [ofs] contains value [v]".  Assertions can be grouped using a separating conjunction operator in the style of separation logic.  Currently, this library is used only in module [Stackingproof] to reason about the shapes of stack frames generated during the [Stacking] pass.  This is not a full-fledged separation logic because there is no program logic (Hoare triples) to speak of.  Also, there is no general frame rule; instead, a weak form of the frame rule is provided by the lemmas that help us reason about the logical assertions. *)
(** * Assertions about memory *)
(** An assertion is composed of: - a predicate over memory states (of type [mem -> Prop]) - a set of (block, offset) memory locations that represents the memory footprint of the assertion - a proof that the predicate is invariant by changes of memory outside of the footprint - a proof that the footprint contains only valid memory blocks.  This presentation (where the footprint is part of the assertion) makes it possible to define separating conjunction without explicitly defining a separation algebra over CompCert memory states (i.e. the notion of splitting a memory state into two disjoint halves).  *)
Record massert : Type := {
m_pred : mem -> Prop;
m_footprint: block -> Z -> Prop;
m_invar: forall m m', m_pred m -> Mem.unchanged_on m_footprint m m' -> m_pred m';
m_valid: forall m b ofs, m_pred m -> m_footprint b ofs -> Mem.valid_block m b
}.
Notation "m |= p" := (m_pred p m) (at level 74, no associativity) : sep_scope.
(** Implication and logical equivalence between memory predicates *)
Definition massert_imp (P Q: massert) : Prop :=
(forall m, m_pred P m -> m_pred Q m) /\ (forall b ofs, m_footprint Q b ofs -> m_footprint P b ofs).
Definition massert_eqv (P Q: massert) : Prop :=
massert_imp P Q /\ massert_imp Q P.
Remark massert_imp_refl: forall p, massert_imp p p.
Remark massert_imp_trans: forall p q r, massert_imp p q -> massert_imp q r -> massert_imp p r.
Remark massert_eqv_refl: forall p, massert_eqv p p.
Remark massert_eqv_sym: forall p q, massert_eqv p q -> massert_eqv q p.
Remark massert_eqv_trans: forall p q r, massert_eqv p q -> massert_eqv q r -> massert_eqv p r.
(** Record [massert_eqv] and [massert_imp] as relations so that they can be used by rewriting tactics. *)
Add Relation massert massert_imp
reflexivity proved by massert_imp_refl
transitivity proved by massert_imp_trans
as massert_imp_prel.
Add Relation massert massert_eqv
reflexivity proved by massert_eqv_refl
symmetry proved by massert_eqv_sym
transitivity proved by massert_eqv_trans
as massert_eqv_prel.
Add Morphism m_pred
with signature massert_imp ==> eq ==> impl
as m_pred_morph_1.
Add Morphism m_pred
with signature massert_eqv ==> eq ==> iff
as m_pred_morph_2.
Hint Resolve massert_imp_refl massert_eqv_refl.
(** * Separating conjunction *)
Definition disjoint_footprint (P Q: massert) : Prop :=
forall b ofs, m_footprint P b ofs -> m_footprint Q b ofs -> False.
Program Definition sepconj (P Q: massert) : massert := {|
m_pred := fun m => m_pred P m /\ m_pred Q m /\ disjoint_footprint P Q;
m_footprint := fun b ofs => m_footprint P b ofs \/ m_footprint Q b ofs
|}.
Next Obligation.
repeat split; auto.
apply (m_invar P) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
apply (m_invar Q) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
Qed.
Next Obligation.
destruct H0; [eapply (m_valid P) | eapply (m_valid Q)]; eauto.
Qed.
Add Morphism sepconj
with signature massert_imp ==> massert_imp ==> massert_imp
as sepconj_morph_1.
Add Morphism sepconj
with signature massert_eqv ==> massert_eqv ==> massert_eqv
as sepconj_morph_2.
Infix "**" := sepconj (at level 60, right associativity) : sep_scope.
Local Open Scope sep_scope.
Definition sep_swap12 := sep_swap.
Definition sep_swap2 := sep_swap.
Proof sep_drop.
Definition sep_pick1 := sep_proj1.
(** * Basic memory assertions. *)
(** Pure logical assertion *)
Program Definition pure (P: Prop) : massert := {|
m_pred := fun m => P;
m_footprint := fun b ofs => False
|}.
Next Obligation.
tauto.
Qed.
(** A range of bytes, with full permissions and unspecified contents. *)
Program Definition range (b: block) (lo hi: Z) : massert := {|
m_pred := fun m =>
0 <= lo /\ hi <= Ptrofs.modulus
/\ (forall i k p, lo <= i < hi -> Mem.perm m b i k p);
m_footprint := fun b' ofs' => b' = b /\ lo <= ofs' < hi
|}.
Next Obligation.
split; auto. split; auto. intros. eapply Mem.perm_unchanged_on; eauto. simpl; auto.
Qed.
Next Obligation.
apply Mem.perm_valid_block with ofs Cur Freeable; auto.
Qed.
(** A memory area that contains a value sastifying a given predicate *)
Program Definition contains (chunk: memory_chunk) (b: block) (ofs: Z) (spec: val -> Prop) : massert := {|
m_pred := fun m =>
0 <= ofs <= Ptrofs.max_unsigned
/\ Mem.valid_access m chunk b ofs Freeable
/\ exists v, Mem.load chunk m b ofs = Some v /\ spec v;
m_footprint := fun b' ofs' => b' = b /\ ofs <= ofs' < ofs + size_chunk chunk
|}.
Next Obligation.
rename H2 into v. split;[|split].
- auto.
- destruct H1; split; auto. red; intros; eapply Mem.perm_unchanged_on; eauto. simpl; auto.
- exists v. split; auto. eapply Mem.load_unchanged_on; eauto. simpl; auto.
Qed.
Next Obligation.
eauto with mem.
Qed.
(** A memory area that contains a given value *)
Definition hasvalue (chunk: memory_chunk) (b: block) (ofs: Z) (v: val) : massert :=
contains chunk b ofs (fun v' => v' = v).
(** Non-separating conjunction *)
Program Definition mconj (P Q: massert) : massert := {|
m_pred := fun m => m_pred P m /\ m_pred Q m;
m_footprint := fun b ofs => m_footprint P b ofs \/ m_footprint Q b ofs
|}.
Next Obligation.
split.
apply (m_invar P) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
apply (m_invar Q) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
Qed.
Next Obligation.
destruct H0; [eapply (m_valid P) | eapply (m_valid Q)]; eauto.
Qed.
Add Morphism mconj
with signature massert_imp ==> massert_imp ==> massert_imp
as mconj_morph_1.
Add Morphism mconj
with signature massert_eqv ==> massert_eqv ==> massert_eqv
as mconj_morph_2.
(** The image of a memory injection *)
Program Definition minjection (j: meminj) (m0: mem) : massert := {|
m_pred := fun m => Mem.inject j m0 m;
m_footprint := fun b ofs => exists b0 delta, j b0 = Some(b, delta) /\ Mem.perm m0 b0 (ofs - delta) Max Nonempty
|}.
Next Obligation.
set (img := fun b' ofs => exists b delta, j b = Some(b', delta) /\ Mem.perm m0 b (ofs - delta) Max Nonempty) in *.
assert (IMG: forall b1 b2 delta ofs k p,
j b1 = Some (b2, delta) -> Mem.perm m0 b1 ofs k p -> img b2 (ofs + delta)).
{ intros. red. exists b1, delta; split; auto.
replace (ofs + delta - delta) with ofs by omega.
eauto with mem. }
destruct H. constructor.
- destruct mi_inj. constructor; intros.
+ eapply Mem.perm_unchanged_on; eauto.
+ eauto.
+ rewrite (Mem.unchanged_on_contents _ _ _ H0); eauto.
- assumption.
- intros. eapply Mem.valid_block_unchanged_on; eauto.
- assumption.
- assumption.
- intros. destruct (Mem.perm_dec m0 b1 ofs Max Nonempty); auto.
eapply mi_perm_inv; eauto.
eapply Mem.perm_unchanged_on_2; eauto.
Qed.
Next Obligation.
eapply Mem.valid_block_inject_2; eauto.
Qed.
(** Preservation of a global environment by a memory injection *)
Inductive globalenv_preserved {F V: Type} (ge: Genv.t F V) (j: meminj) (bound: block) : Prop :=
| globalenv_preserved_intro
(DOMAIN: forall b, Plt b bound -> j b = Some(b, 0))
(IMAGE: forall b1 b2 delta, j b1 = Some(b2, delta) -> Plt b2 bound -> b1 = b2)
(SYMBOLS: forall id b, Genv.find_symbol ge id = Some b -> Plt b bound)
(FUNCTIONS: forall b fd, Genv.find_funct_ptr ge b = Some fd -> Plt b bound)
(VARINFOS: forall b gv, Genv.find_var_info ge b = Some gv -> Plt b bound).
Program Definition globalenv_inject {F V: Type} (ge: Genv.t F V) (j: meminj) : massert := {|
m_pred := fun m => exists bound, Ple bound (Mem.nextblock m) /\ globalenv_preserved ge j bound;
m_footprint := fun b ofs => False
|}.
Next Obligation.
rename H into bound. exists bound; split; auto. eapply Ple_trans; eauto. eapply Mem.unchanged_on_nextblock; eauto.
Qed.
Next Obligation.
tauto.
Qed.

Lemma external_call_parallel_rule_strong:
forall (F V: Type) ef (ge: Genv.t F V) vargs1 m1 t vres1 m1' m2 j P vargs2,
external_call ef ge vargs1 m1 t vres1 m1' ->
injection_full j m1 ->
m2 |= minjection j m1 ** globalenv_inject ge j ** P ->
Val.inject_list j vargs1 vargs2 ->
exists j' vres2 m2' t',
external_call ef ge vargs2 m2 t' vres2 m2'
/\ Val.inject j' vres1 vres2
/\ m2' |= minjection j' m1' ** globalenv_inject ge j' ** P
/\ inject_incr j j'
/\ inject_separated j j' m1 m2
/\ inject_trace j' t t' /\
injection_full j' m1' .