summaryrefslogtreecommitdiff
path: root/common
diff options
context:
space:
mode:
Diffstat (limited to 'common')
-rw-r--r--common/Determinism.v142
-rw-r--r--common/Events.v755
-rw-r--r--common/Globalenvs.v1733
-rw-r--r--common/Mem.v2887
-rw-r--r--common/Memdata.v1058
-rw-r--r--common/Memdataaux.ml68
-rw-r--r--common/Memory.v2844
-rw-r--r--common/Memtype.v989
-rw-r--r--common/Values.v81
9 files changed, 6688 insertions, 3869 deletions
diff --git a/common/Determinism.v b/common/Determinism.v
index 430ee93..862d5a5 100644
--- a/common/Determinism.v
+++ b/common/Determinism.v
@@ -32,8 +32,8 @@ Axiom traceinf_extensionality:
(** * Deterministic worlds *)
(** One source of possible nondeterminism is that our semantics leave
- unspecified the results of calls to external
- functions. Different results to e.g. a "read" operation can of
+ unspecified the results of system calls.
+ Different results to e.g. a "read" operation can of
course lead to different behaviors for the program.
We address this issue by modeling a notion of deterministic
external world that uniquely determines the results of external calls. *)
@@ -61,13 +61,21 @@ Definition nextworld (w: world) (evname: ident) (evargs: list eventval) :
world and [T] the infinite trace of interest.
*)
+Inductive possible_event: world -> event -> world -> Prop :=
+ | possible_event_syscall: forall w1 evname evargs evres w2,
+ nextworld w1 evname evargs = Some (evres, w2) ->
+ possible_event w1 (Event_syscall evname evargs evres) w2
+ | possible_event_load: forall w label,
+ possible_event w (Event_load label) w
+ | possible_event_store: forall w label,
+ possible_event w (Event_store label) w.
+
Inductive possible_trace: world -> trace -> world -> Prop :=
| possible_trace_nil: forall w,
possible_trace w E0 w
- | possible_trace_cons: forall w0 evname evargs evres w1 t w2,
- nextworld w0 evname evargs = Some (evres, w1) ->
- possible_trace w1 t w2 ->
- possible_trace w0 (mkevent evname evargs evres :: t) w2.
+ | possible_trace_cons: forall w1 ev w2 t w3,
+ possible_event w1 ev w2 -> possible_trace w2 t w3 ->
+ possible_trace w1 (ev :: t) w3.
Lemma possible_trace_app:
forall t2 w2 w0 t1 w1,
@@ -90,11 +98,28 @@ Proof.
exists w1; split. econstructor; eauto. auto.
Qed.
+Lemma possible_event_final_world:
+ forall w ev w1 w2,
+ possible_event w ev w1 -> possible_event w ev w2 -> w1 = w2.
+Proof.
+ intros. inv H; inv H0; congruence.
+Qed.
+
+Lemma possible_trace_final_world:
+ forall w0 t w1, possible_trace w0 t w1 ->
+ forall w2, possible_trace w0 t w2 -> w1 = w2.
+Proof.
+ induction 1; intros.
+ inv H. auto.
+ inv H1. assert (w2 = w5) by (eapply possible_event_final_world; eauto).
+ subst; eauto.
+Qed.
+
CoInductive possible_traceinf: world -> traceinf -> Prop :=
- | possible_traceinf_cons: forall w0 evname evargs evres w1 T,
- nextworld w0 evname evargs = Some (evres, w1) ->
- possible_traceinf w1 T ->
- possible_traceinf w0 (Econsinf (mkevent evname evargs evres) T).
+ | possible_traceinf_cons: forall w1 ev w2 T,
+ possible_event w1 ev w2 ->
+ possible_traceinf w2 T ->
+ possible_traceinf w1 (Econsinf ev T).
Lemma possible_traceinf_app:
forall t2 w0 t1 w1,
@@ -149,34 +174,13 @@ Definition possible_behavior (w: world) (b: program_behavior) : Prop :=
| Goes_wrong t => exists w', possible_trace w t w'
end.
-(** Determinism properties of [event_match]. *)
-
-Remark eventval_match_deterministic:
- forall ev1 ev2 ty v1 v2,
- eventval_match ev1 ty v1 -> eventval_match ev2 ty v2 ->
- (ev1 = ev2 <-> v1 = v2).
-Proof.
- intros. inv H; inv H0; intuition congruence.
-Qed.
-
-Remark eventval_list_match_deterministic:
- forall ev1 ty v, eventval_list_match ev1 ty v ->
- forall ev2, eventval_list_match ev2 ty v -> ev1 = ev2.
-Proof.
- induction 1; intros.
- inv H. auto.
- inv H1. decEq.
- rewrite (eventval_match_deterministic _ _ _ _ _ H H6). auto.
- eauto.
-Qed.
-
(** * Deterministic semantics *)
Section DETERM_SEM.
(** We assume given a transition semantics that is internally
deterministic: the only source of non-determinism is the return
- value of external calls. *)
+ value of system calls. *)
Variable genv: Type.
Variable state: Type.
@@ -184,17 +188,9 @@ Variable step: genv -> state -> trace -> state -> Prop.
Variable initial_state: state -> Prop.
Variable final_state: state -> int -> Prop.
-Inductive internal_determinism: trace -> state -> trace -> state -> Prop :=
- | int_determ_0: forall s,
- internal_determinism E0 s E0 s
- | int_determ_1: forall s s' id arg res res',
- (res = res' -> s = s') ->
- internal_determinism (mkevent id arg res :: nil) s
- (mkevent id arg res' :: nil) s'.
-
Hypothesis step_internal_deterministic:
forall ge s t1 s1 t2 s2,
- step ge s t1 s1 -> step ge s t2 s2 -> internal_determinism t1 s1 t2 s2.
+ step ge s t1 s1 -> step ge s t2 s2 -> matching_traces t1 t2 -> s1 = s2 /\ t1 = t2.
Hypothesis initial_state_determ:
forall s1 s2, initial_state s1 -> initial_state s2 -> s1 = s2.
@@ -208,18 +204,29 @@ Hypothesis final_state_nostep:
(** Consequently, the [step] relation is deterministic if restricted
to traces that are possible in a deterministic world. *)
+Remark matching_possible_traces:
+ forall w0 t1 w1, possible_trace w0 t1 w1 ->
+ forall t2 w2, possible_trace w0 t2 w2 ->
+ matching_traces t1 t2.
+Proof.
+ induction 1; intros.
+ destruct t2; simpl; auto.
+ destruct t2; simpl. destruct ev; auto. inv H1.
+ inv H; inv H5; auto; intros.
+ subst. rewrite H in H1; inv H1. split; eauto.
+ eauto.
+ eauto.
+Qed.
+
Lemma step_deterministic:
forall ge s0 t1 s1 t2 s2 w0 w1 w2,
step ge s0 t1 s1 -> step ge s0 t2 s2 ->
possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 ->
s1 = s2 /\ t1 = t2 /\ w1 = w2.
Proof.
- intros. exploit step_internal_deterministic. eexact H. eexact H0. intro ID.
- inv ID.
- inv H1. inv H2. auto.
- inv H2. inv H11. inv H1. inv H11.
- rewrite H10 in H9. inv H9.
- intuition.
+ intros. exploit step_internal_deterministic. eexact H. eexact H0.
+ eapply matching_possible_traces; eauto. intuition.
+ subst. eapply possible_trace_final_world; eauto.
Qed.
Ltac use_step_deterministic :=
@@ -378,44 +385,55 @@ Lemma forever_reactive_inv2:
t1 <> E0 -> t2 <> E0 ->
forever_reactive step ge s1 T1 -> possible_traceinf w1 T1 ->
forever_reactive step ge s2 T2 -> possible_traceinf w2 T2 ->
- exists s', exists e, exists T1', exists T2', exists w',
+ exists s', exists t, exists T1', exists T2', exists w',
+ t <> E0 /\
forever_reactive step ge s' T1' /\ possible_traceinf w' T1' /\
forever_reactive step ge s' T2' /\ possible_traceinf w' T2' /\
- t1 *** T1 = Econsinf e T1' /\
- t2 *** T2 = Econsinf e T2'.
+ t1 *** T1 = t *** T1' /\
+ t2 *** T2 = t *** T2'.
Proof.
induction 1; intros.
congruence.
inv H3. congruence. possibleTraceInv.
- assert (ID: internal_determinism t3 s5 t1 s2). eauto.
- inv ID.
- possibleTraceInv. eauto.
- inv P. inv P1. inv H17. inv H19. rewrite H18 in H16; inv H16.
- assert (s5 = s2) by auto. subst s5.
- exists s2; exists (mkevent id arg res');
- exists (t2 *** T1); exists (t4 *** T2); exists w0.
+ use_step_deterministic.
+ destruct t3.
+ (* inductive case *)
+ simpl in *. inv P1; inv P. eapply IHstar; eauto.
+ (* base case *)
+ exists s5; exists (e :: t3);
+ exists (t2 *** T1); exists (t4 *** T2); exists w3.
+ split. unfold E0; congruence.
split. eapply star_forever_reactive; eauto.
split. eapply possible_traceinf_app; eauto.
split. eapply star_forever_reactive; eauto.
split. eapply possible_traceinf_app; eauto.
- auto.
+ split; traceEq.
Qed.
-Lemma forever_reactive_determ:
+Lemma forever_reactive_determ':
forall ge s T1 T2 w,
forever_reactive step ge s T1 -> possible_traceinf w T1 ->
forever_reactive step ge s T2 -> possible_traceinf w T2 ->
- traceinf_sim T1 T2.
+ traceinf_sim' T1 T2.
Proof.
cofix COINDHYP; intros.
inv H. inv H1. possibleTraceInv.
destruct (forever_reactive_inv2 _ _ _ _ H _ _ _ _ _ _ _ P H3 P1 H6 H4
H7 P0 H5 P2)
- as [s' [e [T1' [T2' [w' [A [B [C [D [E G]]]]]]]]]].
- rewrite E; rewrite G. constructor.
+ as [s' [t' [T1' [T2' [w' [A [B [C [D [E [G K]]]]]]]]]]].
+ rewrite G; rewrite K. constructor. auto.
eapply COINDHYP; eauto.
Qed.
+Lemma forever_reactive_determ:
+ forall ge s T1 T2 w,
+ forever_reactive step ge s T1 -> possible_traceinf w T1 ->
+ forever_reactive step ge s T2 -> possible_traceinf w T2 ->
+ traceinf_sim T1 T2.
+Proof.
+ intros. apply traceinf_sim'_sim. eapply forever_reactive_determ'; eauto.
+Qed.
+
Lemma star_forever_reactive_inv:
forall ge s t s', star step ge s t s' ->
forall w w' T, possible_trace w t w' -> forever_reactive step ge s T ->
diff --git a/common/Events.v b/common/Events.v
index 855c013..ad1fc51 100644
--- a/common/Events.v
+++ b/common/Events.v
@@ -13,34 +13,44 @@
(* *)
(* *********************************************************************)
-(** Representation of observable events and execution traces. *)
+(** Observable events, execution traces, and semantics of external calls. *)
Require Import Coqlib.
+Require Intv.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
+Require Import Memory.
+
+(** * Events and traces *)
(** The observable behaviour of programs is stated in terms of
- input/output events, which can also be thought of as system calls
- to the operating system. An event is generated each time an
- external function (see module AST) is invoked. The event records
- the name of the external function, the arguments to the function
- invocation provided by the program, and the return value provided by
- the outside world (e.g. the operating system). Arguments and values
- are either integers or floating-point numbers. We currently do not
- allow pointers to be exchanged between the program and the outside
- world. *)
+ input/output events, which represent the actions of the program
+ that the external world can observe. CompCert leaves much flexibility as to
+ the exact content of events: the only requirement is that they
+ do not expose pointer values nor memory states, because these
+ are not preserved literally during compilation. For concreteness,
+ we use the following type for events. Each event represents either:
+
+- A system call (e.g. an input/output operation), recording the
+ name of the system call, its int-or-float parameters,
+ and its int-or-float result.
+
+- A volatile load from a memory location, recording a label
+ associated with the read (e.g. a global variable name or a source code position).
+
+- A volatile store to a memory location, also recording a label.
+*)
Inductive eventval: Type :=
| EVint: int -> eventval
| EVfloat: float -> eventval.
-Record event : Type := mkevent {
- ev_name: ident;
- ev_args: list eventval;
- ev_res: eventval
-}.
+Inductive event: Type :=
+ | Event_syscall: ident -> list eventval -> eventval -> event
+ | Event_load: ident -> event
+ | Event_store: ident -> event.
(** The dynamic semantics for programs collect traces of events.
Traces are of two kinds: finite (type [trace]) or infinite (type [traceinf]). *)
@@ -49,10 +59,6 @@ Definition trace := list event.
Definition E0 : trace := nil.
-Definition Eextcall
- (name: ident) (args: list eventval) (res: eventval) : trace :=
- mkevent name args res :: nil.
-
Definition Eapp (t1 t2: trace) : trace := t1 ++ t2.
CoInductive traceinf : Type :=
@@ -93,7 +99,7 @@ Qed.
Hint Rewrite E0_left E0_right Eapp_assoc
E0_left_inf Eappinf_assoc: trace_rewrite.
-Opaque trace E0 Eextcall Eapp Eappinf.
+Opaque trace E0 Eapp Eappinf.
(** The following [traceEq] tactic proves equalities between traces
or infinite traces. *)
@@ -115,115 +121,6 @@ Ltac decomposeTraceEq :=
Ltac traceEq :=
repeat substTraceHyp; autorewrite with trace_rewrite; decomposeTraceEq.
-(** The predicate [event_match ef vargs t vres] expresses that
- the event [t] is generated when invoking external function [ef]
- with arguments [vargs], and obtaining [vres] as a return value
- from the operating system. *)
-
-Inductive eventval_match: eventval -> typ -> val -> Prop :=
- | ev_match_int:
- forall i, eventval_match (EVint i) Tint (Vint i)
- | ev_match_float:
- forall f, eventval_match (EVfloat f) Tfloat (Vfloat f).
-
-Inductive eventval_list_match: list eventval -> list typ -> list val -> Prop :=
- | evl_match_nil:
- eventval_list_match nil nil nil
- | evl_match_cons:
- forall ev1 evl ty1 tyl v1 vl,
- eventval_match ev1 ty1 v1 ->
- eventval_list_match evl tyl vl ->
- eventval_list_match (ev1::evl) (ty1::tyl) (v1::vl).
-
-Inductive event_match:
- external_function -> list val -> trace -> val -> Prop :=
- event_match_intro:
- forall ef vargs vres eargs eres,
- eventval_list_match eargs (sig_args ef.(ef_sig)) vargs ->
- eventval_match eres (proj_sig_res ef.(ef_sig)) vres ->
- event_match ef vargs (Eextcall ef.(ef_id) eargs eres) vres.
-
-(** The following section shows that [event_match] is stable under
- relocation of pointer values, as performed by memory injections
- (see module [Mem]). *)
-
-Require Import Mem.
-
-Section EVENT_MATCH_INJECT.
-
-Variable f: meminj.
-
-Remark eventval_match_inject:
- forall ev ty v1, eventval_match ev ty v1 ->
- forall v2, val_inject f v1 v2 ->
- eventval_match ev ty v2.
-Proof.
- induction 1; intros; inversion H; constructor.
-Qed.
-
-Remark eventval_list_match_inject:
- forall evl tyl vl1, eventval_list_match evl tyl vl1 ->
- forall vl2, val_list_inject f vl1 vl2 ->
- eventval_list_match evl tyl vl2.
-Proof.
- induction 1; intros.
- inversion H; constructor.
- inversion H1; constructor.
- eapply eventval_match_inject; eauto.
- eauto.
-Qed.
-
-Lemma event_match_inject:
- forall ef args1 t res args2,
- event_match ef args1 t res ->
- val_list_inject f args1 args2 ->
- event_match ef args2 t res /\ val_inject f res res.
-Proof.
- intros. inversion H; subst.
- split. constructor. eapply eventval_list_match_inject; eauto. auto.
- inversion H2; constructor.
-Qed.
-
-End EVENT_MATCH_INJECT.
-
-(** The following section shows that [event_match] is stable under
- replacement of [Vundef] values by more defined values. *)
-
-Section EVENT_MATCH_LESSDEF.
-
-Remark eventval_match_lessdef:
- forall ev ty v1, eventval_match ev ty v1 ->
- forall v2, Val.lessdef v1 v2 ->
- eventval_match ev ty v2.
-Proof.
- induction 1; intros; inv H; constructor.
-Qed.
-
-Remark eventval_list_match_moredef:
- forall evl tyl vl1, eventval_list_match evl tyl vl1 ->
- forall vl2, Val.lessdef_list vl1 vl2 ->
- eventval_list_match evl tyl vl2.
-Proof.
- induction 1; intros.
- inversion H; constructor.
- inversion H1; constructor.
- eapply eventval_match_lessdef; eauto.
- eauto.
-Qed.
-
-Lemma event_match_lessdef:
- forall ef args1 t res1 args2,
- event_match ef args1 t res1 ->
- Val.lessdef_list args1 args2 ->
- exists res2, event_match ef args2 t res2 /\ Val.lessdef res1 res2.
-Proof.
- intros. inversion H; subst. exists res1; split.
- constructor. eapply eventval_list_match_moredef; eauto. auto.
- auto.
-Qed.
-
-End EVENT_MATCH_LESSDEF.
-
(** Bisimilarity between infinite traces. *)
CoInductive traceinf_sim: traceinf -> traceinf -> Prop :=
@@ -251,6 +148,23 @@ Proof.
cofix COINDHYP;intros. inv H; inv H0; constructor; eauto.
Qed.
+CoInductive traceinf_sim': traceinf -> traceinf -> Prop :=
+ | traceinf_sim'_cons: forall t T1 T2,
+ t <> E0 -> traceinf_sim' T1 T2 -> traceinf_sim' (t *** T1) (t *** T2).
+
+Lemma traceinf_sim'_sim:
+ forall T1 T2, traceinf_sim' T1 T2 -> traceinf_sim T1 T2.
+Proof.
+ cofix COINDHYP; intros. inv H.
+ destruct t. elim H0; auto.
+Transparent Eappinf.
+Transparent E0.
+ simpl.
+ destruct t. simpl. constructor. apply COINDHYP; auto.
+ constructor. apply COINDHYP.
+ constructor. unfold E0; congruence. auto.
+Qed.
+
(** The "is prefix of" relation between a finite and an infinite trace. *)
Inductive traceinf_prefix: trace -> traceinf -> Prop :=
@@ -321,3 +235,586 @@ Proof.
Transparent Eappinf.
simpl. f_equal. apply IHt.
Qed.
+
+(** * Semantics of external functions *)
+
+(** Each external function is of one of the following kinds: *)
+
+Inductive extfun_kind: signature -> Type :=
+ | EF_syscall (sg: signature) (name: ident): extfun_kind sg
+ (** A system call. Takes integer-or-float arguments, produces a
+ result that is an integer or a float, does not modify
+ the memory, and produces an [Event_syscall] event in the trace. *)
+ | EF_load (label: ident) (chunk: memory_chunk): extfun_kind (mksignature (Tint :: nil) (Some (type_of_chunk chunk)))
+ (** A volatile read operation. Reads and returns the given memory
+ chunk from the address given as first argument.
+ Produces an [Event_load] event containing the given label. *)
+ | EF_store (label: ident) (chunk: memory_chunk): extfun_kind (mksignature (Tint :: type_of_chunk chunk :: nil) None)
+ (** A volatile store operation. Store the value given as second
+ argument at the address given as first argument, using the
+ given memory chunk.
+ Produces an [Event_store] event containing the given label. *)
+ | EF_malloc: extfun_kind (mksignature (Tint :: nil) (Some Tint))
+ (** Dynamic memory allocation. Takes the requested size in bytes
+ as argument; returns a pointer to a fresh block of the given size.
+ Produces no observable event. *)
+ | EF_free: extfun_kind (mksignature (Tint :: nil) None).
+ (** Dynamic memory deallocation. Takes a pointer to a block
+ allocated by an [EF_malloc] external call and frees the
+ corresponding block.
+ Produces no observable event. *)
+
+Parameter classify_external_function:
+ forall (ef: external_function), extfun_kind (ef.(ef_sig)).
+
+(** For each external function, its behavior is defined by a predicate relating:
+- the values of the arguments passed to this function
+- the memory state before the call
+- the result value of the call
+- the memory state after the call
+- the trace generated by the call (can be empty).
+
+We now specify the expected properties of this predicate.
+*)
+
+Definition mem_unchanged_on (P: block -> Z -> Prop) (m_before m_after: mem): Prop :=
+ (forall b ofs p,
+ P b ofs -> Mem.perm m_before b ofs p -> Mem.perm m_after b ofs p)
+/\(forall chunk b ofs v,
+ (forall i, ofs <= i < ofs + size_chunk chunk -> P b i) ->
+ Mem.load chunk m_before b ofs = Some v ->
+ Mem.load chunk m_after b ofs = Some v).
+
+Definition loc_out_of_bounds (m: mem) (b: block) (ofs: Z) : Prop :=
+ ofs < Mem.low_bound m b \/ ofs > Mem.high_bound m b.
+
+Definition loc_unmapped (f: meminj) (b: block) (ofs: Z): Prop :=
+ f b = None.
+
+Definition loc_out_of_reach (f: meminj) (m: mem) (b: block) (ofs: Z): Prop :=
+ forall b0 delta,
+ f b0 = Some(b, delta) ->
+ ofs < Mem.low_bound m b0 + delta \/ ofs >= Mem.high_bound m b0 + delta.
+
+Definition inject_separated (f f': meminj) (m1 m2: mem): Prop :=
+ forall b1 b2 delta,
+ f b1 = None -> f' b1 = Some(b2, delta) ->
+ ~Mem.valid_block m1 b1 /\ ~Mem.valid_block m2 b2.
+
+Fixpoint matching_traces (t1 t2: trace) {struct t1} : Prop :=
+ match t1, t2 with
+ | Event_syscall name1 args1 res1 :: t1', Event_syscall name2 args2 res2 :: t2' =>
+ name1 = name2 -> args1 = args2 -> res1 = res2 /\ matching_traces t1' t2'
+ | Event_load name1 :: t1', Event_load name2 :: t2' =>
+ name1 = name2 -> matching_traces t1' t2'
+ | Event_store name1 :: t1', Event_store name2 :: t2' =>
+ name1 = name2 -> matching_traces t1' t2'
+ | _, _ =>
+ True
+ end.
+
+Record extcall_properties (sem: list val -> mem -> trace -> val -> mem -> Prop)
+ (sg: signature) : Prop := mk_extcall_properties {
+
+(** The return value of an external call must agree with its signature. *)
+ ec_well_typed:
+ forall vargs m1 t vres m2,
+ sem vargs m1 t vres m2 ->
+ Val.has_type vres (proj_sig_res sg);
+
+(** The number of arguments of an external call must agree with its signature. *)
+ ec_arity:
+ forall vargs m1 t vres m2,
+ sem vargs m1 t vres m2 ->
+ List.length vargs = List.length sg.(sig_args);
+
+(** External calls cannot invalidate memory blocks. (Remember that
+ freeing a block does not invalidate its block identifier.) *)
+ ec_valid_block:
+ forall vargs m1 t vres m2 b,
+ sem vargs m1 t vres m2 ->
+ Mem.valid_block m1 b -> Mem.valid_block m2 b;
+
+(** External calls preserve the bounds of valid blocks. *)
+ ec_bounds:
+ forall vargs m1 t vres m2 b,
+ sem vargs m1 t vres m2 ->
+ Mem.valid_block m1 b -> Mem.bounds m2 b = Mem.bounds m1 b;
+
+(** External calls must commute with memory extensions, in the
+ following sense. *)
+ ec_mem_extends:
+ forall vargs m1 t vres m2 m1' vargs',
+ sem vargs m1 t vres m2 ->
+ Mem.extends m1 m1' ->
+ Val.lessdef_list vargs vargs' ->
+ exists vres', exists m2',
+ sem vargs' m1' t vres' m2'
+ /\ Val.lessdef vres vres'
+ /\ Mem.extends m2 m2'
+ /\ mem_unchanged_on (loc_out_of_bounds m1) m1' m2';
+
+(** External calls must commute with memory injections,
+ in the following sense. *)
+ ec_mem_inject:
+ forall vargs m1 t vres m2 f m1' vargs',
+ sem vargs m1 t vres m2 ->
+ Mem.inject f m1 m1' ->
+ val_list_inject f vargs vargs' ->
+ exists f', exists vres', exists m2',
+ sem vargs' m1' t vres' m2'
+ /\ val_inject f' vres vres'
+ /\ Mem.inject f' m2 m2'
+ /\ mem_unchanged_on (loc_unmapped f) m1 m2
+ /\ mem_unchanged_on (loc_out_of_reach f m1) m1' m2'
+ /\ inject_incr f f'
+ /\ inject_separated f f' m1 m1';
+
+(** External calls must be internally deterministic:
+ if the observable traces match, the return states must be
+ identical. *)
+ ec_determ:
+ forall vargs m t1 vres1 m1 t2 vres2 m2,
+ sem vargs m t1 vres1 m1 -> sem vargs m t2 vres2 m2 ->
+ matching_traces t1 t2 -> t1 = t2 /\ vres1 = vres2 /\ m1 = m2
+}.
+
+(** ** Semantics of volatile loads *)
+
+Inductive extcall_load_sem (label: ident) (chunk: memory_chunk):
+ list val -> mem -> trace -> val -> mem -> Prop :=
+ | extcall_load_sem_intro: forall b ofs m vres,
+ Mem.load chunk m b (Int.signed ofs) = Some vres ->
+ extcall_load_sem label chunk (Vptr b ofs :: nil) m (Event_load label :: nil) vres m.
+
+Lemma extcall_load_ok:
+ forall label chunk,
+ extcall_properties (extcall_load_sem label chunk)
+ (mksignature (Tint :: nil) (Some (type_of_chunk chunk))).
+Proof.
+ intros; constructor; intros.
+
+ inv H. unfold proj_sig_res. simpl. eapply Mem.load_type; eauto.
+
+ inv H. simpl. auto.
+
+ inv H. auto.
+
+ inv H. auto.
+
+ inv H. inv H1. inv H6. inv H4.
+ exploit Mem.load_extends; eauto. intros [v2 [A B]].
+ exists v2; exists m1'; intuition.
+ constructor; auto.
+ red. auto.
+
+ inv H. inv H1. inv H6.
+ assert (Mem.loadv chunk m2 (Vptr b ofs) = Some vres). auto.
+ exploit Mem.loadv_inject; eauto. intros [v2 [A B]].
+ inv H4.
+ exists f; exists v2; exists m1'; intuition.
+ constructor. auto.
+ red; auto.
+ red; auto.
+ red; intros. congruence.
+
+ inv H; inv H0. intuition congruence.
+Qed.
+
+(** ** Semantics of volatile stores *)
+
+Inductive extcall_store_sem (label: ident) (chunk: memory_chunk):
+ list val -> mem -> trace -> val -> mem -> Prop :=
+ | extcall_store_sem_intro: forall b ofs v m m',
+ Mem.store chunk m b (Int.signed ofs) v = Some m' ->
+ extcall_store_sem label chunk (Vptr b ofs :: v :: nil) m (Event_store label :: nil) Vundef m'.
+
+Lemma extcall_store_ok:
+ forall label chunk,
+ extcall_properties (extcall_store_sem label chunk)
+ (mksignature (Tint :: type_of_chunk chunk :: nil) None).
+Proof.
+ intros; constructor; intros.
+
+ inv H. unfold proj_sig_res. simpl. auto.
+
+ inv H. simpl. auto.
+
+ inv H. eauto with mem.
+
+ inv H. eapply Mem.bounds_store; eauto.
+
+ inv H. inv H1. inv H6. inv H7. inv H4.
+ exploit Mem.store_within_extends; eauto. intros [m' [A B]].
+ exists Vundef; exists m'; intuition.
+ constructor; auto.
+ red; split; intros.
+ eapply Mem.perm_store_1; eauto.
+ rewrite <- H1. eapply Mem.load_store_other; eauto.
+ destruct (eq_block b0 b); auto. subst b0; right.
+ exploit Mem.valid_access_in_bounds.
+ eapply Mem.store_valid_access_3. eexact H2.
+ intros [C D].
+ generalize (size_chunk_pos chunk0). intro E.
+ generalize (size_chunk_pos chunk). intro F.
+ apply (Intv.range_disjoint' (ofs0, ofs0 + size_chunk chunk0)
+ (Int.signed ofs, Int.signed ofs + size_chunk chunk)).
+ red; intros. generalize (H x H4). unfold loc_out_of_bounds, Intv.In; simpl. omega.
+ simpl; omega. simpl; omega.
+
+ inv H. inv H1. inv H6. inv H7.
+ assert (Mem.storev chunk m1 (Vptr b ofs) v = Some m2). simpl; auto.
+ exploit Mem.storev_mapped_inject; eauto. intros [m2' [A B]].
+ inv H4.
+ exists f; exists Vundef; exists m2'; intuition.
+ constructor; auto.
+ split; intros. eapply Mem.perm_store_1; eauto.
+ rewrite <- H4. eapply Mem.load_store_other; eauto.
+ left. exploit (H1 ofs0). generalize (size_chunk_pos chunk0). omega.
+ unfold loc_unmapped. congruence.
+ split; intros. eapply Mem.perm_store_1; eauto.
+ rewrite <- H4. eapply Mem.load_store_other; eauto.
+ destruct (eq_block b0 b2); auto. subst b0; right.
+ assert (EQ: Int.signed (Int.add ofs (Int.repr delta)) = Int.signed ofs + delta).
+ eapply Mem.address_inject; eauto with mem.
+ simpl in A. rewrite EQ in A. rewrite EQ.
+ exploit Mem.valid_access_in_bounds.
+ eapply Mem.store_valid_access_3. eexact H2.
+ intros [C D].
+ generalize (size_chunk_pos chunk0). intro E.
+ generalize (size_chunk_pos chunk). intro F.
+ apply (Intv.range_disjoint' (ofs0, ofs0 + size_chunk chunk0)
+ (Int.signed ofs + delta, Int.signed ofs + delta + size_chunk chunk)).
+ red; intros. exploit (H1 x H5). eauto. unfold Intv.In; simpl. omega.
+ simpl; omega. simpl; omega.
+
+ red; intros. congruence.
+
+ inv H; inv H0. intuition congruence.
+Qed.
+
+(** ** Semantics of dynamic memory allocation (malloc) *)
+
+Inductive extcall_malloc_sem:
+ list val -> mem -> trace -> val -> mem -> Prop :=
+ | extcall_malloc_sem_intro: forall n m m' b m'',
+ Mem.alloc m (-4) (Int.signed n) = (m', b) ->
+ Mem.store Mint32 m' b (-4) (Vint n) = Some m'' ->
+ extcall_malloc_sem (Vint n :: nil) m E0 (Vptr b Int.zero) m''.
+
+Lemma extcall_malloc_ok:
+ extcall_properties extcall_malloc_sem
+ (mksignature (Tint :: nil) (Some Tint)).
+Proof.
+ assert (UNCHANGED:
+ forall (P: block -> Z -> Prop) m n m' b m'',
+ Mem.alloc m (-4) (Int.signed n) = (m', b) ->
+ Mem.store Mint32 m' b (-4) (Vint n) = Some m'' ->
+ mem_unchanged_on P m m'').
+ intros; split; intros.
+ eauto with mem.
+ transitivity (Mem.load chunk m' b0 ofs).
+ eapply Mem.load_store_other; eauto. left.
+ apply Mem.valid_not_valid_diff with m; eauto with mem.
+ eapply Mem.load_alloc_other; eauto.
+
+ constructor; intros.
+
+ inv H. unfold proj_sig_res; simpl. auto.
+
+ inv H. auto.
+
+ inv H. eauto with mem.
+
+ inv H. transitivity (Mem.bounds m' b).
+ eapply Mem.bounds_store; eauto.
+ eapply Mem.bounds_alloc_other; eauto.
+ apply Mem.valid_not_valid_diff with m1; eauto with mem.
+
+ inv H. inv H1. inv H5. inv H7.
+ exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl.
+ intros [m3' [A B]].
+ exploit Mem.store_within_extends. eexact B. eauto.
+ instantiate (1 := Vint n). auto.
+ intros [m2' [C D]].
+ exists (Vptr b Int.zero); exists m2'; intuition.
+ econstructor; eauto.
+ eapply UNCHANGED; eauto.
+
+ inv H. inv H1. inv H5. inv H7.
+ exploit Mem.alloc_parallel_inject; eauto. apply Zle_refl. apply Zle_refl.
+ intros [f' [m3' [b' [ALLOC [A [B [C D]]]]]]].
+ exploit Mem.store_mapped_inject. eexact A. eauto. eauto.
+ instantiate (1 := Vint n). auto.
+ intros [m2' [E F]].
+ exists f'; exists (Vptr b' Int.zero); exists m2'; intuition.
+ econstructor; eauto.
+ econstructor. eauto. auto.
+ eapply UNCHANGED; eauto.
+ eapply UNCHANGED; eauto.
+ red; intros. destruct (eq_block b1 b).
+ subst b1. rewrite C in H1. inv H1. eauto with mem.
+ rewrite D in H1. congruence. auto.
+
+ inv H; inv H0. intuition congruence.
+Qed.
+
+(** ** Semantics of dynamic memory deallocation (free) *)
+
+Inductive extcall_free_sem:
+ list val -> mem -> trace -> val -> mem -> Prop :=
+ | extcall_free_sem_intro: forall b lo sz m m',
+ Mem.load Mint32 m b (Int.signed lo - 4) = Some (Vint sz) ->
+ Int.signed sz > 0 ->
+ Mem.free m b (Int.signed lo - 4) (Int.signed lo + Int.signed sz) = Some m' ->
+ extcall_free_sem (Vptr b lo :: nil) m E0 Vundef m'.
+
+Lemma extcall_free_ok:
+ extcall_properties extcall_free_sem
+ (mksignature (Tint :: nil) None).
+Proof.
+ assert (UNCHANGED:
+ forall (P: block -> Z -> Prop) m b lo hi m',
+ Mem.free m b lo hi = Some m' ->
+ lo < hi ->
+ (forall b' ofs, P b' ofs -> b' <> b \/ ofs < lo \/ hi <= ofs) ->
+ mem_unchanged_on P m m').
+ intros; split; intros.
+ eapply Mem.perm_free_1; eauto.
+ rewrite <- H3. eapply Mem.load_free; eauto.
+ destruct (eq_block b0 b); auto. right. right.
+ apply (Intv.range_disjoint' (ofs, ofs + size_chunk chunk) (lo, hi)).
+ red; intros. apply Intv.notin_range. simpl. exploit H1; eauto. intuition.
+ simpl; generalize (size_chunk_pos chunk); omega.
+ simpl; omega.
+
+ constructor; intros.
+
+ inv H. unfold proj_sig_res. simpl. auto.
+
+ inv H. auto.
+
+ inv H. eauto with mem.
+
+ inv H. eapply Mem.bounds_free; eauto.
+
+ inv H. inv H1. inv H8. inv H6.
+ exploit Mem.load_extends; eauto. intros [vsz [A B]]. inv B.
+ exploit Mem.free_parallel_extends; eauto. intros [m2' [C D]].
+ exists Vundef; exists m2'; intuition.
+ econstructor; eauto.
+ eapply UNCHANGED; eauto. omega.
+ intros. destruct (eq_block b' b); auto. subst b; right.
+ red in H.
+ exploit Mem.range_perm_in_bounds.
+ eapply Mem.free_range_perm. eexact H4. omega. omega.
+
+ inv H. inv H1. inv H8. inv H6.
+ exploit Mem.load_inject; eauto. intros [vsz [A B]]. inv B.
+ assert (Mem.range_perm m1 b (Int.signed lo - 4) (Int.signed lo + Int.signed sz) Freeable).
+ eapply Mem.free_range_perm; eauto.
+ exploit Mem.address_inject; eauto.
+ apply Mem.perm_implies with Freeable; auto with mem.
+ apply H. instantiate (1 := lo). omega.
+ intro EQ.
+ assert (Mem.range_perm m1' b2 (Int.signed lo + delta - 4) (Int.signed lo + delta + Int.signed sz) Freeable).
+ red; intros.
+ replace ofs with ((ofs - delta) + delta) by omega.
+ eapply Mem.perm_inject; eauto. apply H. omega.
+ destruct (Mem.range_perm_free _ _ _ _ H1) as [m2' FREE].
+ exists f; exists Vundef; exists m2'; intuition.
+
+ econstructor.
+ rewrite EQ. replace (Int.signed lo + delta - 4) with (Int.signed lo - 4 + delta) by omega.
+ eauto. auto.
+ rewrite EQ. auto.
+
+ assert (Mem.free_list m1 ((b, Int.signed lo - 4, Int.signed lo + Int.signed sz) :: nil) = Some m2).
+ simpl. rewrite H4. auto.
+ eapply Mem.free_inject; eauto.
+ intros. destruct (eq_block b b1).
+ subst b. assert (delta0 = delta) by congruence. subst delta0.
+ exists (Int.signed lo - 4); exists (Int.signed lo + Int.signed sz); split.
+ simpl; auto. omega.
+ elimtype False.
+ exploit Mem.inject_no_overlap. eauto. eauto. eauto. eauto.
+ instantiate (1 := ofs + delta0 - delta).
+ apply Mem.perm_implies with Freeable; auto with mem.
+ apply H. omega. eauto with mem.
+ unfold block; omega.
+
+ eapply UNCHANGED; eauto. omega. intros.
+ red in H6. left. congruence.
+
+ eapply UNCHANGED; eauto. omega. intros.
+ destruct (eq_block b' b2); auto. subst b'. right.
+ red in H6. generalize (H6 _ _ H5). intros.
+ exploit Mem.range_perm_in_bounds. eexact H. omega. intros. omega.
+
+ red; intros. congruence.
+
+ inv H; inv H0. intuition congruence.
+Qed.
+
+(** ** Semantics of system calls. *)
+
+Inductive eventval_match: eventval -> typ -> val -> Prop :=
+ | ev_match_int:
+ forall i, eventval_match (EVint i) Tint (Vint i)
+ | ev_match_float:
+ forall f, eventval_match (EVfloat f) Tfloat (Vfloat f).
+
+Inductive eventval_list_match: list eventval -> list typ -> list val -> Prop :=
+ | evl_match_nil:
+ eventval_list_match nil nil nil
+ | evl_match_cons:
+ forall ev1 evl ty1 tyl v1 vl,
+ eventval_match ev1 ty1 v1 ->
+ eventval_list_match evl tyl vl ->
+ eventval_list_match (ev1::evl) (ty1::tyl) (v1::vl).
+
+Inductive extcall_io_sem (name: ident) (sg: signature):
+ list val -> mem -> trace -> val -> mem -> Prop :=
+ | extcall_io_sem_intro: forall vargs m args res vres,
+ eventval_list_match args (sig_args sg) vargs ->
+ eventval_match res (proj_sig_res sg) vres ->
+ extcall_io_sem name sg vargs m (Event_syscall name args res :: E0) vres m.
+
+Remark eventval_match_lessdef:
+ forall ev ty v1 v2,
+ eventval_match ev ty v1 -> Val.lessdef v1 v2 -> eventval_match ev ty v2.
+Proof.
+ intros. inv H; inv H0; constructor.
+Qed.
+
+Remark eventval_list_match_lessdef:
+ forall evl tyl vl1, eventval_list_match evl tyl vl1 ->
+ forall vl2, Val.lessdef_list vl1 vl2 -> eventval_list_match evl tyl vl2.
+Proof.
+ induction 1; intros. inv H; constructor.
+ inv H1. constructor. eapply eventval_match_lessdef; eauto. eauto.
+Qed.
+
+Remark eventval_match_inject:
+ forall f ev ty v1 v2,
+ eventval_match ev ty v1 -> val_inject f v1 v2 -> eventval_match ev ty v2.
+Proof.
+ intros. inv H; inv H0; constructor.
+Qed.
+
+Remark eventval_match_inject_2:
+ forall f ev ty v,
+ eventval_match ev ty v -> val_inject f v v.
+Proof.
+ induction 1; constructor.
+Qed.
+
+Remark eventval_list_match_inject:
+ forall f evl tyl vl1, eventval_list_match evl tyl vl1 ->
+ forall vl2, val_list_inject f vl1 vl2 -> eventval_list_match evl tyl vl2.
+Proof.
+ induction 1; intros. inv H; constructor.
+ inv H1. constructor. eapply eventval_match_inject; eauto. eauto.
+Qed.
+
+Remark eventval_list_match_length:
+ forall evl tyl vl, eventval_list_match evl tyl vl -> List.length vl = List.length tyl.
+Proof.
+ induction 1; simpl; eauto.
+Qed.
+
+Remark eventval_match_determ_1:
+ forall ev ty v1 v2, eventval_match ev ty v1 -> eventval_match ev ty v2 -> v1 = v2.
+Proof.
+ intros. inv H; inv H0; auto.
+Qed.
+
+Remark eventval_match_determ_2:
+ forall ev1 ev2 ty v, eventval_match ev1 ty v -> eventval_match ev2 ty v -> ev1 = ev2.
+Proof.
+ intros. inv H; inv H0; auto.
+Qed.
+
+Remark eventval_list_match_determ_2:
+ forall evl1 tyl vl, eventval_list_match evl1 tyl vl ->
+ forall evl2, eventval_list_match evl2 tyl vl -> evl1 = evl2.
+Proof.
+ induction 1; intros. inv H. auto. inv H1. f_equal; eauto.
+ eapply eventval_match_determ_2; eauto.
+Qed.
+
+Lemma extcall_io_ok:
+ forall name sg,
+ extcall_properties (extcall_io_sem name sg) sg.
+Proof.
+ intros; constructor; intros.
+
+ inv H. inv H1; constructor.
+
+ inv H. eapply eventval_list_match_length; eauto.
+
+ inv H; auto.
+
+ inv H; auto.
+
+ inv H.
+ exists vres; exists m1'; intuition.
+ econstructor; eauto. eapply eventval_list_match_lessdef; eauto.
+ red; auto.
+
+ inv H.
+ exists f; exists vres; exists m1'; intuition.
+ econstructor; eauto. eapply eventval_list_match_inject; eauto.
+ eapply eventval_match_inject_2; eauto.
+ red; auto.
+ red; auto.
+ red; intros; congruence.
+
+ inv H; inv H0. simpl in H1.
+ assert (args = args0) by (eapply eventval_list_match_determ_2; eauto).
+ destruct H1; auto. subst.
+ intuition. eapply eventval_match_determ_1; eauto.
+Qed.
+
+(** ** Combined semantics of external calls *)
+
+(** Combining the semantics given above for the various kinds of external calls,
+ we define the predicate [external_call] that relates:
+- the external function being invoked
+- the values of the arguments passed to this function
+- the memory state before the call
+- the result value of the call
+- the memory state after the call
+- the trace generated by the call (can be empty).
+
+This predicate is used in the semantics of all CompCert languages. *)
+
+Definition external_call (ef: external_function):
+ list val -> mem -> trace -> val -> mem -> Prop :=
+ match classify_external_function ef with
+ | EF_syscall sg name => extcall_io_sem name sg
+ | EF_load label chunk => extcall_load_sem label chunk
+ | EF_store label chunk => extcall_store_sem label chunk
+ | EF_malloc => extcall_malloc_sem
+ | EF_free => extcall_free_sem
+ end.
+
+Theorem external_call_spec:
+ forall ef,
+ extcall_properties (external_call ef) (ef.(ef_sig)).
+Proof.
+ intros. unfold external_call. destruct (classify_external_function ef).
+ apply extcall_io_ok.
+ apply extcall_load_ok.
+ apply extcall_store_ok.
+ apply extcall_malloc_ok.
+ apply extcall_free_ok.
+Qed.
+
+Definition external_call_well_typed ef := ec_well_typed _ _ (external_call_spec ef).
+Definition external_call_arity ef := ec_arity _ _ (external_call_spec ef).
+Definition external_call_valid_block ef := ec_valid_block _ _ (external_call_spec ef).
+Definition external_call_bounds ef := ec_bounds _ _ (external_call_spec ef).
+Definition external_call_mem_extends ef := ec_mem_extends _ _ (external_call_spec ef).
+Definition external_call_mem_inject ef := ec_mem_inject _ _ (external_call_spec ef).
+Definition external_call_determ ef := ec_determ _ _ (external_call_spec ef).
diff --git a/common/Globalenvs.v b/common/Globalenvs.v
index 1ce7bf5..9dbf902 100644
--- a/common/Globalenvs.v
+++ b/common/Globalenvs.v
@@ -38,530 +38,259 @@ Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
+Require Import Floats.
Require Import Values.
-Require Import Mem.
+Require Import Memory.
-Set Implicit Arguments.
+Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
+Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
-Module Type GENV.
-
-(** ** Types and operations *)
-
- Variable t: Type -> Type.
- (** The type of global environments. The parameter [F] is the type
- of function descriptions. *)
-
- Variable globalenv: forall (F V: Type), program F V -> t F.
- (** Return the global environment for the given program. *)
-
- Variable init_mem: forall (F V: Type), program F V -> mem.
- (** Return the initial memory state for the given program. *)
-
- Variable find_funct_ptr: forall (F: Type), t F -> block -> option F.
- (** Return the function description associated with the given address,
- if any. *)
-
- Variable find_funct: forall (F: Type), t F -> val -> option F.
- (** Same as [find_funct_ptr] but the function address is given as
- a value, which must be a pointer with offset 0. *)
-
- Variable find_symbol: forall (F: Type), t F -> ident -> option block.
- (** Return the address of the given global symbol, if any. *)
-
-(** ** Properties of the operations. *)
-
- Hypothesis find_funct_inv:
- forall (F: Type) (ge: t F) (v: val) (f: F),
- find_funct ge v = Some f -> exists b, v = Vptr b Int.zero.
- Hypothesis find_funct_find_funct_ptr:
- forall (F: Type) (ge: t F) (b: block),
- find_funct ge (Vptr b Int.zero) = find_funct_ptr ge b.
-
- Hypothesis find_symbol_exists:
- forall (F V: Type) (p: program F V)
- (id: ident) (init: list init_data) (v: V),
- In (id, init, v) (prog_vars p) ->
- exists b, find_symbol (globalenv p) id = Some b.
- Hypothesis find_funct_ptr_exists:
- forall (F V: Type) (p: program F V) (id: ident) (f: F),
- list_norepet (prog_funct_names p) ->
- list_disjoint (prog_funct_names p) (prog_var_names p) ->
- In (id, f) (prog_funct p) ->
- exists b, find_symbol (globalenv p) id = Some b
- /\ find_funct_ptr (globalenv p) b = Some f.
-
- Hypothesis find_funct_ptr_inversion:
- forall (F V: Type) (P: F -> Prop) (p: program F V) (b: block) (f: F),
- find_funct_ptr (globalenv p) b = Some f ->
- exists id, In (id, f) (prog_funct p).
- Hypothesis find_funct_inversion:
- forall (F V: Type) (P: F -> Prop) (p: program F V) (v: val) (f: F),
- find_funct (globalenv p) v = Some f ->
- exists id, In (id, f) (prog_funct p).
- Hypothesis find_funct_ptr_symbol_inversion:
- forall (F V: Type) (p: program F V) (id: ident) (b: block) (f: F),
- find_symbol (globalenv p) id = Some b ->
- find_funct_ptr (globalenv p) b = Some f ->
- In (id, f) p.(prog_funct).
-
- Hypothesis find_funct_ptr_prop:
- forall (F V: Type) (P: F -> Prop) (p: program F V) (b: block) (f: F),
- (forall id f, In (id, f) (prog_funct p) -> P f) ->
- find_funct_ptr (globalenv p) b = Some f ->
- P f.
- Hypothesis find_funct_prop:
- forall (F V: Type) (P: F -> Prop) (p: program F V) (v: val) (f: F),
- (forall id f, In (id, f) (prog_funct p) -> P f) ->
- find_funct (globalenv p) v = Some f ->
- P f.
-
- Hypothesis initmem_nullptr:
- forall (F V: Type) (p: program F V),
- let m := init_mem p in
- valid_block m nullptr /\
- m.(blocks) nullptr = empty_block 0 0.
- Hypothesis initmem_inject_neutral:
- forall (F V: Type) (p: program F V),
- mem_inject_neutral (init_mem p).
- Hypothesis find_funct_ptr_negative:
- forall (F V: Type) (p: program F V) (b: block) (f: F),
- find_funct_ptr (globalenv p) b = Some f -> b < 0.
- Hypothesis find_symbol_not_fresh:
- forall (F V: Type) (p: program F V) (id: ident) (b: block),
- find_symbol (globalenv p) id = Some b -> b < nextblock (init_mem p).
- Hypothesis find_symbol_not_nullptr:
- forall (F V: Type) (p: program F V) (id: ident) (b: block),
- find_symbol (globalenv p) id = Some b -> b <> nullptr.
- Hypothesis global_addresses_distinct:
- forall (F V: Type) (p: program F V) id1 id2 b1 b2,
- id1<>id2 ->
- find_symbol (globalenv p) id1 = Some b1 ->
- find_symbol (globalenv p) id2 = Some b2 ->
- b1<>b2.
-
-(** Commutation properties between program transformations
- and operations over global environments. *)
-
- Hypothesis find_funct_ptr_transf:
- forall (A B V: Type) (transf: A -> B) (p: program A V),
- forall (b: block) (f: A),
- find_funct_ptr (globalenv p) b = Some f ->
- find_funct_ptr (globalenv (transform_program transf p)) b = Some (transf f).
- Hypothesis find_funct_transf:
- forall (A B V: Type) (transf: A -> B) (p: program A V),
- forall (v: val) (f: A),
- find_funct (globalenv p) v = Some f ->
- find_funct (globalenv (transform_program transf p)) v = Some (transf f).
- Hypothesis find_symbol_transf:
- forall (A B V: Type) (transf: A -> B) (p: program A V),
- forall (s: ident),
- find_symbol (globalenv (transform_program transf p)) s =
- find_symbol (globalenv p) s.
- Hypothesis init_mem_transf:
- forall (A B V: Type) (transf: A -> B) (p: program A V),
- init_mem (transform_program transf p) = init_mem p.
- Hypothesis find_funct_ptr_rev_transf:
- forall (A B V: Type) (transf: A -> B) (p: program A V),
- forall (b : block) (tf : B),
- find_funct_ptr (globalenv (transform_program transf p)) b = Some tf ->
- exists f : A, find_funct_ptr (globalenv p) b = Some f /\ transf f = tf.
- Hypothesis find_funct_rev_transf:
- forall (A B V: Type) (transf: A -> B) (p: program A V),
- forall (v : val) (tf : B),
- find_funct (globalenv (transform_program transf p)) v = Some tf ->
- exists f : A, find_funct (globalenv p) v = Some f /\ transf f = tf.
-
-(** Commutation properties between partial program transformations
- and operations over global environments. *)
-
- Hypothesis find_funct_ptr_transf_partial:
- forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V),
- transform_partial_program transf p = OK p' ->
- forall (b: block) (f: A),
- find_funct_ptr (globalenv p) b = Some f ->
- exists f',
- find_funct_ptr (globalenv p') b = Some f' /\ transf f = OK f'.
- Hypothesis find_funct_transf_partial:
- forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V),
- transform_partial_program transf p = OK p' ->
- forall (v: val) (f: A),
- find_funct (globalenv p) v = Some f ->
- exists f',
- find_funct (globalenv p') v = Some f' /\ transf f = OK f'.
- Hypothesis find_symbol_transf_partial:
- forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V),
- transform_partial_program transf p = OK p' ->
- forall (s: ident),
- find_symbol (globalenv p') s = find_symbol (globalenv p) s.
- Hypothesis init_mem_transf_partial:
- forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V),
- transform_partial_program transf p = OK p' ->
- init_mem p' = init_mem p.
- Hypothesis find_funct_ptr_rev_transf_partial:
- forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V),
- transform_partial_program transf p = OK p' ->
- forall (b : block) (tf : B),
- find_funct_ptr (globalenv p') b = Some tf ->
- exists f : A,
- find_funct_ptr (globalenv p) b = Some f /\ transf f = OK tf.
- Hypothesis find_funct_rev_transf_partial:
- forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V),
- transform_partial_program transf p = OK p' ->
- forall (v : val) (tf : B),
- find_funct (globalenv p') v = Some tf ->
- exists f : A,
- find_funct (globalenv p) v = Some f /\ transf f = OK tf.
-
- Hypothesis find_funct_ptr_transf_partial2:
- forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W)
- (p: program A V) (p': program B W),
- transform_partial_program2 transf_fun transf_var p = OK p' ->
- forall (b: block) (f: A),
- find_funct_ptr (globalenv p) b = Some f ->
- exists f',
- find_funct_ptr (globalenv p') b = Some f' /\ transf_fun f = OK f'.
- Hypothesis find_funct_transf_partial2:
- forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W)
- (p: program A V) (p': program B W),
- transform_partial_program2 transf_fun transf_var p = OK p' ->
- forall (v: val) (f: A),
- find_funct (globalenv p) v = Some f ->
- exists f',
- find_funct (globalenv p') v = Some f' /\ transf_fun f = OK f'.
- Hypothesis find_symbol_transf_partial2:
- forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W)
- (p: program A V) (p': program B W),
- transform_partial_program2 transf_fun transf_var p = OK p' ->
- forall (s: ident),
- find_symbol (globalenv p') s = find_symbol (globalenv p) s.
- Hypothesis init_mem_transf_partial2:
- forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W)
- (p: program A V) (p': program B W),
- transform_partial_program2 transf_fun transf_var p = OK p' ->
- init_mem p' = init_mem p.
- Hypothesis find_funct_ptr_rev_transf_partial2:
- forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W)
- (p: program A V) (p': program B W),
- transform_partial_program2 transf_fun transf_var p = OK p' ->
- forall (b : block) (tf : B),
- find_funct_ptr (globalenv p') b = Some tf ->
- exists f : A,
- find_funct_ptr (globalenv p) b = Some f /\ transf_fun f = OK tf.
- Hypothesis find_funct_rev_transf_partial2:
- forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W)
- (p: program A V) (p': program B W),
- transform_partial_program2 transf_fun transf_var p = OK p' ->
- forall (v : val) (tf : B),
- find_funct (globalenv p') v = Some tf ->
- exists f : A,
- find_funct (globalenv p) v = Some f /\ transf_fun f = OK tf.
-
-(** Commutation properties between matching between programs
- and operations over global environments. *)
-
- Hypothesis find_funct_ptr_match:
- forall (A B V W: Type) (match_fun: A -> B -> Prop)
- (match_var: V -> W -> Prop) (p: program A V) (p': program B W),
- match_program match_fun match_var p p' ->
- forall (b : block) (f : A),
- find_funct_ptr (globalenv p) b = Some f ->
- exists tf : B,
- find_funct_ptr (globalenv p') b = Some tf /\ match_fun f tf.
- Hypothesis find_funct_ptr_rev_match:
- forall (A B V W: Type) (match_fun: A -> B -> Prop)
- (match_var: V -> W -> Prop) (p: program A V) (p': program B W),
- match_program match_fun match_var p p' ->
- forall (b : block) (tf : B),
- find_funct_ptr (globalenv p') b = Some tf ->
- exists f : A,
- find_funct_ptr (globalenv p) b = Some f /\ match_fun f tf.
- Hypothesis find_funct_match:
- forall (A B V W: Type) (match_fun: A -> B -> Prop)
- (match_var: V -> W -> Prop) (p: program A V) (p': program B W),
- match_program match_fun match_var p p' ->
- forall (v : val) (f : A),
- find_funct (globalenv p) v = Some f ->
- exists tf : B, find_funct (globalenv p') v = Some tf /\ match_fun f tf.
- Hypothesis find_funct_rev_match:
- forall (A B V W: Type) (match_fun: A -> B -> Prop)
- (match_var: V -> W -> Prop) (p: program A V) (p': program B W),
- match_program match_fun match_var p p' ->
- forall (v : val) (tf : B),
- find_funct (globalenv p') v = Some tf ->
- exists f : A, find_funct (globalenv p) v = Some f /\ match_fun f tf.
- Hypothesis find_symbol_match:
- forall (A B V W: Type) (match_fun: A -> B -> Prop)
- (match_var: V -> W -> Prop) (p: program A V) (p': program B W),
- match_program match_fun match_var p p' ->
- forall (s : ident),
- find_symbol (globalenv p') s = find_symbol (globalenv p) s.
- Hypothesis init_mem_match:
- forall (A B V W: Type) (match_fun: A -> B -> Prop)
- (match_var: V -> W -> Prop) (p: program A V) (p': program B W),
- match_program match_fun match_var p p' ->
- init_mem p' = init_mem p.
+Local Open Scope pair_scope.
+Local Open Scope error_monad_scope.
-End GENV.
+Set Implicit Arguments.
-(** The rest of this library is a straightforward implementation of
- the module signature above. *)
+Module Genv.
-Module Genv: GENV.
+(** * Global environments *)
Section GENV.
-Variable F: Type. (* The type of functions *)
-Variable V: Type. (* The type of information over variables *)
-
-Record genv : Type := mkgenv {
- functions: ZMap.t (option F); (* mapping function ptr -> function *)
- nextfunction: Z;
- symbols: PTree.t block (* mapping symbol -> block *)
+Variable F: Type. (**r The type of function descriptions *)
+Variable V: Type. (**r The type of information attached to variables *)
+
+(** The type of global environments. *)
+
+Record t: Type := mkgenv {
+ genv_symb: PTree.t block; (**r mapping symbol -> block *)
+ genv_funs: ZMap.t (option F); (**r mapping function pointer -> definition *)
+ genv_vars: ZMap.t (option V); (**r mapping variable pointer -> info *)
+ genv_nextfun: block; (**r next function pointer *)
+ genv_nextvar: block; (**r next variable pointer *)
+ genv_nextfun_neg: genv_nextfun < 0;
+ genv_nextvar_pos: genv_nextvar > 0;
+ genv_symb_range: forall id b, PTree.get id genv_symb = Some b -> b <> 0 /\ genv_nextfun < b /\ b < genv_nextvar;
+ genv_funs_range: forall b f, ZMap.get b genv_funs = Some f -> genv_nextfun < b < 0;
+ genv_vars_range: forall b v, ZMap.get b genv_vars = Some v -> 0 < b < genv_nextvar
}.
-Definition t := genv.
+(** ** Lookup functions *)
-Definition add_funct (name_fun: (ident * F)) (g: genv) : genv :=
- let b := g.(nextfunction) in
- mkgenv (ZMap.set b (Some (snd name_fun)) g.(functions))
- (Zpred b)
- (PTree.set (fst name_fun) b g.(symbols)).
+(** [find_symbol ge id] returns the block associated with the given name, if any *)
-Definition add_symbol (name: ident) (b: block) (g: genv) : genv :=
- mkgenv g.(functions)
- g.(nextfunction)
- (PTree.set name b g.(symbols)).
+Definition find_symbol (ge: t) (id: ident) : option block :=
+ PTree.get id ge.(genv_symb).
-Definition find_funct_ptr (g: genv) (b: block) : option F :=
- ZMap.get b g.(functions).
+(** [find_funct_ptr ge b] returns the function description associated with
+ the given address. *)
-Definition find_funct (g: genv) (v: val) : option F :=
+Definition find_funct_ptr (ge: t) (b: block) : option F :=
+ ZMap.get b ge.(genv_funs).
+
+(** [find_funct] is similar to [find_funct_ptr], but the function address
+ is given as a value, which must be a pointer with offset 0. *)
+
+Definition find_funct (ge: t) (v: val) : option F :=
match v with
- | Vptr b ofs =>
- if Int.eq ofs Int.zero then find_funct_ptr g b else None
- | _ =>
- None
+ | Vptr b ofs => if Int.eq_dec ofs Int.zero then find_funct_ptr ge b else None
+ | _ => None
end.
-Definition find_symbol (g: genv) (symb: ident) : option block :=
- PTree.get symb g.(symbols).
+(** [find_var_info ge b] returns the information attached to the variable
+ at address [b]. *)
+
+Definition find_var_info (ge: t) (b: block) : option V :=
+ ZMap.get b ge.(genv_vars).
+
+(** ** Constructing the global environment *)
+
+Program Definition add_function (ge: t) (idf: ident * F) : t :=
+ @mkgenv
+ (PTree.set idf#1 ge.(genv_nextfun) ge.(genv_symb))
+ (ZMap.set ge.(genv_nextfun) (Some idf#2) ge.(genv_funs))
+ ge.(genv_vars)
+ (ge.(genv_nextfun) - 1)
+ ge.(genv_nextvar)
+ _ _ _ _ _.
+Next Obligation.
+ destruct ge; simpl; omega.
+Qed.
+Next Obligation.
+ destruct ge; auto.
+Qed.
+Next Obligation.
+ destruct ge; simpl in *.
+ rewrite PTree.gsspec in H. destruct (peq id i). inv H. unfold block; omega.
+ exploit genv_symb_range0; eauto. unfold block; omega.
+Qed.
+Next Obligation.
+ destruct ge; simpl in *. rewrite ZMap.gsspec in H.
+ destruct (ZIndexed.eq b genv_nextfun0). subst; omega.
+ exploit genv_funs_range0; eauto. omega.
+Qed.
+Next Obligation.
+ destruct ge; eauto.
+Qed.
+
+Program Definition add_variable (ge: t) (idv: ident * list init_data * V) : t :=
+ @mkgenv
+ (PTree.set idv#1#1 ge.(genv_nextvar) ge.(genv_symb))
+ ge.(genv_funs)
+ (ZMap.set ge.(genv_nextvar) (Some idv#2) ge.(genv_vars))
+ ge.(genv_nextfun)
+ (ge.(genv_nextvar) + 1)
+ _ _ _ _ _.
+Next Obligation.
+ destruct ge; auto.
+Qed.
+Next Obligation.
+ destruct ge; simpl; omega.
+Qed.
+Next Obligation.
+ destruct ge; simpl in *.
+ rewrite PTree.gsspec in H. destruct (peq id i). inv H. unfold block; omega.
+ exploit genv_symb_range0; eauto. unfold block; omega.
+Qed.
+Next Obligation.
+ destruct ge; eauto.
+Qed.
+Next Obligation.
+ destruct ge; simpl in *. rewrite ZMap.gsspec in H.
+ destruct (ZIndexed.eq b genv_nextvar0). subst; omega.
+ exploit genv_vars_range0; eauto. omega.
+Qed.
+
+Program Definition empty_genv : t :=
+ @mkgenv (PTree.empty block) (ZMap.init None) (ZMap.init None) (-1) 1 _ _ _ _ _.
+Next Obligation.
+ omega.
+Qed.
+Next Obligation.
+ omega.
+Qed.
+Next Obligation.
+ rewrite PTree.gempty in H. discriminate.
+Qed.
+Next Obligation.
+ rewrite ZMap.gi in H. discriminate.
+Qed.
+Next Obligation.
+ rewrite ZMap.gi in H. discriminate.
+Qed.
+
+Definition add_functions (ge: t) (fl: list (ident * F)) : t :=
+ List.fold_left add_function fl ge.
+
+Definition add_variables (ge: t) (vl: list (ident * list init_data * V)) : t :=
+ List.fold_left add_variable vl ge.
+
+Definition globalenv (p: program F V) :=
+ add_variables (add_functions empty_genv p.(prog_funct)) p.(prog_vars).
-Lemma find_funct_inv:
- forall (ge: t) (v: val) (f: F),
+(** ** Properties of the operations over global environments *)
+
+Theorem find_funct_inv:
+ forall ge v f,
find_funct ge v = Some f -> exists b, v = Vptr b Int.zero.
Proof.
- intros until f. unfold find_funct. destruct v; try (intros; discriminate).
- generalize (Int.eq_spec i Int.zero). case (Int.eq i Int.zero); intros.
- exists b. congruence.
- discriminate.
-Qed.
-
-Lemma find_funct_find_funct_ptr:
- forall (ge: t) (b: block),
- find_funct ge (Vptr b Int.zero) = find_funct_ptr ge b.
-Proof.
- intros. simpl.
- generalize (Int.eq_spec Int.zero Int.zero).
- case (Int.eq Int.zero Int.zero); intros.
- auto. tauto.
-Qed.
-
-(* Construct environment and initial memory store *)
-
-Definition empty : genv :=
- mkgenv (ZMap.init None) (-1) (PTree.empty block).
-
-Definition add_functs (init: genv) (fns: list (ident * F)) : genv :=
- List.fold_right add_funct init fns.
-
-Definition add_globals
- (init: genv * mem) (vars: list (ident * list init_data * V))
- : genv * mem :=
- List.fold_right
- (fun (id_init: ident * list init_data * V) (g_st: genv * mem) =>
- match id_init, g_st with
- | ((id, init), info), (g, st) =>
- let (st', b) := Mem.alloc_init_data st init in
- (add_symbol id b g, st')
- end)
- init vars.
-
-Definition globalenv_initmem (p: program F V) : (genv * mem) :=
- add_globals
- (add_functs empty p.(prog_funct), Mem.empty)
- p.(prog_vars).
-
-Definition globalenv (p: program F V) : genv :=
- fst (globalenv_initmem p).
-Definition init_mem (p: program F V) : mem :=
- snd (globalenv_initmem p).
-
-Lemma functions_globalenv:
- forall (p: program F V),
- functions (globalenv p) = functions (add_functs empty p.(prog_funct)).
-Proof.
- assert (forall init vars,
- functions (fst (add_globals init vars)) = functions (fst init)).
- induction vars; simpl.
- reflexivity.
- destruct a as [[id1 init1] info1]. destruct (add_globals init vars).
- simpl. exact IHvars.
-
- unfold add_globals; simpl.
- intros. unfold globalenv; unfold globalenv_initmem.
- rewrite H. reflexivity.
-Qed.
-
-Lemma initmem_nullptr:
- forall (p: program F V),
- let m := init_mem p in
- valid_block m nullptr /\
- m.(blocks) nullptr = mkblock 0 0 (fun y => Undef).
-Proof.
- pose (P := fun m => valid_block m nullptr /\
- m.(blocks) nullptr = mkblock 0 0 (fun y => Undef)).
- assert (forall init, P (snd init) -> forall vars, P (snd (add_globals init vars))).
- induction vars; simpl; intros.
- auto.
- destruct a as [[id1 in1] inf1].
- destruct (add_globals init vars) as [g st].
- simpl in *. destruct IHvars. split.
- red; simpl. red in H0. omega.
- simpl. rewrite update_o. auto. unfold block. red in H0. omega.
-
- intro. unfold init_mem, globalenv_initmem. apply H.
- red; simpl. split. compute. auto. reflexivity.
-Qed.
+ intros until f; unfold find_funct.
+ destruct v; try congruence.
+ destruct (Int.eq_dec i Int.zero); try congruence.
+ intros. exists b; congruence.
+Qed.
-Lemma initmem_inject_neutral:
- forall (p: program F V),
- mem_inject_neutral (init_mem p).
-Proof.
- assert (forall g0 vars g1 m,
- add_globals (g0, Mem.empty) vars = (g1, m) ->
- mem_inject_neutral m).
- Opaque alloc_init_data.
- induction vars; simpl.
- intros. inv H. red; intros. destruct (load_inv _ _ _ _ _ H).
- simpl in H1. rewrite Mem.getN_init in H1.
- replace v with Vundef. auto. destruct chunk; simpl in H1; auto.
- destruct a as [[id1 init1] info1].
- caseEq (add_globals (g0, Mem.empty) vars). intros g1 m1 EQ.
- caseEq (alloc_init_data m1 init1). intros m2 b ALLOC.
- intros. inv H.
- eapply Mem.alloc_init_data_neutral; eauto.
- intros. caseEq (globalenv_initmem p). intros g m EQ.
- unfold init_mem; rewrite EQ; simpl.
- unfold globalenv_initmem in EQ. eauto.
-Qed.
-
-Remark nextfunction_add_functs_neg:
- forall fns, nextfunction (add_functs empty fns) < 0.
-Proof.
- induction fns; simpl; intros. omega. unfold Zpred. omega.
+Theorem find_funct_find_funct_ptr:
+ forall ge b,
+ find_funct ge (Vptr b Int.zero) = find_funct_ptr ge b.
+Proof.
+ intros; simpl. apply dec_eq_true.
Qed.
-Theorem find_funct_ptr_negative:
- forall (p: program F V) (b: block) (f: F),
- find_funct_ptr (globalenv p) b = Some f -> b < 0.
+Theorem find_symbol_exists:
+ forall p id init v,
+ In (id, init, v) (prog_vars p) ->
+ exists b, find_symbol (globalenv p) id = Some b.
Proof.
- intros until f.
- assert (forall fns, ZMap.get b (functions (add_functs empty fns)) = Some f -> b < 0).
- induction fns; simpl.
- rewrite ZMap.gi. congruence.
- rewrite ZMap.gsspec. case (ZIndexed.eq b (nextfunction (add_functs empty fns))); intro.
- intro. rewrite e. apply nextfunction_add_functs_neg.
- auto.
- unfold find_funct_ptr. rewrite functions_globalenv.
- intros. eauto.
-Qed.
-
-Remark find_symbol_add_functs_negative:
- forall (fns: list (ident * F)) s b,
- (symbols (add_functs empty fns)) ! s = Some b -> b < 0.
-Proof.
- induction fns; simpl; intros until b.
- rewrite PTree.gempty. congruence.
- rewrite PTree.gsspec. destruct a; simpl. case (peq s i); intro.
- intro EQ; inversion EQ. apply nextfunction_add_functs_neg.
+ intros until v.
+ assert (forall vl ge,
+ (exists b, find_symbol ge id = Some b) ->
+ exists b, find_symbol (add_variables ge vl) id = Some b).
+ unfold find_symbol; induction vl; simpl; intros. auto. apply IHvl.
+ simpl. rewrite PTree.gsspec. fold ident. destruct (peq id a#1#1).
+ exists (genv_nextvar ge); auto. auto.
+
+ assert (forall vl ge, In (id, init, v) vl ->
+ exists b, find_symbol (add_variables ge vl) id = Some b).
+ unfold find_symbol; induction vl; simpl; intros. contradiction.
+ destruct H0. apply H. subst; unfold find_symbol; simpl.
+ rewrite PTree.gss. exists (genv_nextvar ge); auto.
eauto.
+
+ intros. unfold globalenv; eauto.
Qed.
-Remark find_symbol_add_symbols_not_fresh:
- forall fns vars g m s b,
- add_globals (add_functs empty fns, Mem.empty) vars = (g, m) ->
- (symbols g)!s = Some b ->
- b < nextblock m.
+Remark add_functions_same_symb:
+ forall id fl ge,
+ ~In id (map (@fst ident F) fl) ->
+ find_symbol (add_functions ge fl) id = find_symbol ge id.
Proof.
- induction vars; simpl; intros until b.
- intros. inversion H. subst g m. simpl.
- generalize (find_symbol_add_functs_negative fns s H0). omega.
- Transparent alloc_init_data.
- destruct a as [[id1 init1] info1].
- caseEq (add_globals (add_functs empty fns, Mem.empty) vars).
- intros g1 m1 ADG EQ. inversion EQ; subst g m; clear EQ.
- unfold add_symbol; simpl. rewrite PTree.gsspec. case (peq s id1); intro.
- intro EQ; inversion EQ. omega.
- intro. generalize (IHvars _ _ _ _ ADG H). omega.
+ induction fl; simpl; intros. auto.
+ rewrite IHfl. unfold find_symbol; simpl. apply PTree.gso. intuition. intuition.
Qed.
-Theorem find_symbol_not_fresh:
- forall (p: program F V) (id: ident) (b: block),
- find_symbol (globalenv p) id = Some b -> b < nextblock (init_mem p).
+Remark add_functions_same_address:
+ forall b fl ge,
+ b > ge.(genv_nextfun) ->
+ find_funct_ptr (add_functions ge fl) b = find_funct_ptr ge b.
Proof.
- intros until b. unfold find_symbol, globalenv, init_mem, globalenv_initmem; simpl.
- caseEq (add_globals (add_functs empty (prog_funct p), Mem.empty)
- (prog_vars p)); intros g m EQ.
- simpl; intros. eapply find_symbol_add_symbols_not_fresh; eauto.
+ induction fl; simpl; intros. auto.
+ rewrite IHfl. unfold find_funct_ptr; simpl. apply ZMap.gso.
+ red; intros; subst b; omegaContradiction.
+ simpl. omega.
Qed.
-Lemma find_symbol_exists:
- forall (p: program F V)
- (id: ident) (init: list init_data) (v: V),
- In (id, init, v) (prog_vars p) ->
- exists b, find_symbol (globalenv p) id = Some b.
+Remark add_variables_same_symb:
+ forall id vl ge,
+ ~In id (map (fun idv => idv#1#1) vl) ->
+ find_symbol (add_variables ge vl) id = find_symbol ge id.
Proof.
- intros until v.
- assert (forall initm vl, In (id, init, v) vl ->
- exists b, PTree.get id (symbols (fst (add_globals initm vl))) = Some b).
- induction vl; simpl; intros.
- elim H.
- destruct a as [[id0 init0] v0].
- caseEq (add_globals initm vl). intros g1 m1 EQ. simpl.
- rewrite PTree.gsspec. destruct (peq id id0). econstructor; eauto.
- elim H; intro. congruence. generalize (IHvl H0). rewrite EQ. auto.
- intros. unfold globalenv, find_symbol, globalenv_initmem. auto.
-Qed.
-
-Remark find_symbol_above_nextfunction:
- forall (id: ident) (b: block) (fns: list (ident * F)),
- let g := add_functs empty fns in
- PTree.get id g.(symbols) = Some b ->
- b > g.(nextfunction).
-Proof.
- induction fns; simpl.
- rewrite PTree.gempty. congruence.
- rewrite PTree.gsspec. case (peq id (fst a)); intro.
- intro EQ. inversion EQ. unfold Zpred. omega.
- intros. generalize (IHfns H). unfold Zpred; omega.
-Qed.
-
-Remark find_symbol_add_globals:
- forall (id: ident) (ge_m: t * mem) (vars: list (ident * list init_data * V)),
- ~In id (map (fun x: ident * list init_data * V => fst(fst x)) vars) ->
- find_symbol (fst (add_globals ge_m vars)) id =
- find_symbol (fst ge_m) id.
-Proof.
- unfold find_symbol; induction vars; simpl; intros.
- auto.
- destruct a as [[id0 init0] var0]. simpl in *.
- caseEq (add_globals ge_m vars); intros ge' m' EQ.
- simpl. rewrite PTree.gso. rewrite EQ in IHvars. simpl in IHvars.
- apply IHvars. tauto. intuition congruence.
+ induction vl; simpl; intros. auto.
+ rewrite IHvl. unfold find_symbol; simpl. apply PTree.gso. intuition. intuition.
+Qed.
+
+Remark add_variables_same_address:
+ forall b vl ge,
+ b < ge.(genv_nextvar) ->
+ find_var_info (add_variables ge vl) b = find_var_info ge b.
+Proof.
+ induction vl; simpl; intros. auto.
+ rewrite IHvl. unfold find_var_info; simpl. apply ZMap.gso.
+ red; intros; subst b; omegaContradiction.
+ simpl. omega.
+Qed.
+
+Remark add_variables_same_funs:
+ forall b vl ge, find_funct_ptr (add_variables ge vl) b = find_funct_ptr ge b.
+Proof.
+ induction vl; simpl; intros. auto. rewrite IHvl. auto.
+Qed.
+
+Remark add_functions_nextvar:
+ forall fl ge, genv_nextvar (add_functions ge fl) = genv_nextvar ge.
+Proof.
+ induction fl; simpl; intros. auto. rewrite IHfl. auto.
+Qed.
+
+Remark add_variables_nextvar:
+ forall vl ge, genv_nextvar (add_variables ge vl) = genv_nextvar ge + Z_of_nat(List.length vl).
+Proof.
+ induction vl; intros.
+ simpl. unfold block; omega.
+ simpl length; rewrite inj_S; simpl. rewrite IHvl. simpl. unfold block; omega.
Qed.
-Lemma find_funct_ptr_exists:
- forall (p: program F V) (id: ident) (f: F),
+Theorem find_funct_ptr_exists:
+ forall p id f,
list_norepet (prog_funct_names p) ->
list_disjoint (prog_funct_names p) (prog_var_names p) ->
In (id, f) (prog_funct p) ->
@@ -569,384 +298,784 @@ Lemma find_funct_ptr_exists:
/\ find_funct_ptr (globalenv p) b = Some f.
Proof.
intros until f.
- assert (forall (fns: list (ident * F)),
- list_norepet (map (@fst ident F) fns) ->
- In (id, f) fns ->
- exists b, find_symbol (add_functs empty fns) id = Some b
- /\ find_funct_ptr (add_functs empty fns) b = Some f).
- unfold find_symbol, find_funct_ptr. induction fns; intros.
- elim H0.
- destruct a as [id0 f0]; simpl in *. inv H.
- unfold add_funct; simpl.
- rewrite PTree.gsspec. destruct (peq id id0).
- subst id0. econstructor; split. eauto.
- replace f0 with f. apply ZMap.gss.
- elim H0; intro. congruence. elim H3.
- change id with (@fst ident F (id, f)). apply List.in_map. auto.
- exploit IHfns; eauto. elim H0; intro. congruence. auto.
- intros [b [X Y]]. exists b; split. auto. rewrite ZMap.gso. auto.
- generalize (find_symbol_above_nextfunction _ _ X).
- unfold block; unfold ZIndexed.t; intro; omega.
-
- intros. exploit H; eauto. intros [b [X Y]].
- exists b; split.
- unfold globalenv, globalenv_initmem. rewrite find_symbol_add_globals.
- assumption. apply list_disjoint_notin with (prog_funct_names p). assumption.
- unfold prog_funct_names. change id with (fst (id, f)).
- apply List.in_map; auto.
- unfold find_funct_ptr. rewrite functions_globalenv.
- assumption.
-Qed.
-
-Lemma find_funct_ptr_inversion:
- forall (P: F -> Prop) (p: program F V) (b: block) (f: F),
- find_funct_ptr (globalenv p) b = Some f ->
- exists id, In (id, f) (prog_funct p).
-Proof.
- intros until f.
- assert (forall fns: list (ident * F),
- find_funct_ptr (add_functs empty fns) b = Some f ->
- exists id, In (id, f) fns).
- unfold find_funct_ptr. induction fns; simpl.
- rewrite ZMap.gi. congruence.
- destruct a as [id0 f0]; simpl.
- rewrite ZMap.gsspec. destruct (ZIndexed.eq b (nextfunction (add_functs empty fns))).
- intro. inv H. exists id0; auto.
- intro. exploit IHfns; eauto. intros [id A]. exists id; auto.
- unfold find_funct_ptr; rewrite functions_globalenv. intros; apply H; auto.
-Qed.
-
-Lemma find_funct_ptr_prop:
- forall (P: F -> Prop) (p: program F V) (b: block) (f: F),
+
+ assert (forall fl ge, In (id, f) fl -> list_norepet (map (@fst ident F) fl) ->
+ exists b, find_symbol (add_functions ge fl) id = Some b
+ /\ find_funct_ptr (add_functions ge fl) b = Some f).
+ induction fl; simpl; intros. contradiction. inv H0.
+ destruct H. subst a. exists (genv_nextfun ge); split.
+ rewrite add_functions_same_symb; auto. unfold find_symbol; simpl. apply PTree.gss.
+ rewrite add_functions_same_address. unfold find_funct_ptr; simpl. apply ZMap.gss.
+ simpl; omega.
+ apply IHfl; auto.
+
+ intros. exploit (H p.(prog_funct) empty_genv); eauto. intros [b [A B]].
+ unfold globalenv; exists b; split.
+ rewrite add_variables_same_symb. auto. eapply list_disjoint_notin; eauto.
+ unfold prog_funct_names. change id with (fst (id, f)). apply in_map; auto.
+ rewrite add_variables_same_funs. auto.
+Qed.
+
+Theorem find_funct_ptr_prop:
+ forall (P: F -> Prop) p b f,
(forall id f, In (id, f) (prog_funct p) -> P f) ->
find_funct_ptr (globalenv p) b = Some f ->
P f.
Proof.
- intros. exploit find_funct_ptr_inversion; eauto. intros [id A]. eauto.
+ intros until f. intros PROP.
+ assert (forall fl ge,
+ List.incl fl (prog_funct p) ->
+ match find_funct_ptr ge b with None => True | Some f => P f end ->
+ match find_funct_ptr (add_functions ge fl) b with None => True | Some f => P f end).
+ induction fl; simpl; intros. auto.
+ apply IHfl. eauto with coqlib. unfold find_funct_ptr; simpl.
+ destruct a as [id' f']; simpl.
+ rewrite ZMap.gsspec. destruct (ZIndexed.eq b (genv_nextfun ge)).
+ apply PROP with id'. apply H. auto with coqlib.
+ assumption.
+
+ unfold globalenv. rewrite add_variables_same_funs. intro.
+ exploit (H p.(prog_funct) empty_genv). auto with coqlib.
+ unfold find_funct_ptr; simpl. rewrite ZMap.gi. auto.
+ rewrite H0. auto.
Qed.
-Lemma find_funct_inversion:
- forall (P: F -> Prop) (p: program F V) (v: val) (f: F),
+Theorem find_funct_prop:
+ forall (P: F -> Prop) p v f,
+ (forall id f, In (id, f) (prog_funct p) -> P f) ->
find_funct (globalenv p) v = Some f ->
+ P f.
+Proof.
+ intros. exploit find_funct_inv; eauto. intros [b EQ]. subst v.
+ rewrite find_funct_find_funct_ptr in H0.
+ eapply find_funct_ptr_prop; eauto.
+Qed.
+
+Theorem find_funct_ptr_inversion:
+ forall p b f,
+ find_funct_ptr (globalenv p) b = Some f ->
exists id, In (id, f) (prog_funct p).
Proof.
- intros. exploit find_funct_inv; eauto. intros [b EQ]. rewrite EQ in H.
- rewrite find_funct_find_funct_ptr in H.
- eapply find_funct_ptr_inversion; eauto.
+ intros. pattern f. apply find_funct_ptr_prop with p b; auto.
+ intros. exists id; auto.
Qed.
-Lemma find_funct_prop:
- forall (P: F -> Prop) (p: program F V) (v: val) (f: F),
- (forall id f, In (id, f) (prog_funct p) -> P f) ->
+Theorem find_funct_inversion:
+ forall p v f,
find_funct (globalenv p) v = Some f ->
- P f.
+ exists id, In (id, f) (prog_funct p).
+Proof.
+ intros. pattern f. apply find_funct_prop with p v; auto.
+ intros. exists id; auto.
+Qed.
+
+Theorem find_funct_ptr_negative:
+ forall p b f,
+ find_funct_ptr (globalenv p) b = Some f -> b < 0.
Proof.
- intros. exploit find_funct_inversion; eauto. intros [id A]. eauto.
+ unfold find_funct_ptr. intros. destruct (globalenv p). simpl in H.
+ exploit genv_funs_range0; eauto. omega.
Qed.
-Lemma find_funct_ptr_symbol_inversion:
- forall (p: program F V) (id: ident) (b: block) (f: F),
+Theorem find_var_info_positive:
+ forall p b v,
+ find_var_info (globalenv p) b = Some v -> b > 0.
+Proof.
+ unfold find_var_info. intros. destruct (globalenv p). simpl in H.
+ exploit genv_vars_range0; eauto. omega.
+Qed.
+
+Remark add_variables_symb_neg:
+ forall id b vl ge,
+ find_symbol (add_variables ge vl) id = Some b -> b < 0 ->
+ find_symbol ge id = Some b.
+Proof.
+ induction vl; simpl; intros. auto.
+ exploit IHvl; eauto. unfold find_symbol; simpl. rewrite PTree.gsspec.
+ fold ident. destruct (peq id (a#1#1)); auto. intros. inv H1.
+ generalize (genv_nextvar_pos ge). intros. omegaContradiction.
+Qed.
+
+Theorem find_funct_ptr_symbol_inversion:
+ forall p id b f,
find_symbol (globalenv p) id = Some b ->
find_funct_ptr (globalenv p) b = Some f ->
In (id, f) p.(prog_funct).
Proof.
intros until f.
- assert (forall fns,
- let g := add_functs empty fns in
- PTree.get id g.(symbols) = Some b ->
- ZMap.get b g.(functions) = Some f ->
- In (id, f) fns).
- induction fns; simpl.
- rewrite ZMap.gi. congruence.
- set (g := add_functs empty fns).
- rewrite PTree.gsspec. rewrite ZMap.gsspec.
- case (peq id (fst a)); intro.
- intro EQ. inversion EQ. unfold ZIndexed.eq. rewrite zeq_true.
- intro EQ2. left. destruct a. simpl in *. congruence.
- intro. unfold ZIndexed.eq. rewrite zeq_false. intro. eauto.
- generalize (find_symbol_above_nextfunction _ _ H). fold g. unfold block. omega.
- assert (forall g0 m0, b < 0 ->
- forall vars g m,
- add_globals (g0, m0) vars = (g, m) ->
- PTree.get id g.(symbols) = Some b ->
- PTree.get id g0.(symbols) = Some b).
- induction vars; simpl.
- intros. inv H1. auto.
- destruct a as [[id1 init1] info1]. caseEq (add_globals (g0, m0) vars).
- intros g1 m1 EQ g m EQ1. injection EQ1; simpl; clear EQ1.
- unfold add_symbol; intros A B. rewrite <- B. simpl.
- rewrite PTree.gsspec. case (peq id id1); intros.
- assert (b > 0). inv H1. apply nextblock_pos.
- omegaContradiction.
- eauto.
- intros.
- generalize (find_funct_ptr_negative _ _ H2). intro.
- pose (g := add_functs empty (prog_funct p)).
- apply H.
- apply H0 with Mem.empty (prog_vars p) (globalenv p) (init_mem p).
- auto. unfold globalenv, init_mem. rewrite <- surjective_pairing.
- reflexivity. assumption. rewrite <- functions_globalenv. assumption.
+
+ assert (forall fl ge,
+ find_symbol (add_functions ge fl) id = Some b ->
+ find_funct_ptr (add_functions ge fl) b = Some f ->
+ In (id, f) fl \/ (find_symbol ge id = Some b /\ find_funct_ptr ge b = Some f)).
+ induction fl; simpl; intros.
+ auto.
+ exploit IHfl; eauto. intros [A | [A B]]. auto.
+ destruct a as [id' f'].
+ unfold find_symbol in A; simpl in A.
+ unfold find_funct_ptr in B; simpl in B.
+ rewrite PTree.gsspec in A. destruct (peq id id'). inv A.
+ rewrite ZMap.gss in B. inv B. auto.
+ rewrite ZMap.gso in B. right; auto.
+ exploit genv_symb_range; eauto. unfold block, ZIndexed.t; omega.
+
+ intros. assert (b < 0) by (eapply find_funct_ptr_negative; eauto).
+ unfold globalenv in *. rewrite add_variables_same_funs in H1.
+ exploit (H (prog_funct p) empty_genv).
+ eapply add_variables_symb_neg; eauto. auto.
+ intuition. unfold find_symbol in H3; simpl in H3. rewrite PTree.gempty in H3. discriminate.
Qed.
Theorem find_symbol_not_nullptr:
- forall (p: program F V) (id: ident) (b: block),
- find_symbol (globalenv p) id = Some b -> b <> nullptr.
-Proof.
- intros until b.
- assert (forall fns,
- find_symbol (add_functs empty fns) id = Some b ->
- b <> nullptr).
- unfold find_symbol; induction fns; simpl.
- rewrite PTree.gempty. congruence.
- destruct a as [id1 f1]. simpl. rewrite PTree.gsspec.
- destruct (peq id id1); intros.
- inversion H. generalize (nextfunction_add_functs_neg fns).
- unfold block, nullptr; omega.
- auto.
- set (g0 := add_functs empty p.(prog_funct)).
- assert (forall vars g m,
- add_globals (g0, Mem.empty) vars = (g, m) ->
- find_symbol g id = Some b ->
- b <> nullptr).
- induction vars; simpl; intros until m.
- intros. inversion H0. subst g. apply H with (prog_funct p). auto.
- destruct a as [[id1 init1] info1].
- caseEq (add_globals (g0, Mem.empty) vars); intros g1 m1 EQ1 EQ2.
- inv EQ2. unfold find_symbol, add_symbol; simpl. rewrite PTree.gsspec.
- destruct (peq id id1); intros.
- inv H0. generalize (nextblock_pos m1). unfold nullptr, block; omega.
- eauto.
- intros. eapply H0 with (vars := prog_vars p). apply surjective_pairing. auto.
-Qed.
+ forall p id b,
+ find_symbol (globalenv p) id = Some b -> b <> Mem.nullptr.
+Proof.
+ intros until b. unfold find_symbol. destruct (globalenv p); simpl.
+ intros. exploit genv_symb_range0; eauto. intuition.
+Qed.
Theorem global_addresses_distinct:
- forall (p: program F V) id1 id2 b1 b2,
+ forall p id1 id2 b1 b2,
id1<>id2 ->
find_symbol (globalenv p) id1 = Some b1 ->
find_symbol (globalenv p) id2 = Some b2 ->
b1<>b2.
Proof.
+ intros until b2; intro DIFF.
+
+ set (P := fun ge => find_symbol ge id1 = Some b1 -> find_symbol ge id2 = Some b2 -> b1 <> b2).
+
+ assert (forall fl ge, P ge -> P (add_functions ge fl)).
+ induction fl; intros; simpl. auto.
+ apply IHfl. red. unfold find_symbol; simpl.
+ repeat rewrite PTree.gsspec.
+ fold ident. destruct (peq id1 a#1); destruct (peq id2 a#1).
+ congruence.
+ intros. inversion H0. exploit genv_symb_range; eauto. unfold block; omega.
+ intros. inversion H1. exploit genv_symb_range; eauto. unfold block; omega.
+ auto.
+
+ assert (forall vl ge, P ge -> P (add_variables ge vl)).
+ induction vl; intros; simpl. auto.
+ apply IHvl. red. unfold find_symbol; simpl.
+ repeat rewrite PTree.gsspec.
+ fold ident. destruct (peq id1 a#1#1); destruct (peq id2 a#1#1).
+ congruence.
+ intros. inversion H1. exploit genv_symb_range; eauto. unfold block; omega.
+ intros. inversion H2. exploit genv_symb_range; eauto. unfold block; omega.
+ auto.
+
+ change (P (globalenv p)). unfold globalenv. apply H0. apply H.
+ red; unfold find_symbol; simpl; intros. rewrite PTree.gempty in H1. congruence.
+Qed.
+
+(** * Construction of the initial memory state *)
+
+Section INITMEM.
+
+Variable ge: t.
+
+Definition init_data_size (i: init_data) : Z :=
+ match i with
+ | Init_int8 _ => 1
+ | Init_int16 _ => 2
+ | Init_int32 _ => 4
+ | Init_float32 _ => 4
+ | Init_float64 _ => 8
+ | Init_addrof _ _ => 4
+ | Init_space n => Zmax n 0
+ end.
+
+Lemma init_data_size_pos:
+ forall i, init_data_size i >= 0.
+Proof.
+ destruct i; simpl; try omega. generalize (Zle_max_r z 0). omega.
+Qed.
+
+Definition store_init_data (m: mem) (b: block) (p: Z) (id: init_data) : option mem :=
+ match id with
+ | Init_int8 n => Mem.store Mint8unsigned m b p (Vint n)
+ | Init_int16 n => Mem.store Mint16unsigned m b p (Vint n)
+ | Init_int32 n => Mem.store Mint32 m b p (Vint n)
+ | Init_float32 n => Mem.store Mfloat32 m b p (Vfloat n)
+ | Init_float64 n => Mem.store Mfloat64 m b p (Vfloat n)
+ | Init_addrof symb ofs =>
+ match find_symbol ge symb with
+ | None => None
+ | Some b' => Mem.store Mint32 m b p (Vptr b' ofs)
+ end
+ | Init_space n => Some m
+ end.
+
+Fixpoint store_init_data_list (m: mem) (b: block) (p: Z) (idl: list init_data)
+ {struct idl}: option mem :=
+ match idl with
+ | nil => Some m
+ | id :: idl' =>
+ match store_init_data m b p id with
+ | None => None
+ | Some m' => store_init_data_list m' b (p + init_data_size id) idl'
+ end
+ end.
+
+Fixpoint init_data_list_size (il: list init_data) {struct il} : Z :=
+ match il with
+ | nil => 0
+ | i :: il' => init_data_size i + init_data_list_size il'
+ end.
+
+Definition alloc_variable (m: mem) (idv: ident * list init_data * V) : option mem :=
+ let (m', b) := Mem.alloc m 0 (init_data_list_size idv#1#2) in
+ store_init_data_list m' b 0 idv#1#2.
+
+Fixpoint alloc_variables (m: mem) (vl: list (ident * list init_data * V))
+ {struct vl} : option mem :=
+ match vl with
+ | nil => Some m
+ | v :: vl' =>
+ match alloc_variable m v with
+ | None => None
+ | Some m' => alloc_variables m' vl'
+ end
+ end.
+
+Remark store_init_data_list_nextblock:
+ forall idl b m p m',
+ store_init_data_list m b p idl = Some m' ->
+ Mem.nextblock m' = Mem.nextblock m.
+Proof.
+ induction idl; simpl; intros until m'.
+ intros. congruence.
+ caseEq (store_init_data m b p a); try congruence. intros.
+ transitivity (Mem.nextblock m0). eauto.
+ destruct a; simpl in H; try (eapply Mem.nextblock_store; eauto; fail).
+ congruence.
+ destruct (find_symbol ge i); try congruence. eapply Mem.nextblock_store; eauto.
+Qed.
+
+Remark alloc_variables_nextblock:
+ forall vl m m',
+ alloc_variables m vl = Some m' ->
+ Mem.nextblock m' = Mem.nextblock m + Z_of_nat(List.length vl).
+Proof.
+ induction vl.
+ simpl; intros. inv H; unfold block; omega.
+ simpl length; rewrite inj_S; simpl. intros m m'.
+ unfold alloc_variable.
+ caseEq (Mem.alloc m 0 (init_data_list_size (a#1)#2)). intros m1 b ALLOC.
+ caseEq (store_init_data_list m1 b 0 a#1#2); try congruence. intros m2 STORE REC.
+ rewrite (IHvl _ _ REC).
+ rewrite (store_init_data_list_nextblock _ _ _ _ STORE).
+ rewrite (Mem.nextblock_alloc _ _ _ _ _ ALLOC).
+ unfold block in *; omega.
+Qed.
+
+Remark store_init_data_list_perm:
+ forall prm b' q idl b m p m',
+ store_init_data_list m b p idl = Some m' ->
+ Mem.perm m b' q prm -> Mem.perm m' b' q prm.
+Proof.
+ induction idl; simpl; intros until m'.
+ intros. congruence.
+ caseEq (store_init_data m b p a); try congruence. intros.
+ eapply IHidl; eauto.
+ destruct a; simpl in H; eauto with mem.
+ congruence.
+ destruct (find_symbol ge i); try congruence. eauto with mem.
+Qed.
+
+Remark alloc_variables_perm:
+ forall prm b' q vl m m',
+ alloc_variables m vl = Some m' ->
+ Mem.perm m b' q prm -> Mem.perm m' b' q prm.
+Proof.
+ induction vl.
+ simpl; intros. congruence.
+ intros until m'. simpl. unfold alloc_variable.
+ caseEq (Mem.alloc m 0 (init_data_list_size (a#1)#2)). intros m1 b ALLOC.
+ caseEq (store_init_data_list m1 b 0 a#1#2); try congruence. intros m2 STORE REC PERM.
+ eapply IHvl; eauto.
+ eapply store_init_data_list_perm; eauto.
+ eauto with mem.
+Qed.
+
+Remark store_init_data_list_outside:
+ forall b il m p m',
+ store_init_data_list m b p il = Some m' ->
+ forall chunk b' q,
+ b' <> b \/ q + size_chunk chunk <= p ->
+ Mem.load chunk m' b' q = Mem.load chunk m b' q.
+Proof.
+ induction il; simpl.
+ intros; congruence.
+ intros until m'. caseEq (store_init_data m b p a); try congruence.
+ intros m1 A B chunk b' q C. transitivity (Mem.load chunk m1 b' q).
+ eapply IHil; eauto. generalize (init_data_size_pos a). intuition omega.
+ destruct a; simpl in A;
+ try (eapply Mem.load_store_other; eauto; intuition; fail).
+ congruence.
+ destruct (find_symbol ge i); try congruence.
+ eapply Mem.load_store_other; eauto; intuition.
+Qed.
+
+(*
+Remark alloc_variables_nextblock:
+ forall vl g m m',
+ alloc_variables m vl = Some m' ->
+ Mem.nextblock m = genv_nextvar g ->
+ Mem.nextblock m' = genv_nextvar (add_variables g vl).
+Proof.
+ induction vl; simpl; intros until m'.
+ intros. congruence.
+ unfold alloc_variable.
+ caseEq (Mem.alloc m 0 (init_data_list_size (a#1)#2)). intros m1 b ALLOC.
+ caseEq (store_init_data_list m1 b 0 a#1#2); try congruence. intros m2 STORE REC EQ.
+ eapply IHvl; eauto.
+ rewrite (store_init_data_list_nextblock _ _ _ _ STORE).
+ rewrite (Mem.nextblock_alloc _ _ _ _ _ ALLOC).
+ simpl. unfold block in *; omega.
+Qed.
+*)
+Fixpoint load_store_init_data (m: mem) (b: block) (p: Z) (il: list init_data) {struct il} : Prop :=
+ match il with
+ | nil => True
+ | Init_int8 n :: il' =>
+ Mem.load Mint8unsigned m b p = Some(Vint(Int.zero_ext 8 n))
+ /\ load_store_init_data m b (p + 1) il'
+ | Init_int16 n :: il' =>
+ Mem.load Mint16unsigned m b p = Some(Vint(Int.zero_ext 16 n))
+ /\ load_store_init_data m b (p + 2) il'
+ | Init_int32 n :: il' =>
+ Mem.load Mint32 m b p = Some(Vint n)
+ /\ load_store_init_data m b (p + 4) il'
+ | Init_float32 n :: il' =>
+ Mem.load Mfloat32 m b p = Some(Vfloat(Float.singleoffloat n))
+ /\ load_store_init_data m b (p + 4) il'
+ | Init_float64 n :: il' =>
+ Mem.load Mfloat64 m b p = Some(Vfloat n)
+ /\ load_store_init_data m b (p + 8) il'
+ | Init_addrof symb ofs :: il' =>
+ (exists b', find_symbol ge symb = Some b' /\ Mem.load Mint32 m b p = Some(Vptr b' ofs))
+ /\ load_store_init_data m b (p + 4) il'
+ | Init_space n :: il' =>
+ load_store_init_data m b (p + Zmax n 0) il'
+ end.
+
+Lemma store_init_data_list_charact:
+ forall b il m p m',
+ store_init_data_list m b p il = Some m' ->
+ load_store_init_data m' b p il.
+Proof.
+ assert (A: forall chunk v m b p m1 il m',
+ Mem.store chunk m b p v = Some m1 ->
+ store_init_data_list m1 b (p + size_chunk chunk) il = Some m' ->
+ Val.has_type v (type_of_chunk chunk) ->
+ Mem.load chunk m' b p = Some(Val.load_result chunk v)).
+ intros. transitivity (Mem.load chunk m1 b p).
+ eapply store_init_data_list_outside; eauto. right. omega.
+ eapply Mem.load_store_same; eauto.
+
+ induction il; simpl.
+ auto.
+ intros until m'. caseEq (store_init_data m b p a); try congruence.
+ intros m1 B C.
+ exploit IHil; eauto. intro D.
+ destruct a; simpl in B; intuition.
+ eapply (A Mint8unsigned (Vint i)); eauto. simpl; auto.
+ eapply (A Mint16unsigned (Vint i)); eauto. simpl; auto.
+ eapply (A Mint32 (Vint i)); eauto. simpl; auto.
+ eapply (A Mfloat32 (Vfloat f)); eauto. simpl; auto.
+ eapply (A Mfloat64 (Vfloat f)); eauto. simpl; auto.
+ destruct (find_symbol ge i); try congruence. exists b0; split; auto.
+ eapply (A Mint32 (Vptr b0 i0)); eauto. simpl; auto.
+Qed.
+
+Remark load_alloc_variables:
+ forall chunk b p vl m m',
+ alloc_variables m vl = Some m' ->
+ Mem.valid_block m b ->
+ Mem.load chunk m' b p = Mem.load chunk m b p.
+Proof.
+ induction vl; simpl; intros until m'.
+ congruence.
+ unfold alloc_variable.
+ caseEq (Mem.alloc m 0 (init_data_list_size a#1#2)); intros m1 b1 ALLOC.
+ caseEq (store_init_data_list m1 b1 0 a#1#2); try congruence. intros m2 STO REC VAL.
+ transitivity (Mem.load chunk m2 b p).
+ apply IHvl; auto. red. rewrite (store_init_data_list_nextblock _ _ _ _ STO).
+ change (Mem.valid_block m1 b). eauto with mem.
+ transitivity (Mem.load chunk m1 b p).
+ eapply store_init_data_list_outside; eauto. left.
+ apply Mem.valid_not_valid_diff with m; eauto with mem.
+ eapply Mem.load_alloc_unchanged; eauto.
+Qed.
+
+Remark load_store_init_data_invariant:
+ forall m m' b,
+ (forall chunk ofs, Mem.load chunk m' b ofs = Mem.load chunk m b ofs) ->
+ forall il p,
+ load_store_init_data m b p il -> load_store_init_data m' b p il.
+Proof.
+ induction il; intro p; simpl.
+ auto.
+ repeat rewrite H. destruct a; intuition.
+Qed.
+
+Lemma alloc_variables_charact:
+ forall id init v vl g m m',
+ genv_nextvar g = Mem.nextblock m ->
+ alloc_variables m vl = Some m' ->
+ list_norepet (map (fun v => v#1#1) vl) ->
+ In (id, init, v) vl ->
+ exists b, find_symbol (add_variables g vl) id = Some b
+ /\ find_var_info (add_variables g vl) b = Some v
+ /\ Mem.range_perm m' b 0 (init_data_list_size init) Writable
+ /\ load_store_init_data m' b 0 init.
+Proof.
+ induction vl; simpl.
+ contradiction.
+ intros until m'; intro NEXT.
+ unfold alloc_variable. destruct a as [[id' init'] v']. simpl.
+ caseEq (Mem.alloc m 0 (init_data_list_size init')); try congruence.
+ intros m1 b ALLOC.
+ caseEq (store_init_data_list m1 b 0 init'); try congruence.
+ intros m2 STORE REC NOREPET IN. inv NOREPET.
+ exploit Mem.alloc_result; eauto. intro BEQ.
+ destruct IN. inv H.
+ exists (Mem.nextblock m); split.
+ rewrite add_variables_same_symb; auto. unfold find_symbol; simpl.
+ rewrite PTree.gss. congruence.
+ split. rewrite add_variables_same_address. unfold find_var_info; simpl.
+ rewrite NEXT. apply ZMap.gss.
+ simpl. rewrite <- NEXT; omega.
+ split. red; intros. eapply alloc_variables_perm; eauto.
+ eapply store_init_data_list_perm; eauto.
+ apply Mem.perm_implies with Freeable; eauto with mem.
+ apply load_store_init_data_invariant with m2.
+ intros. eapply load_alloc_variables; eauto.
+ red. rewrite (store_init_data_list_nextblock _ _ _ _ STORE).
+ change (Mem.valid_block m1 (Mem.nextblock m)). eauto with mem.
+ eapply store_init_data_list_charact; eauto.
+
+ apply IHvl with m2; auto.
+ simpl. rewrite (store_init_data_list_nextblock _ _ _ _ STORE).
+ rewrite (Mem.nextblock_alloc _ _ _ _ _ ALLOC). unfold block in *; omega.
+Qed.
+
+End INITMEM.
+
+Definition init_mem (p: program F V) :=
+ alloc_variables (globalenv p) Mem.empty p.(prog_vars).
+
+Theorem find_symbol_not_fresh:
+ forall p id b m,
+ init_mem p = Some m ->
+ find_symbol (globalenv p) id = Some b -> Mem.valid_block m b.
+Proof.
+ unfold init_mem; intros.
+ exploit alloc_variables_nextblock; eauto. rewrite Mem.nextblock_empty. intro.
+ exploit genv_symb_range; eauto. intros.
+ generalize (add_variables_nextvar (prog_vars p) (add_functions empty_genv (prog_funct p))).
+ rewrite add_functions_nextvar. simpl genv_nextvar. intro.
+ red. rewrite H1. rewrite <- H3. intuition.
+Qed.
+
+Theorem find_var_exists:
+ forall p id init v m,
+ list_norepet (prog_var_names p) ->
+ In (id, init, v) (prog_vars p) ->
+ init_mem p = Some m ->
+ exists b, find_symbol (globalenv p) id = Some b
+ /\ find_var_info (globalenv p) b = Some v
+ /\ Mem.range_perm m b 0 (init_data_list_size init) Writable
+ /\ load_store_init_data (globalenv p) m b 0 init.
+Proof.
+ intros. exploit alloc_variables_charact; eauto.
+ instantiate (1 := Mem.empty). rewrite add_functions_nextvar. rewrite Mem.nextblock_empty; auto.
+ assumption.
+Qed.
+
+(** ** Compatibility with memory injections *)
+
+Section INITMEM_INJ.
+
+Variable ge: t.
+Variable thr: block.
+Hypothesis symb_inject: forall id b, find_symbol ge id = Some b -> b < thr.
+
+Lemma store_init_data_neutral:
+ forall m b p id m',
+ Mem.inject_neutral thr m ->
+ b < thr ->
+ store_init_data ge m b p id = Some m' ->
+ Mem.inject_neutral thr m'.
+Proof.
intros.
- assert (forall fns,
- find_symbol (add_functs empty fns) id1 = Some b1 ->
- find_symbol (add_functs empty fns) id2 = Some b2 ->
- b1 <> b2).
- unfold find_symbol. induction fns; simpl; intros.
- rewrite PTree.gempty in H2. discriminate.
- destruct a as [id f]; simpl in *.
- rewrite PTree.gsspec in H2.
- destruct (peq id1 id). subst id. inv H2.
- rewrite PTree.gso in H3; auto.
- generalize (find_symbol_above_nextfunction _ _ H3). unfold block. omega.
- rewrite PTree.gsspec in H3.
- destruct (peq id2 id). subst id. inv H3.
- generalize (find_symbol_above_nextfunction _ _ H2). unfold block. omega.
- eauto.
- set (ge0 := add_functs empty p.(prog_funct)).
- assert (forall (vars: list (ident * list init_data * V)) ge m,
- add_globals (ge0, Mem.empty) vars = (ge, m) ->
- find_symbol ge id1 = Some b1 ->
- find_symbol ge id2 = Some b2 ->
- b1 <> b2).
- unfold find_symbol. induction vars; simpl.
- intros. inv H3. subst ge. apply H2 with (p.(prog_funct)); auto.
- intros ge m. destruct a as [[id init] info].
- caseEq (add_globals (ge0, Mem.empty) vars). intros ge1 m1 A B. inv B.
- unfold add_symbol. simpl. intros.
- rewrite PTree.gsspec in H3; destruct (peq id1 id). subst id. inv H3.
- rewrite PTree.gso in H4; auto.
- generalize (find_symbol_add_symbols_not_fresh _ _ _ A H4). unfold block; omega.
- rewrite PTree.gsspec in H4; destruct (peq id2 id). subst id. inv H4.
- generalize (find_symbol_add_symbols_not_fresh _ _ _ A H3). unfold block; omega.
+ destruct id; simpl in H1; try (eapply Mem.store_inject_neutral; eauto; fail).
+ inv H1; auto.
+ revert H1. caseEq (find_symbol ge i); try congruence. intros b' FS ST.
+ eapply Mem.store_inject_neutral; eauto.
+ econstructor. unfold Mem.flat_inj. apply zlt_true; eauto.
+ rewrite Int.add_zero. auto.
+Qed.
+
+Lemma store_init_data_list_neutral:
+ forall b idl m p m',
+ Mem.inject_neutral thr m ->
+ b < thr ->
+ store_init_data_list ge m b p idl = Some m' ->
+ Mem.inject_neutral thr m'.
+Proof.
+ induction idl; simpl.
+ intros; congruence.
+ intros until m'; intros INJ FB.
+ caseEq (store_init_data ge m b p a); try congruence. intros.
+ eapply IHidl. eapply store_init_data_neutral; eauto. auto. eauto.
+Qed.
+
+Lemma alloc_variable_neutral:
+ forall id m m',
+ alloc_variable ge m id = Some m' ->
+ Mem.inject_neutral thr m ->
+ Mem.nextblock m < thr ->
+ Mem.inject_neutral thr m'.
+Proof.
+ intros until m'. unfold alloc_variable.
+ caseEq (Mem.alloc m 0 (init_data_list_size (id#1)#2)); intros m1 b; intros.
+ eapply store_init_data_list_neutral with (b := b).
+ eapply Mem.alloc_inject_neutral; eauto.
+ rewrite (Mem.alloc_result _ _ _ _ _ H). auto.
eauto.
- set (ge_m := add_globals (ge0, Mem.empty) p.(prog_vars)).
- apply H3 with (p.(prog_vars)) (fst ge_m) (snd ge_m).
- fold ge_m. apply surjective_pairing. auto. auto.
+Qed.
+
+Lemma alloc_variables_neutral:
+ forall idl m m',
+ alloc_variables ge m idl = Some m' ->
+ Mem.inject_neutral thr m ->
+ Mem.nextblock m' <= thr ->
+ Mem.inject_neutral thr m'.
+Proof.
+ induction idl; simpl.
+ intros. congruence.
+ intros until m'. caseEq (alloc_variable ge m a); try congruence. intros.
+ assert (Mem.nextblock m' = Mem.nextblock m + Z_of_nat(length (a :: idl))).
+ eapply alloc_variables_nextblock with ge. simpl. rewrite H. auto.
+ simpl length in H3. rewrite inj_S in H3.
+ exploit alloc_variable_neutral; eauto. unfold block in *; omega.
+Qed.
+
+End INITMEM_INJ.
+
+Theorem initmem_inject:
+ forall p m,
+ init_mem p = Some m ->
+ Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m.
+Proof.
+ unfold init_mem; intros.
+ apply Mem.neutral_inject.
+ eapply alloc_variables_neutral; eauto.
+ intros. exploit find_symbol_not_fresh; eauto.
+ apply Mem.empty_inject_neutral.
+ omega.
Qed.
End GENV.
-(* Global environments and program transformations. *)
+(** * Commutation with program transformations *)
-Section MATCH_PROGRAM.
+(** ** Commutation with matching between programs. *)
-Variable A B V W: Type.
+Section MATCH_PROGRAMS.
+
+Variables A B V W: Type.
Variable match_fun: A -> B -> Prop.
Variable match_var: V -> W -> Prop.
-Variable p: program A V.
-Variable p': program B W.
-Hypothesis match_prog:
- match_program match_fun match_var p p'.
-
-Lemma add_functs_match:
- forall (fns: list (ident * A)) (tfns: list (ident * B)),
- list_forall2 (match_funct_entry match_fun) fns tfns ->
- let r := add_functs (empty A) fns in
- let tr := add_functs (empty B) tfns in
- nextfunction tr = nextfunction r /\
- symbols tr = symbols r /\
- forall (b: block) (f: A),
- ZMap.get b (functions r) = Some f ->
- exists tf, ZMap.get b (functions tr) = Some tf /\ match_fun f tf.
-Proof.
- induction 1; simpl.
-
- split. reflexivity. split. reflexivity.
- intros b f; repeat (rewrite ZMap.gi). intros; discriminate.
-
- destruct a1 as [id1 fn1]. destruct b1 as [id2 fn2].
- simpl. red in H. destruct H.
- destruct IHlist_forall2 as [X [Y Z]].
- rewrite X. rewrite Y.
- split. auto.
- split. congruence.
- intros b f.
- repeat (rewrite ZMap.gsspec).
- destruct (ZIndexed.eq b (nextfunction (add_functs (empty A) al))).
- intro EQ; inv EQ. exists fn2; auto.
+
+Record match_genvs (ge1: t A V) (ge2: t B W): Prop := {
+ mge_nextfun: genv_nextfun ge1 = genv_nextfun ge2;
+ mge_nextvar: genv_nextvar ge1 = genv_nextvar ge2;
+ mge_symb: genv_symb ge1 = genv_symb ge2;
+ mge_funs:
+ forall b f, ZMap.get b (genv_funs ge1) = Some f ->
+ exists tf, ZMap.get b (genv_funs ge2) = Some tf /\ match_fun f tf;
+ mge_rev_funs:
+ forall b tf, ZMap.get b (genv_funs ge2) = Some tf ->
+ exists f, ZMap.get b (genv_funs ge1) = Some f /\ match_fun f tf;
+ mge_vars:
+ forall b v, ZMap.get b (genv_vars ge1) = Some v ->
+ exists tv, ZMap.get b (genv_vars ge2) = Some tv /\ match_var v tv;
+ mge_rev_vars:
+ forall b tv, ZMap.get b (genv_vars ge2) = Some tv ->
+ exists v, ZMap.get b (genv_vars ge1) = Some v /\ match_var v tv
+}.
+
+Lemma add_function_match:
+ forall ge1 ge2 id f1 f2,
+ match_genvs ge1 ge2 ->
+ match_fun f1 f2 ->
+ match_genvs (add_function ge1 (id, f1)) (add_function ge2 (id, f2)).
+Proof.
+ intros. destruct H. constructor; simpl.
+ congruence. congruence. congruence.
+ rewrite mge_nextfun0. intros. rewrite ZMap.gsspec in H. rewrite ZMap.gsspec.
+ destruct (ZIndexed.eq b (genv_nextfun ge2)).
+ exists f2; split; congruence.
+ eauto.
+ rewrite mge_nextfun0. intros. rewrite ZMap.gsspec in H. rewrite ZMap.gsspec.
+ destruct (ZIndexed.eq b (genv_nextfun ge2)).
+ exists f1; split; congruence.
+ eauto.
+ auto.
auto.
Qed.
-Lemma add_functs_rev_match:
- forall (fns: list (ident * A)) (tfns: list (ident * B)),
- list_forall2 (match_funct_entry match_fun) fns tfns ->
- let r := add_functs (empty A) fns in
- let tr := add_functs (empty B) tfns in
- nextfunction tr = nextfunction r /\
- symbols tr = symbols r /\
- forall (b: block) (tf: B),
- ZMap.get b (functions tr) = Some tf ->
- exists f, ZMap.get b (functions r) = Some f /\ match_fun f tf.
-Proof.
- induction 1; simpl.
-
- split. reflexivity. split. reflexivity.
- intros b f; repeat (rewrite ZMap.gi). intros; discriminate.
-
- destruct a1 as [id1 fn1]. destruct b1 as [id2 fn2].
- simpl. red in H. destruct H.
- destruct IHlist_forall2 as [X [Y Z]].
- rewrite X. rewrite Y.
- split. auto.
- split. congruence.
- intros b f.
- repeat (rewrite ZMap.gsspec).
- destruct (ZIndexed.eq b (nextfunction (add_functs (empty A) al))).
- intro EQ; inv EQ. exists fn1; auto.
+Lemma add_functions_match:
+ forall fl1 fl2, list_forall2 (match_funct_entry match_fun) fl1 fl2 ->
+ forall ge1 ge2, match_genvs ge1 ge2 ->
+ match_genvs (add_functions ge1 fl1) (add_functions ge2 fl2).
+Proof.
+ induction 1; intros; simpl.
auto.
+ destruct a1 as [id1 f1]; destruct b1 as [id2 f2].
+ destruct H. subst. apply IHlist_forall2. apply add_function_match; auto.
Qed.
-Lemma mem_add_globals_match:
- forall (g1: genv A) (g2: genv B) (m: mem)
- (vars: list (ident * list init_data * V))
- (tvars: list (ident * list init_data * W)),
- list_forall2 (match_var_entry match_var) vars tvars ->
- snd (add_globals (g1, m) vars) = snd (add_globals (g2, m) tvars).
+Lemma add_variable_match:
+ forall ge1 ge2 id idl v1 v2,
+ match_genvs ge1 ge2 ->
+ match_var v1 v2 ->
+ match_genvs (add_variable ge1 (id, idl, v1)) (add_variable ge2 (id, idl, v2)).
Proof.
- induction 1; simpl.
+ intros. destruct H. constructor; simpl.
+ congruence. congruence. congruence.
auto.
- destruct a1 as [[id1 init1] info1].
- destruct b1 as [[id2 init2] info2].
- red in H. destruct H as [X [Y Z]]. subst id2 init2.
- generalize IHlist_forall2.
- destruct (add_globals (g1, m) al).
- destruct (add_globals (g2, m) bl).
- simpl. intro. subst m1. auto.
-Qed.
-
-Lemma symbols_add_globals_match:
- forall (g1: genv A) (g2: genv B) (m: mem),
- symbols g1 = symbols g2 ->
- forall (vars: list (ident * list init_data * V))
- (tvars: list (ident * list init_data * W)),
- list_forall2 (match_var_entry match_var) vars tvars ->
- symbols (fst (add_globals (g1, m) vars)) =
- symbols (fst (add_globals (g2, m) tvars)).
-Proof.
- induction 2; simpl.
auto.
- destruct a1 as [[id1 init1] info1].
- destruct b1 as [[id2 init2] info2].
- red in H0. destruct H0 as [X [Y Z]]. subst id2 init2.
- generalize IHlist_forall2.
- generalize (mem_add_globals_match g1 g2 m H1).
- destruct (add_globals (g1, m) al).
- destruct (add_globals (g2, m) bl).
- simpl. intros. congruence.
+ rewrite mge_nextvar0. intros. rewrite ZMap.gsspec in H. rewrite ZMap.gsspec.
+ destruct (ZIndexed.eq b (genv_nextvar ge2)).
+ exists v2; split; congruence.
+ eauto.
+ rewrite mge_nextvar0. intros. rewrite ZMap.gsspec in H. rewrite ZMap.gsspec.
+ destruct (ZIndexed.eq b (genv_nextvar ge2)).
+ exists v1; split; congruence.
+ eauto.
Qed.
-Theorem find_funct_ptr_match:
- forall (b: block) (f: A),
- find_funct_ptr (globalenv p) b = Some f ->
- exists tf, find_funct_ptr (globalenv p') b = Some tf /\ match_fun f tf.
+Lemma add_variables_match:
+ forall vl1 vl2, list_forall2 (match_var_entry match_var) vl1 vl2 ->
+ forall ge1 ge2, match_genvs ge1 ge2 ->
+ match_genvs (add_variables ge1 vl1) (add_variables ge2 vl2).
Proof.
- intros until f. destruct match_prog as [X [Y Z]].
- destruct (add_functs_match X) as [P [Q R]].
- unfold find_funct_ptr. repeat rewrite functions_globalenv.
+ induction 1; intros; simpl.
auto.
+ destruct a1 as [[id1 init1] f1]; destruct b1 as [[id2 init2] f2].
+ destruct H. destruct H2. subst. apply IHlist_forall2. apply add_variable_match; auto.
Qed.
-Theorem find_funct_ptr_rev_match:
- forall (b: block) (tf: B),
- find_funct_ptr (globalenv p') b = Some tf ->
- exists f, find_funct_ptr (globalenv p) b = Some f /\ match_fun f tf.
+Variable p: program A V.
+Variable p': program B W.
+Hypothesis progmatch: match_program match_fun match_var p p'.
+
+Lemma globalenvs_match:
+ match_genvs (globalenv p) (globalenv p').
Proof.
- intros until tf. destruct match_prog as [X [Y Z]].
- destruct (add_functs_rev_match X) as [P [Q R]].
- unfold find_funct_ptr. repeat rewrite functions_globalenv.
- auto.
+ unfold globalenv. destruct progmatch. destruct H0.
+ apply add_variables_match; auto. apply add_functions_match; auto.
+ constructor; simpl; auto; intros; rewrite ZMap.gi in H2; congruence.
Qed.
+Theorem find_funct_ptr_match:
+ forall (b : block) (f : A),
+ find_funct_ptr (globalenv p) b = Some f ->
+ exists tf : B,
+ find_funct_ptr (globalenv p') b = Some tf /\ match_fun f tf.
+Proof (mge_funs globalenvs_match).
+
+Theorem find_funct_ptr_rev_match:
+ forall (b : block) (tf : B),
+ find_funct_ptr (globalenv p') b = Some tf ->
+ exists f : A,
+ find_funct_ptr (globalenv p) b = Some f /\ match_fun f tf.
+Proof (mge_rev_funs globalenvs_match).
+
Theorem find_funct_match:
- forall (v: val) (f: A),
+ forall (v : val) (f : A),
find_funct (globalenv p) v = Some f ->
- exists tf, find_funct (globalenv p') v = Some tf /\ match_fun f tf.
+ exists tf : B, find_funct (globalenv p') v = Some tf /\ match_fun f tf.
Proof.
- intros until f. unfold find_funct.
- case v; try (intros; discriminate).
- intros b ofs.
- case (Int.eq ofs Int.zero); try (intros; discriminate).
- apply find_funct_ptr_match.
+ intros. exploit find_funct_inv; eauto. intros [b EQ]. subst v.
+ rewrite find_funct_find_funct_ptr in H.
+ rewrite find_funct_find_funct_ptr.
+ apply find_funct_ptr_match. auto.
Qed.
Theorem find_funct_rev_match:
- forall (v: val) (tf: B),
+ forall (v : val) (tf : B),
find_funct (globalenv p') v = Some tf ->
- exists f, find_funct (globalenv p) v = Some f /\ match_fun f tf.
+ exists f : A, find_funct (globalenv p) v = Some f /\ match_fun f tf.
Proof.
- intros until tf. unfold find_funct.
- case v; try (intros; discriminate).
- intros b ofs.
- case (Int.eq ofs Int.zero); try (intros; discriminate).
- apply find_funct_ptr_rev_match.
+ intros. exploit find_funct_inv; eauto. intros [b EQ]. subst v.
+ rewrite find_funct_find_funct_ptr in H.
+ rewrite find_funct_find_funct_ptr.
+ apply find_funct_ptr_rev_match. auto.
Qed.
-Lemma symbols_init_match:
- symbols (globalenv p') = symbols (globalenv p).
-Proof.
- unfold globalenv. unfold globalenv_initmem.
- destruct match_prog as [X [Y Z]].
- destruct (add_functs_match X) as [P [Q R]].
- simpl. symmetry. apply symbols_add_globals_match. auto. auto.
-Qed.
+Theorem find_var_info_match:
+ forall (b : block) (v : V),
+ find_var_info (globalenv p) b = Some v ->
+ exists tv,
+ find_var_info (globalenv p') b = Some tv /\ match_var v tv.
+Proof (mge_vars globalenvs_match).
+
+Theorem find_var_info_rev_match:
+ forall (b : block) (tv : W),
+ find_var_info (globalenv p') b = Some tv ->
+ exists v,
+ find_var_info (globalenv p) b = Some v /\ match_var v tv.
+Proof (mge_rev_vars globalenvs_match).
Theorem find_symbol_match:
- forall (s: ident),
+ forall (s : ident),
find_symbol (globalenv p') s = find_symbol (globalenv p) s.
Proof.
- intros. unfold find_symbol.
- rewrite symbols_init_match. auto.
+ intros. destruct globalenvs_match. unfold find_symbol. congruence.
+Qed.
+
+Lemma store_init_data_list_match:
+ forall idl m b ofs,
+ store_init_data_list (globalenv p') m b ofs idl =
+ store_init_data_list (globalenv p) m b ofs idl.
+Proof.
+ induction idl; simpl; intros.
+ auto.
+ assert (store_init_data (globalenv p') m b ofs a =
+ store_init_data (globalenv p) m b ofs a).
+ destruct a; simpl; auto. rewrite find_symbol_match. auto.
+ rewrite H. destruct (store_init_data (globalenv p) m b ofs a); auto.
+Qed.
+
+Lemma alloc_variables_match:
+ forall vl1 vl2, list_forall2 (match_var_entry match_var) vl1 vl2 ->
+ forall m,
+ alloc_variables (globalenv p') m vl2 = alloc_variables (globalenv p) m vl1.
+Proof.
+ induction 1; intros; simpl.
+ auto.
+ destruct a1 as [[id1 init1] v1]; destruct b1 as [[id2 init2] v2].
+ destruct H. destruct H1. subst.
+ unfold alloc_variable; simpl.
+ destruct (Mem.alloc m 0 (init_data_list_size init2)).
+ rewrite store_init_data_list_match.
+ destruct (store_init_data_list (globalenv p) m0 b 0 init2); auto.
Qed.
Theorem init_mem_match:
- init_mem p' = init_mem p.
+ forall m, init_mem p = Some m -> init_mem p' = Some m.
Proof.
- unfold init_mem. unfold globalenv_initmem.
- destruct match_prog as [X [Y Z]].
- symmetry. apply mem_add_globals_match. auto.
+ intros. rewrite <- H. unfold init_mem. destruct progmatch. destruct H1.
+ apply alloc_variables_match; auto.
Qed.
-End MATCH_PROGRAM.
+End MATCH_PROGRAMS.
Section TRANSF_PROGRAM_PARTIAL2.
@@ -1007,6 +1136,28 @@ Proof.
exploit find_funct_rev_match. eexact prog_match. eauto. auto.
Qed.
+Theorem find_var_info_transf_partial2:
+ forall (b: block) (v: V),
+ find_var_info (globalenv p) b = Some v ->
+ exists v',
+ find_var_info (globalenv p') b = Some v' /\ transf_var v = OK v'.
+Proof.
+ intros.
+ exploit find_var_info_match. eexact prog_match. eauto.
+ intros [tv [X Y]]. exists tv; auto.
+Qed.
+
+Theorem find_var_info_rev_transf_partial2:
+ forall (b: block) (v': W),
+ find_var_info (globalenv p') b = Some v' ->
+ exists v,
+ find_var_info (globalenv p) b = Some v /\ transf_var v = OK v'.
+Proof.
+ intros.
+ exploit find_var_info_rev_match. eexact prog_match. eauto.
+ intros [v [X Y]]. exists v; auto.
+Qed.
+
Theorem find_symbol_transf_partial2:
forall (s: ident),
find_symbol (globalenv p') s = find_symbol (globalenv p) s.
@@ -1015,9 +1166,9 @@ Proof.
Qed.
Theorem init_mem_transf_partial2:
- init_mem p' = init_mem p.
+ forall m, init_mem p = Some m -> init_mem p' = Some m.
Proof.
- intros. eapply init_mem_match. eexact prog_match.
+ intros. eapply init_mem_match. eexact prog_match. auto.
Qed.
End TRANSF_PROGRAM_PARTIAL2.
@@ -1080,7 +1231,7 @@ Proof.
Qed.
Theorem init_mem_transf_partial:
- init_mem p' = init_mem p.
+ forall m, init_mem p = Some m -> init_mem p' = Some m.
Proof.
exact (@init_mem_transf_partial2 _ _ _ _ _ _ _ _ transf2_OK).
Qed.
@@ -1147,7 +1298,7 @@ Proof.
Qed.
Theorem init_mem_transf:
- init_mem tp = init_mem p.
+ forall m, init_mem p = Some m -> init_mem tp = Some m.
Proof.
exact (@init_mem_transf_partial _ _ _ _ _ _ transf_OK).
Qed.
diff --git a/common/Mem.v b/common/Mem.v
deleted file mode 100644
index 252ee29..0000000
--- a/common/Mem.v
+++ /dev/null
@@ -1,2887 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* Sandrine Blazy, ENSIIE and 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 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. *)
-(* *)
-(* *********************************************************************)
-
-(** This file develops the memory model that is used in the dynamic
- semantics of all the languages used in the compiler.
- It defines a type [mem] of memory states, the following 4 basic
- operations over memory states, and their properties:
-- [load]: read a memory chunk at a given address;
-- [store]: store a memory chunk at a given address;
-- [alloc]: allocate a fresh memory block;
-- [free]: invalidate a memory block.
-*)
-
-Require Import Coqlib.
-Require Import Maps.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Values.
-
-Definition update (A: Type) (x: Z) (v: A) (f: Z -> A) : Z -> A :=
- fun y => if zeq y x then v else f y.
-
-Implicit Arguments update [A].
-
-Lemma update_s:
- forall (A: Type) (x: Z) (v: A) (f: Z -> A),
- update x v f x = v.
-Proof.
- intros; unfold update. apply zeq_true.
-Qed.
-
-Lemma update_o:
- forall (A: Type) (x: Z) (v: A) (f: Z -> A) (y: Z),
- x <> y -> update x v f y = f y.
-Proof.
- intros; unfold update. apply zeq_false; auto.
-Qed.
-
-(** * Structure of memory states *)
-
-(** A memory state is organized in several disjoint blocks. Each block
- has a low and a high bound that defines its size. Each block map
- byte offsets to the contents of this byte. *)
-
-(** The possible contents of a byte-sized memory cell. To give intuitions,
- a 4-byte value [v] stored at offset [d] will be represented by
- the content [Datum(4, v)] at offset [d] and [Cont] at offsets [d+1],
- [d+2] and [d+3]. The [Cont] contents enable detecting future writes
- that would partially overlap the 4-byte value. *)
-
-Inductive content : Type :=
- | Undef: content (**r undefined contents *)
- | Datum: nat -> val -> content (**r first byte of a value *)
- | Cont: content. (**r continuation bytes for a multi-byte value *)
-
-Definition contentmap : Type := Z -> content.
-
-(** A memory block comprises the dimensions of the block (low and high bounds)
- plus a mapping from byte offsets to contents. *)
-
-Record block_contents : Type := mkblock {
- low: Z;
- high: Z;
- contents: contentmap
-}.
-
-(** A memory state is a mapping from block addresses (represented by [Z]
- integers) to blocks. We also maintain the address of the next
- unallocated block, and a proof that this address is positive. *)
-
-Record mem : Type := mkmem {
- blocks: Z -> block_contents;
- nextblock: block;
- nextblock_pos: nextblock > 0
-}.
-
-(** * Operations on memory stores *)
-
-(** Memory reads and writes are performed by quantities called memory chunks,
- encoding the type, size and signedness of the chunk being addressed.
- The following functions extract the size information from a chunk. *)
-
-Definition size_chunk (chunk: memory_chunk) : Z :=
- match chunk with
- | Mint8signed => 1
- | Mint8unsigned => 1
- | Mint16signed => 2
- | Mint16unsigned => 2
- | Mint32 => 4
- | Mfloat32 => 4
- | Mfloat64 => 8
- end.
-
-Definition pred_size_chunk (chunk: memory_chunk) : nat :=
- match chunk with
- | Mint8signed => 0%nat
- | Mint8unsigned => 0%nat
- | Mint16signed => 1%nat
- | Mint16unsigned => 1%nat
- | Mint32 => 3%nat
- | Mfloat32 => 3%nat
- | Mfloat64 => 7%nat
- end.
-
-Lemma size_chunk_pred:
- forall chunk, size_chunk chunk = 1 + Z_of_nat (pred_size_chunk chunk).
-Proof.
- destruct chunk; auto.
-Qed.
-
-Lemma size_chunk_pos:
- forall chunk, size_chunk chunk > 0.
-Proof.
- intros. rewrite size_chunk_pred. omega.
-Qed.
-
-(** Memory reads and writes must respect alignment constraints:
- the byte offset of the location being addressed should be an exact
- multiple of the natural alignment for the chunk being addressed.
- This natural alignment is defined by the following
- [align_chunk] function. Some target architectures
- (e.g. the PowerPC) have no alignment constraints, which we could
- reflect by taking [align_chunk chunk = 1]. However, other architectures
- have stronger alignment requirements. The following definition is
- appropriate for PowerPC and ARM. *)
-
-Definition align_chunk (chunk: memory_chunk) : Z :=
- match chunk with
- | Mint8signed => 1
- | Mint8unsigned => 1
- | Mint16signed => 2
- | Mint16unsigned => 2
- | _ => 4
- end.
-
-Lemma align_chunk_pos:
- forall chunk, align_chunk chunk > 0.
-Proof.
- intro. destruct chunk; simpl; omega.
-Qed.
-
-Lemma align_size_chunk_divides:
- forall chunk, (align_chunk chunk | size_chunk chunk).
-Proof.
- intros. destruct chunk; simpl; try apply Zdivide_refl. exists 2; auto.
-Qed.
-
-Lemma align_chunk_compat:
- forall chunk1 chunk2,
- size_chunk chunk1 = size_chunk chunk2 -> align_chunk chunk1 = align_chunk chunk2.
-Proof.
- intros chunk1 chunk2.
- destruct chunk1; destruct chunk2; simpl; congruence.
-Qed.
-
-(** The initial store. *)
-
-Remark one_pos: 1 > 0.
-Proof. omega. Qed.
-
-Definition empty_block (lo hi: Z) : block_contents :=
- mkblock lo hi (fun y => Undef).
-
-Definition empty: mem :=
- mkmem (fun x => empty_block 0 0) 1 one_pos.
-
-Definition nullptr: block := 0.
-
-(** Allocation of a fresh block with the given bounds. Return an updated
- memory state and the address of the fresh block, which initially contains
- undefined cells. Note that allocation never fails: we model an
- infinite memory. *)
-
-Remark succ_nextblock_pos:
- forall m, Zsucc m.(nextblock) > 0.
-Proof. intro. generalize (nextblock_pos m). omega. Qed.
-
-Definition alloc (m: mem) (lo hi: Z) :=
- (mkmem (update m.(nextblock)
- (empty_block lo hi)
- m.(blocks))
- (Zsucc m.(nextblock))
- (succ_nextblock_pos m),
- m.(nextblock)).
-
-(** Freeing a block. Return the updated memory state where the given
- block address has been invalidated: future reads and writes to this
- address will fail. Note that we make no attempt to return the block
- to an allocation pool: the given block address will never be allocated
- later. *)
-
-Definition free (m: mem) (b: block) :=
- mkmem (update b
- (empty_block 0 0)
- m.(blocks))
- m.(nextblock)
- m.(nextblock_pos).
-
-(** Freeing of a list of blocks. *)
-
-Definition free_list (m:mem) (l:list block) :=
- List.fold_right (fun b m => free m b) m l.
-
-(** Return the low and high bounds for the given block address.
- Those bounds are 0 for freed or not yet allocated address. *)
-
-Definition low_bound (m: mem) (b: block) :=
- low (m.(blocks) b).
-Definition high_bound (m: mem) (b: block) :=
- high (m.(blocks) b).
-
-(** A block address is valid if it was previously allocated. It remains valid
- even after being freed. *)
-
-Definition valid_block (m: mem) (b: block) :=
- b < m.(nextblock).
-
-(** Reading and writing [N] adjacent locations in a [contentmap].
-
- We define two functions and prove some of their properties:
- - [getN n ofs m] returns the datum at offset [ofs] in block contents [m]
- after checking that the contents of offsets [ofs+1] to [ofs+n+1]
- are [Cont].
- - [setN n ofs v m] updates the block contents [m], storing the content [v]
- at offset [ofs] and the content [Cont] at offsets [ofs+1] to [ofs+n+1].
- *)
-
-Fixpoint check_cont (n: nat) (p: Z) (m: contentmap) {struct n} : bool :=
- match n with
- | O => true
- | S n1 =>
- match m p with
- | Cont => check_cont n1 (p + 1) m
- | _ => false
- end
- end.
-
-Definition eq_nat: forall (p q: nat), {p=q} + {p<>q}.
-Proof. decide equality. Defined.
-
-Definition getN (n: nat) (p: Z) (m: contentmap) : val :=
- match m p with
- | Datum n' v =>
- if eq_nat n n' && check_cont n (p + 1) m then v else Vundef
- | _ =>
- Vundef
- end.
-
-Fixpoint set_cont (n: nat) (p: Z) (m: contentmap) {struct n} : contentmap :=
- match n with
- | O => m
- | S n1 => update p Cont (set_cont n1 (p + 1) m)
- end.
-
-Definition setN (n: nat) (p: Z) (v: val) (m: contentmap) : contentmap :=
- update p (Datum n v) (set_cont n (p + 1) m).
-
-Lemma check_cont_spec:
- forall n m p,
- if check_cont n p m
- then (forall q, p <= q < p + Z_of_nat n -> m q = Cont)
- else (exists q, p <= q < p + Z_of_nat n /\ m q <> Cont).
-Proof.
- induction n; intros.
- simpl. intros; omegaContradiction.
- simpl check_cont. repeat rewrite inj_S. caseEq (m p); intros.
- exists p; split. omega. congruence.
- exists p; split. omega. congruence.
- generalize (IHn m (p + 1)). case (check_cont n (p + 1) m).
- intros. assert (p = q \/ p + 1 <= q < p + Zsucc (Z_of_nat n)) by omega.
- elim H2; intro. congruence. apply H0; omega.
- intros [q [A B]]. exists q; split. omega. auto.
-Qed.
-
-Lemma check_cont_true:
- forall n m p,
- (forall q, p <= q < p + Z_of_nat n -> m q = Cont) ->
- check_cont n p m = true.
-Proof.
- intros. generalize (check_cont_spec n m p).
- destruct (check_cont n p m). auto.
- intros [q [A B]]. elim B; auto.
-Qed.
-
-Lemma check_cont_false:
- forall n m p q,
- p <= q < p + Z_of_nat n -> m q <> Cont ->
- check_cont n p m = false.
-Proof.
- intros. generalize (check_cont_spec n m p).
- destruct (check_cont n p m).
- intros. elim H0; auto.
- auto.
-Qed.
-
-Lemma set_cont_inside:
- forall n p m q,
- p <= q < p + Z_of_nat n ->
- (set_cont n p m) q = Cont.
-Proof.
- induction n; intros.
- unfold Z_of_nat in H. omegaContradiction.
- simpl.
- assert (p = q \/ p + 1 <= q < (p + 1) + Z_of_nat n).
- rewrite inj_S in H. omega.
- elim H0; intro.
- subst q. apply update_s.
- rewrite update_o. apply IHn. auto.
- red; intro; subst q. omega.
-Qed.
-
-Lemma set_cont_outside:
- forall n p m q,
- q < p \/ p + Z_of_nat n <= q ->
- (set_cont n p m) q = m q.
-Proof.
- induction n; intros.
- simpl. auto.
- simpl. rewrite inj_S in H.
- rewrite update_o. apply IHn. omega. omega.
-Qed.
-
-Lemma getN_setN_same:
- forall n p v m,
- getN n p (setN n p v m) = v.
-Proof.
- intros. unfold getN, setN. rewrite update_s.
- rewrite check_cont_true. unfold proj_sumbool.
- rewrite dec_eq_true. auto.
- intros. rewrite update_o. apply set_cont_inside. auto.
- omega.
-Qed.
-
-Lemma getN_setN_other:
- forall n1 n2 p1 p2 v m,
- p1 + Z_of_nat n1 < p2 \/ p2 + Z_of_nat n2 < p1 ->
- getN n2 p2 (setN n1 p1 v m) = getN n2 p2 m.
-Proof.
- intros. unfold getN, setN.
- generalize (check_cont_spec n2 m (p2 + 1));
- destruct (check_cont n2 (p2 + 1) m); intros.
- rewrite check_cont_true.
- rewrite update_o. rewrite set_cont_outside. auto.
- omega. omega.
- intros. rewrite update_o. rewrite set_cont_outside. auto.
- omega. omega.
- destruct H0 as [q [A B]].
- rewrite (check_cont_false n2 (update p1 (Datum n1 v) (set_cont n1 (p1 + 1) m)) (p2 + 1) q).
- rewrite update_o. rewrite set_cont_outside. auto.
- omega. omega. omega.
- rewrite update_o. rewrite set_cont_outside. auto.
- omega. omega.
-Qed.
-
-Lemma getN_setN_overlap:
- forall n1 n2 p1 p2 v m,
- p1 <> p2 ->
- p1 + Z_of_nat n1 >= p2 -> p2 + Z_of_nat n2 >= p1 ->
- getN n2 p2 (setN n1 p1 v m) = Vundef.
-Proof.
- intros. unfold getN, setN.
- rewrite update_o; auto.
- destruct (zlt p2 p1).
- (* [p1] belongs to [[p2, p2 + n2 - 1]],
- therefore [check_cont n2 (p2 + 1) ...] is false. *)
- rewrite (check_cont_false n2 (update p1 (Datum n1 v) (set_cont n1 (p1 + 1) m)) (p2 + 1) p1).
- destruct (set_cont n1 (p1 + 1) m p2); auto.
- destruct (eq_nat n2 n); auto.
- omega.
- rewrite update_s. congruence.
- (* [p2] belongs to [[p1 + 1, p1 + n1 - 1]],
- therefore [set_cont n1 (p1 + 1) m p2] is [Cont]. *)
- rewrite set_cont_inside. auto. omega.
-Qed.
-
-Lemma getN_setN_mismatch:
- forall n1 n2 p v m,
- n1 <> n2 ->
- getN n2 p (setN n1 p v m) = Vundef.
-Proof.
- intros. unfold getN, setN. rewrite update_s.
- unfold proj_sumbool; rewrite dec_eq_false; simpl. auto. auto.
-Qed.
-
-Lemma getN_setN_characterization:
- forall m v n1 p1 n2 p2,
- getN n2 p2 (setN n1 p1 v m) = v
- \/ getN n2 p2 (setN n1 p1 v m) = getN n2 p2 m
- \/ getN n2 p2 (setN n1 p1 v m) = Vundef.
-Proof.
- intros. destruct (zeq p1 p2). subst p2.
- destruct (eq_nat n1 n2). subst n2.
- left; apply getN_setN_same.
- right; right; apply getN_setN_mismatch; auto.
- destruct (zlt (p1 + Z_of_nat n1) p2).
- right; left; apply getN_setN_other; auto.
- destruct (zlt (p2 + Z_of_nat n2) p1).
- right; left; apply getN_setN_other; auto.
- right; right; apply getN_setN_overlap; omega.
-Qed.
-
-Lemma getN_init:
- forall n p,
- getN n p (fun y => Undef) = Vundef.
-Proof.
- intros. auto.
-Qed.
-
-(** [valid_access m chunk b ofs] holds if a memory access (load or store)
- of the given chunk is possible in [m] at address [b, ofs].
- This means:
-- The block [b] is valid.
-- The range of bytes accessed is within the bounds of [b].
-- The offset [ofs] is aligned.
-*)
-
-Inductive valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) : Prop :=
- | valid_access_intro:
- valid_block m b ->
- low_bound m b <= ofs ->
- ofs + size_chunk chunk <= high_bound m b ->
- (align_chunk chunk | ofs) ->
- valid_access m chunk b ofs.
-
-(** The following function checks whether accessing the given memory chunk
- at the given offset in the given block respects the bounds of the block. *)
-
-Definition in_bounds (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) :
- {valid_access m chunk b ofs} + {~valid_access m chunk b ofs}.
-Proof.
- intros.
- destruct (zlt b m.(nextblock)).
- destruct (zle (low_bound m b) ofs).
- destruct (zle (ofs + size_chunk chunk) (high_bound m b)).
- destruct (Zdivide_dec (align_chunk chunk) ofs (align_chunk_pos chunk)).
- left; constructor; auto.
- right; red; intro V; inv V; contradiction.
- right; red; intro V; inv V; omega.
- right; red; intro V; inv V; omega.
- right; red; intro V; inv V; contradiction.
-Defined.
-
-Lemma in_bounds_true:
- forall m chunk b ofs (A: Type) (a1 a2: A),
- valid_access m chunk b ofs ->
- (if in_bounds m chunk b ofs then a1 else a2) = a1.
-Proof.
- intros. destruct (in_bounds m chunk b ofs). auto. contradiction.
-Qed.
-
-(** [valid_pointer] holds if the given block address is valid and the
- given offset falls within the bounds of the corresponding block. *)
-
-Definition valid_pointer (m: mem) (b: block) (ofs: Z) : bool :=
- zlt b m.(nextblock) &&
- zle (low_bound m b) ofs &&
- zlt ofs (high_bound m b).
-
-(** [load chunk m b ofs] perform a read in memory state [m], at address
- [b] and offset [ofs]. [None] is returned if the address is invalid
- or the memory access is out of bounds. *)
-
-Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z)
- : option val :=
- if in_bounds m chunk b ofs then
- Some (Val.load_result chunk
- (getN (pred_size_chunk chunk) ofs (contents (blocks m b))))
- else
- None.
-
-Lemma load_inv:
- forall chunk m b ofs v,
- load chunk m b ofs = Some v ->
- valid_access m chunk b ofs /\
- v = Val.load_result chunk
- (getN (pred_size_chunk chunk) ofs (contents (blocks m b))).
-Proof.
- intros until v; unfold load.
- destruct (in_bounds m chunk b ofs); intros.
- split. auto. congruence.
- congruence.
-Qed.
-
-(** [loadv chunk m addr] is similar, but the address and offset are given
- as a single value [addr], which must be a pointer value. *)
-
-Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val :=
- match addr with
- | Vptr b ofs => load chunk m b (Int.signed ofs)
- | _ => None
- end.
-
-(* The memory state [m] after a store of value [v] at offset [ofs]
- in block [b]. *)
-
-Definition unchecked_store
- (chunk: memory_chunk) (m: mem) (b: block)
- (ofs: Z) (v: val) : mem :=
- let c := m.(blocks) b in
- mkmem
- (update b
- (mkblock c.(low) c.(high)
- (setN (pred_size_chunk chunk) ofs v c.(contents)))
- m.(blocks))
- m.(nextblock)
- m.(nextblock_pos).
-
-(** [store chunk m b ofs v] perform a write in memory state [m].
- Value [v] is stored at address [b] and offset [ofs].
- Return the updated memory store, or [None] if the address is invalid
- or the memory access is out of bounds. *)
-
-Definition store (chunk: memory_chunk) (m: mem) (b: block)
- (ofs: Z) (v: val) : option mem :=
- if in_bounds m chunk b ofs
- then Some(unchecked_store chunk m b ofs v)
- else None.
-
-Lemma store_inv:
- forall chunk m b ofs v m',
- store chunk m b ofs v = Some m' ->
- valid_access m chunk b ofs /\
- m' = unchecked_store chunk m b ofs v.
-Proof.
- intros until m'; unfold store.
- destruct (in_bounds m chunk b ofs); intros.
- split. auto. congruence.
- congruence.
-Qed.
-
-(** [storev chunk m addr v] is similar, but the address and offset are given
- as a single value [addr], which must be a pointer value. *)
-
-Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem :=
- match addr with
- | Vptr b ofs => store chunk m b (Int.signed ofs) v
- | _ => None
- end.
-
-(** Build a block filled with the given initialization data. *)
-
-Fixpoint contents_init_data (pos: Z) (id: list init_data) {struct id}: contentmap :=
- match id with
- | nil => (fun y => Undef)
- | Init_int8 n :: id' =>
- setN 0%nat pos (Vint n) (contents_init_data (pos + 1) id')
- | Init_int16 n :: id' =>
- setN 1%nat pos (Vint n) (contents_init_data (pos + 1) id')
- | Init_int32 n :: id' =>
- setN 3%nat pos (Vint n) (contents_init_data (pos + 1) id')
- | Init_float32 f :: id' =>
- setN 3%nat pos (Vfloat f) (contents_init_data (pos + 1) id')
- | Init_float64 f :: id' =>
- setN 7%nat pos (Vfloat f) (contents_init_data (pos + 1) id')
- | Init_space n :: id' =>
- contents_init_data (pos + Zmax n 0) id'
- | Init_addrof s n :: id' =>
- (* Not handled properly yet *)
- contents_init_data (pos + 4) id'
- end.
-
-Definition size_init_data (id: init_data) : Z :=
- match id with
- | Init_int8 _ => 1
- | Init_int16 _ => 2
- | Init_int32 _ => 4
- | Init_float32 _ => 4
- | Init_float64 _ => 8
- | Init_space n => Zmax n 0
- | Init_addrof _ _ => 4
- end.
-
-Definition size_init_data_list (id: list init_data): Z :=
- List.fold_right (fun id sz => size_init_data id + sz) 0 id.
-
-Remark size_init_data_list_pos:
- forall id, size_init_data_list id >= 0.
-Proof.
- induction id; simpl.
- omega.
- assert (size_init_data a >= 0). destruct a; simpl; try omega.
- generalize (Zmax2 z 0). omega. omega.
-Qed.
-
-Definition block_init_data (id: list init_data) : block_contents :=
- mkblock 0 (size_init_data_list id) (contents_init_data 0 id).
-
-Definition alloc_init_data (m: mem) (id: list init_data) : mem * block :=
- (mkmem (update m.(nextblock)
- (block_init_data id)
- m.(blocks))
- (Zsucc m.(nextblock))
- (succ_nextblock_pos m),
- m.(nextblock)).
-
-Remark block_init_data_empty:
- block_init_data nil = empty_block 0 0.
-Proof.
- auto.
-Qed.
-
-(** * Properties of the memory operations *)
-
-(** ** Properties related to block validity *)
-
-Lemma valid_not_valid_diff:
- forall m b b', valid_block m b -> ~(valid_block m b') -> b <> b'.
-Proof.
- intros; red; intros. subst b'. contradiction.
-Qed.
-
-Lemma valid_access_valid_block:
- forall m chunk b ofs,
- valid_access m chunk b ofs -> valid_block m b.
-Proof.
- intros. inv H; auto.
-Qed.
-
-Lemma valid_access_aligned:
- forall m chunk b ofs,
- valid_access m chunk b ofs -> (align_chunk chunk | ofs).
-Proof.
- intros. inv H; auto.
-Qed.
-
-Lemma valid_access_compat:
- forall m chunk1 chunk2 b ofs,
- size_chunk chunk1 = size_chunk chunk2 ->
- valid_access m chunk1 b ofs ->
- valid_access m chunk2 b ofs.
-Proof.
- intros. inv H0. rewrite H in H3. constructor; auto.
- rewrite <- (align_chunk_compat _ _ H). auto.
-Qed.
-
-Hint Resolve valid_not_valid_diff valid_access_valid_block valid_access_aligned: mem.
-
-(** ** Properties related to [load] *)
-
-Theorem valid_access_load:
- forall m chunk b ofs,
- valid_access m chunk b ofs ->
- exists v, load chunk m b ofs = Some v.
-Proof.
- intros. econstructor. unfold load. rewrite in_bounds_true; auto.
-Qed.
-
-Theorem load_valid_access:
- forall m chunk b ofs v,
- load chunk m b ofs = Some v ->
- valid_access m chunk b ofs.
-Proof.
- intros. generalize (load_inv _ _ _ _ _ H). tauto.
-Qed.
-
-Hint Resolve load_valid_access valid_access_load.
-
-(** ** Properties related to [store] *)
-
-Lemma valid_access_store:
- forall m1 chunk b ofs v,
- valid_access m1 chunk b ofs ->
- exists m2, store chunk m1 b ofs v = Some m2.
-Proof.
- intros. econstructor. unfold store. rewrite in_bounds_true; auto.
-Qed.
-
-Hint Resolve valid_access_store: mem.
-
-Section STORE.
-Variable chunk: memory_chunk.
-Variable m1: mem.
-Variable b: block.
-Variable ofs: Z.
-Variable v: val.
-Variable m2: mem.
-Hypothesis STORE: store chunk m1 b ofs v = Some m2.
-
-Lemma low_bound_store:
- forall b', low_bound m2 b' = low_bound m1 b'.
-Proof.
- intro. elim (store_inv _ _ _ _ _ _ STORE); intros.
- subst m2. unfold low_bound, unchecked_store; simpl.
- unfold update. destruct (zeq b' b); auto. subst b'; auto.
-Qed.
-
-Lemma high_bound_store:
- forall b', high_bound m2 b' = high_bound m1 b'.
-Proof.
- intro. elim (store_inv _ _ _ _ _ _ STORE); intros.
- subst m2. unfold high_bound, unchecked_store; simpl.
- unfold update. destruct (zeq b' b); auto. subst b'; auto.
-Qed.
-
-Lemma nextblock_store:
- nextblock m2 = nextblock m1.
-Proof.
- intros. elim (store_inv _ _ _ _ _ _ STORE); intros.
- subst m2; reflexivity.
-Qed.
-
-Lemma store_valid_block_1:
- forall b', valid_block m1 b' -> valid_block m2 b'.
-Proof.
- unfold valid_block; intros. rewrite nextblock_store; auto.
-Qed.
-
-Lemma store_valid_block_2:
- forall b', valid_block m2 b' -> valid_block m1 b'.
-Proof.
- unfold valid_block; intros. rewrite nextblock_store in H; auto.
-Qed.
-
-Hint Resolve store_valid_block_1 store_valid_block_2: mem.
-
-Lemma store_valid_access_1:
- forall chunk' b' ofs',
- valid_access m1 chunk' b' ofs' -> valid_access m2 chunk' b' ofs'.
-Proof.
- intros. inv H. constructor; auto with mem.
- rewrite low_bound_store; auto.
- rewrite high_bound_store; auto.
-Qed.
-
-Lemma store_valid_access_2:
- forall chunk' b' ofs',
- valid_access m2 chunk' b' ofs' -> valid_access m1 chunk' b' ofs'.
-Proof.
- intros. inv H. constructor; auto with mem.
- rewrite low_bound_store in H1; auto.
- rewrite high_bound_store in H2; auto.
-Qed.
-
-Lemma store_valid_access_3:
- valid_access m1 chunk b ofs.
-Proof.
- elim (store_inv _ _ _ _ _ _ STORE); intros. auto.
-Qed.
-
-Hint Resolve store_valid_access_1 store_valid_access_2
- store_valid_access_3: mem.
-
-Theorem load_store_similar:
- forall chunk',
- size_chunk chunk' = size_chunk chunk ->
- load chunk' m2 b ofs = Some (Val.load_result chunk' v).
-Proof.
- intros. destruct (store_inv _ _ _ _ _ _ STORE).
- unfold load. rewrite in_bounds_true.
- decEq. decEq. rewrite H1. unfold unchecked_store; simpl.
- rewrite update_s. simpl.
- replace (pred_size_chunk chunk) with (pred_size_chunk chunk').
- apply getN_setN_same.
- repeat rewrite size_chunk_pred in H. omega.
- apply store_valid_access_1.
- inv H0. constructor; auto. congruence.
- rewrite (align_chunk_compat _ _ H). auto.
-Qed.
-
-Theorem load_store_same:
- load chunk m2 b ofs = Some (Val.load_result chunk v).
-Proof.
- eapply load_store_similar; eauto.
-Qed.
-
-Theorem load_store_other:
- forall chunk' b' ofs',
- b' <> b
- \/ ofs' + size_chunk chunk' <= ofs
- \/ ofs + size_chunk chunk <= ofs' ->
- load chunk' m2 b' ofs' = load chunk' m1 b' ofs'.
-Proof.
- intros. destruct (store_inv _ _ _ _ _ _ STORE).
- unfold load. destruct (in_bounds m1 chunk' b' ofs').
- rewrite in_bounds_true. decEq. decEq.
- rewrite H1; unfold unchecked_store; simpl.
- unfold update. destruct (zeq b' b). subst b'.
- simpl. repeat rewrite size_chunk_pred in H.
- apply getN_setN_other. elim H; intro. congruence. omega.
- auto.
- eauto with mem.
- destruct (in_bounds m2 chunk' b' ofs'); auto.
- elim n. eauto with mem.
-Qed.
-
-Theorem load_store_overlap:
- forall chunk' ofs' v',
- load chunk' m2 b ofs' = Some v' ->
- ofs' <> ofs ->
- ofs' + size_chunk chunk' > ofs ->
- ofs + size_chunk chunk > ofs' ->
- v' = Vundef.
-Proof.
- intros. destruct (store_inv _ _ _ _ _ _ STORE).
- destruct (load_inv _ _ _ _ _ H). rewrite H6.
- rewrite H4. unfold unchecked_store. simpl. rewrite update_s.
- simpl. rewrite getN_setN_overlap.
- destruct chunk'; reflexivity.
- auto. rewrite size_chunk_pred in H2. omega.
- rewrite size_chunk_pred in H1. omega.
-Qed.
-
-Theorem load_store_overlap':
- forall chunk' ofs',
- valid_access m1 chunk' b ofs' ->
- ofs' <> ofs ->
- ofs' + size_chunk chunk' > ofs ->
- ofs + size_chunk chunk > ofs' ->
- load chunk' m2 b ofs' = Some Vundef.
-Proof.
- intros.
- assert (exists v', load chunk' m2 b ofs' = Some v').
- eauto with mem.
- destruct H3 as [v' LOAD]. rewrite LOAD. decEq.
- eapply load_store_overlap; eauto.
-Qed.
-
-Theorem load_store_mismatch:
- forall chunk' v',
- load chunk' m2 b ofs = Some v' ->
- size_chunk chunk' <> size_chunk chunk ->
- v' = Vundef.
-Proof.
- intros. destruct (store_inv _ _ _ _ _ _ STORE).
- destruct (load_inv _ _ _ _ _ H). rewrite H4.
- rewrite H2. unfold unchecked_store. simpl. rewrite update_s.
- simpl. rewrite getN_setN_mismatch.
- destruct chunk'; reflexivity.
- repeat rewrite size_chunk_pred in H0; omega.
-Qed.
-
-Theorem load_store_mismatch':
- forall chunk',
- valid_access m1 chunk' b ofs ->
- size_chunk chunk' <> size_chunk chunk ->
- load chunk' m2 b ofs = Some Vundef.
-Proof.
- intros.
- assert (exists v', load chunk' m2 b ofs = Some v').
- eauto with mem.
- destruct H1 as [v' LOAD]. rewrite LOAD. decEq.
- eapply load_store_mismatch; eauto.
-Qed.
-
-Inductive load_store_cases
- (chunk1: memory_chunk) (b1: block) (ofs1: Z)
- (chunk2: memory_chunk) (b2: block) (ofs2: Z) : Type :=
- | lsc_similar:
- b1 = b2 -> ofs1 = ofs2 -> size_chunk chunk1 = size_chunk chunk2 ->
- load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2
- | lsc_other:
- b1 <> b2 \/ ofs2 + size_chunk chunk2 <= ofs1 \/ ofs1 + size_chunk chunk1 <= ofs2 ->
- load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2
- | lsc_overlap:
- b1 = b2 -> ofs1 <> ofs2 -> ofs2 + size_chunk chunk2 > ofs1 -> ofs1 + size_chunk chunk1 > ofs2 ->
- load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2
- | lsc_mismatch:
- b1 = b2 -> ofs1 = ofs2 -> size_chunk chunk1 <> size_chunk chunk2 ->
- load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2.
-
-Definition load_store_classification:
- forall (chunk1: memory_chunk) (b1: block) (ofs1: Z)
- (chunk2: memory_chunk) (b2: block) (ofs2: Z),
- load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2.
-Proof.
- intros. destruct (eq_block b1 b2).
- destruct (zeq ofs1 ofs2).
- destruct (zeq (size_chunk chunk1) (size_chunk chunk2)).
- apply lsc_similar; auto.
- apply lsc_mismatch; auto.
- destruct (zle (ofs2 + size_chunk chunk2) ofs1).
- apply lsc_other. tauto.
- destruct (zle (ofs1 + size_chunk chunk1) ofs2).
- apply lsc_other. tauto.
- apply lsc_overlap; auto.
- apply lsc_other; tauto.
-Qed.
-
-Theorem load_store_characterization:
- forall chunk' b' ofs',
- valid_access m1 chunk' b' ofs' ->
- load chunk' m2 b' ofs' =
- match load_store_classification chunk b ofs chunk' b' ofs' with
- | lsc_similar _ _ _ => Some (Val.load_result chunk' v)
- | lsc_other _ => load chunk' m1 b' ofs'
- | lsc_overlap _ _ _ _ => Some Vundef
- | lsc_mismatch _ _ _ => Some Vundef
- end.
-Proof.
- intros.
- assert (exists v', load chunk' m2 b' ofs' = Some v') by eauto with mem.
- destruct H0 as [v' LOAD].
- destruct (load_store_classification chunk b ofs chunk' b' ofs').
- subst b' ofs'. apply load_store_similar; auto.
- apply load_store_other; intuition.
- subst b'. rewrite LOAD. decEq.
- eapply load_store_overlap; eauto.
- subst b' ofs'. rewrite LOAD. decEq.
- eapply load_store_mismatch; eauto.
-Qed.
-
-End STORE.
-
-Hint Resolve store_valid_block_1 store_valid_block_2: mem.
-Hint Resolve store_valid_access_1 store_valid_access_2
- store_valid_access_3: mem.
-
-(** ** Properties related to [alloc]. *)
-
-Section ALLOC.
-
-Variable m1: mem.
-Variables lo hi: Z.
-Variable m2: mem.
-Variable b: block.
-Hypothesis ALLOC: alloc m1 lo hi = (m2, b).
-
-Lemma nextblock_alloc:
- nextblock m2 = Zsucc (nextblock m1).
-Proof.
- injection ALLOC; intros. rewrite <- H0; auto.
-Qed.
-
-Lemma alloc_result:
- b = nextblock m1.
-Proof.
- injection ALLOC; auto.
-Qed.
-
-Lemma valid_block_alloc:
- forall b', valid_block m1 b' -> valid_block m2 b'.
-Proof.
- unfold valid_block; intros. rewrite nextblock_alloc. omega.
-Qed.
-
-Lemma fresh_block_alloc:
- ~(valid_block m1 b).
-Proof.
- unfold valid_block. rewrite alloc_result. omega.
-Qed.
-
-Lemma valid_new_block:
- valid_block m2 b.
-Proof.
- unfold valid_block. rewrite alloc_result. rewrite nextblock_alloc. omega.
-Qed.
-
-Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem.
-
-Lemma valid_block_alloc_inv:
- forall b', valid_block m2 b' -> b' = b \/ valid_block m1 b'.
-Proof.
- unfold valid_block; intros.
- rewrite nextblock_alloc in H. rewrite alloc_result.
- unfold block; omega.
-Qed.
-
-Lemma low_bound_alloc:
- forall b', low_bound m2 b' = if zeq b' b then lo else low_bound m1 b'.
-Proof.
- intros. injection ALLOC; intros. rewrite <- H0; unfold low_bound; simpl.
- unfold update. rewrite H. destruct (zeq b' b); auto.
-Qed.
-
-Lemma low_bound_alloc_same:
- low_bound m2 b = lo.
-Proof.
- rewrite low_bound_alloc. apply zeq_true.
-Qed.
-
-Lemma low_bound_alloc_other:
- forall b', valid_block m1 b' -> low_bound m2 b' = low_bound m1 b'.
-Proof.
- intros; rewrite low_bound_alloc.
- apply zeq_false. eauto with mem.
-Qed.
-
-Lemma high_bound_alloc:
- forall b', high_bound m2 b' = if zeq b' b then hi else high_bound m1 b'.
-Proof.
- intros. injection ALLOC; intros. rewrite <- H0; unfold high_bound; simpl.
- unfold update. rewrite H. destruct (zeq b' b); auto.
-Qed.
-
-Lemma high_bound_alloc_same:
- high_bound m2 b = hi.
-Proof.
- rewrite high_bound_alloc. apply zeq_true.
-Qed.
-
-Lemma high_bound_alloc_other:
- forall b', valid_block m1 b' -> high_bound m2 b' = high_bound m1 b'.
-Proof.
- intros; rewrite high_bound_alloc.
- apply zeq_false. eauto with mem.
-Qed.
-
-Lemma valid_access_alloc_other:
- forall chunk b' ofs,
- valid_access m1 chunk b' ofs ->
- valid_access m2 chunk b' ofs.
-Proof.
- intros. inv H. constructor; auto with mem.
- rewrite low_bound_alloc_other; auto.
- rewrite high_bound_alloc_other; auto.
-Qed.
-
-Lemma valid_access_alloc_same:
- forall chunk ofs,
- lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) ->
- valid_access m2 chunk b ofs.
-Proof.
- intros. constructor; auto with mem.
- rewrite low_bound_alloc_same; auto.
- rewrite high_bound_alloc_same; auto.
-Qed.
-
-Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem.
-
-Lemma valid_access_alloc_inv:
- forall chunk b' ofs,
- valid_access m2 chunk b' ofs ->
- valid_access m1 chunk b' ofs \/
- (b' = b /\ lo <= ofs /\ ofs + size_chunk chunk <= hi /\ (align_chunk chunk | ofs)).
-Proof.
- intros. inv H.
- elim (valid_block_alloc_inv _ H0); intro.
- subst b'. rewrite low_bound_alloc_same in H1.
- rewrite high_bound_alloc_same in H2.
- right. tauto.
- left. constructor; auto.
- rewrite low_bound_alloc_other in H1; auto.
- rewrite high_bound_alloc_other in H2; auto.
-Qed.
-
-Theorem load_alloc_unchanged:
- forall chunk b' ofs,
- valid_block m1 b' ->
- load chunk m2 b' ofs = load chunk m1 b' ofs.
-Proof.
- intros. unfold load.
- destruct (in_bounds m2 chunk b' ofs).
- elim (valid_access_alloc_inv _ _ _ v). intro.
- rewrite in_bounds_true; auto.
- injection ALLOC; intros. rewrite <- H2; simpl.
- rewrite update_o. auto. rewrite H1. apply sym_not_equal. eauto with mem.
- intros [A [B C]]. subst b'. elimtype False. eauto with mem.
- destruct (in_bounds m1 chunk b' ofs).
- elim n; eauto with mem.
- auto.
-Qed.
-
-Theorem load_alloc_other:
- forall chunk b' ofs v,
- load chunk m1 b' ofs = Some v ->
- load chunk m2 b' ofs = Some v.
-Proof.
- intros. rewrite <- H. apply load_alloc_unchanged. eauto with mem.
-Qed.
-
-Theorem load_alloc_same:
- forall chunk ofs v,
- load chunk m2 b ofs = Some v ->
- v = Vundef.
-Proof.
- intros. destruct (load_inv _ _ _ _ _ H). rewrite H1.
- injection ALLOC; intros. rewrite <- H3; simpl.
- rewrite <- H2. rewrite update_s.
- simpl. rewrite getN_init. destruct chunk; auto.
-Qed.
-
-Theorem load_alloc_same':
- forall chunk ofs,
- lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) ->
- load chunk m2 b ofs = Some Vundef.
-Proof.
- intros. assert (exists v, load chunk m2 b ofs = Some v).
- apply valid_access_load. constructor; eauto with mem.
- rewrite low_bound_alloc_same. auto.
- rewrite high_bound_alloc_same. auto.
- destruct H2 as [v LOAD]. rewrite LOAD. decEq.
- eapply load_alloc_same; eauto.
-Qed.
-
-End ALLOC.
-
-Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem.
-Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem.
-Hint Resolve load_alloc_unchanged: mem.
-
-(** ** Properties related to [free]. *)
-
-Section FREE.
-
-Variable m: mem.
-Variable bf: block.
-
-Lemma valid_block_free_1:
- forall b, valid_block m b -> valid_block (free m bf) b.
-Proof.
- unfold valid_block, free; intros; simpl; auto.
-Qed.
-
-Lemma valid_block_free_2:
- forall b, valid_block (free m bf) b -> valid_block m b.
-Proof.
- unfold valid_block, free; intros; simpl in *; auto.
-Qed.
-
-Hint Resolve valid_block_free_1 valid_block_free_2: mem.
-
-Lemma low_bound_free:
- forall b, b <> bf -> low_bound (free m bf) b = low_bound m b.
-Proof.
- intros. unfold low_bound, free; simpl.
- rewrite update_o; auto.
-Qed.
-
-Lemma high_bound_free:
- forall b, b <> bf -> high_bound (free m bf) b = high_bound m b.
-Proof.
- intros. unfold high_bound, free; simpl.
- rewrite update_o; auto.
-Qed.
-
-Lemma low_bound_free_same:
- forall m b, low_bound (free m b) b = 0.
-Proof.
- intros. unfold low_bound; simpl. rewrite update_s. simpl; omega.
-Qed.
-
-Lemma high_bound_free_same:
- forall m b, high_bound (free m b) b = 0.
-Proof.
- intros. unfold high_bound; simpl. rewrite update_s. simpl; omega.
-Qed.
-
-Lemma valid_access_free_1:
- forall chunk b ofs,
- valid_access m chunk b ofs -> b <> bf ->
- valid_access (free m bf) chunk b ofs.
-Proof.
- intros. inv H. constructor; auto with mem.
- rewrite low_bound_free; auto. rewrite high_bound_free; auto.
-Qed.
-
-Lemma valid_access_free_2:
- forall chunk ofs, ~(valid_access (free m bf) chunk bf ofs).
-Proof.
- intros; red; intros. inv H.
- unfold free, low_bound in H1; simpl in H1. rewrite update_s in H1. simpl in H1.
- unfold free, high_bound in H2; simpl in H2. rewrite update_s in H2. simpl in H2.
- generalize (size_chunk_pos chunk). omega.
-Qed.
-
-Hint Resolve valid_access_free_1 valid_access_free_2: mem.
-
-Lemma valid_access_free_inv:
- forall chunk b ofs,
- valid_access (free m bf) chunk b ofs ->
- valid_access m chunk b ofs /\ b <> bf.
-Proof.
- intros. destruct (eq_block b bf). subst b.
- elim (valid_access_free_2 _ _ H).
- inv H. rewrite low_bound_free in H1; auto.
- rewrite high_bound_free in H2; auto.
- split; auto. constructor; auto with mem.
-Qed.
-
-Theorem load_free:
- forall chunk b ofs,
- b <> bf ->
- load chunk (free m bf) b ofs = load chunk m b ofs.
-Proof.
- intros. unfold load.
- destruct (in_bounds m chunk b ofs).
- rewrite in_bounds_true; auto with mem.
- unfold free; simpl. rewrite update_o; auto.
- destruct (in_bounds (free m bf) chunk b ofs); auto.
- elim n. elim (valid_access_free_inv _ _ _ v); auto.
-Qed.
-
-End FREE.
-
-(** ** Properties related to [free_list] *)
-
-Lemma valid_block_free_list_1:
- forall bl m b, valid_block m b -> valid_block (free_list m bl) b.
-Proof.
- induction bl; simpl; intros. auto.
- apply valid_block_free_1; auto.
-Qed.
-
-Lemma valid_block_free_list_2:
- forall bl m b, valid_block (free_list m bl) b -> valid_block m b.
-Proof.
- induction bl; simpl; intros. auto.
- apply IHbl. apply valid_block_free_2 with a; auto.
-Qed.
-
-Lemma valid_access_free_list:
- forall chunk b ofs m bl,
- valid_access m chunk b ofs -> ~In b bl ->
- valid_access (free_list m bl) chunk b ofs.
-Proof.
- induction bl; simpl; intros. auto.
- apply valid_access_free_1. apply IHbl. auto. intuition. intuition congruence.
-Qed.
-
-Lemma valid_access_free_list_inv:
- forall chunk b ofs m bl,
- valid_access (free_list m bl) chunk b ofs ->
- ~In b bl /\ valid_access m chunk b ofs.
-Proof.
- induction bl; simpl; intros.
- tauto.
- elim (valid_access_free_inv _ _ _ _ _ H); intros.
- elim (IHbl H0); intros.
- intuition congruence.
-Qed.
-
-(** ** Properties related to pointer validity *)
-
-Lemma valid_pointer_valid_access:
- forall m b ofs,
- valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs.
-Proof.
- unfold valid_pointer; intros; split; intros.
- destruct (andb_prop _ _ H). destruct (andb_prop _ _ H0).
- constructor. red. eapply proj_sumbool_true; eauto.
- eapply proj_sumbool_true; eauto.
- change (size_chunk Mint8unsigned) with 1.
- generalize (proj_sumbool_true _ H1). omega.
- simpl. apply Zone_divide.
- inv H. unfold proj_sumbool.
- rewrite zlt_true; auto. rewrite zle_true; auto.
- change (size_chunk Mint8unsigned) with 1 in H2.
- rewrite zlt_true. auto. omega.
-Qed.
-
-Theorem valid_pointer_alloc:
- forall (m1 m2: mem) (lo hi: Z) (b b': block) (ofs: Z),
- alloc m1 lo hi = (m2, b') ->
- valid_pointer m1 b ofs = true ->
- valid_pointer m2 b ofs = true.
-Proof.
- intros. rewrite valid_pointer_valid_access in H0.
- rewrite valid_pointer_valid_access.
- eauto with mem.
-Qed.
-
-Theorem valid_pointer_store:
- forall (chunk: memory_chunk) (m1 m2: mem) (b b': block) (ofs ofs': Z) (v: val),
- store chunk m1 b' ofs' v = Some m2 ->
- valid_pointer m1 b ofs = true -> valid_pointer m2 b ofs = true.
-Proof.
- intros. rewrite valid_pointer_valid_access in H0.
- rewrite valid_pointer_valid_access.
- eauto with mem.
-Qed.
-
-(** * Generic injections between memory states. *)
-
-Section GENERIC_INJECT.
-
-Definition meminj : Type := block -> option (block * Z).
-
-Variable val_inj: meminj -> val -> val -> Prop.
-
-Hypothesis val_inj_undef:
- forall mi, val_inj mi Vundef Vundef.
-
-Definition mem_inj (mi: meminj) (m1 m2: mem) :=
- forall chunk b1 ofs v1 b2 delta,
- mi b1 = Some(b2, delta) ->
- load chunk m1 b1 ofs = Some v1 ->
- exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inj mi v1 v2.
-
-Lemma valid_access_inj:
- forall mi m1 m2 chunk b1 ofs b2 delta,
- mi b1 = Some(b2, delta) ->
- mem_inj mi m1 m2 ->
- valid_access m1 chunk b1 ofs ->
- valid_access m2 chunk b2 (ofs + delta).
-Proof.
- intros.
- assert (exists v1, load chunk m1 b1 ofs = Some v1) by eauto with mem.
- destruct H2 as [v1 LOAD1].
- destruct (H0 _ _ _ _ _ _ H LOAD1) as [v2 [LOAD2 VCP]].
- eauto with mem.
-Qed.
-
-Hint Resolve valid_access_inj: mem.
-
-Lemma store_unmapped_inj:
- forall mi m1 m2 b ofs v chunk m1',
- mem_inj mi m1 m2 ->
- mi b = None ->
- store chunk m1 b ofs v = Some m1' ->
- mem_inj mi m1' m2.
-Proof.
- intros; red; intros.
- assert (load chunk0 m1 b1 ofs0 = Some v1).
- rewrite <- H3; symmetry. eapply load_store_other; eauto.
- left. congruence.
- eapply H; eauto.
-Qed.
-
-Lemma store_outside_inj:
- forall mi m1 m2 chunk b ofs v m2',
- mem_inj mi m1 m2 ->
- (forall b' delta,
- mi b' = Some(b, delta) ->
- high_bound m1 b' + delta <= ofs
- \/ ofs + size_chunk chunk <= low_bound m1 b' + delta) ->
- store chunk m2 b ofs v = Some m2' ->
- mem_inj mi m1 m2'.
-Proof.
- intros; red; intros.
- exploit H; eauto. intros [v2 [LOAD2 VINJ]].
- exists v2; split; auto.
- rewrite <- LOAD2. eapply load_store_other; eauto.
- destruct (eq_block b2 b). subst b2.
- right. generalize (H0 _ _ H2); intro.
- assert (valid_access m1 chunk0 b1 ofs0) by eauto with mem.
- inv H5. omega. auto.
-Qed.
-
-Definition meminj_no_overlap (mi: meminj) (m: mem) : Prop :=
- forall b1 b1' delta1 b2 b2' delta2,
- b1 <> b2 ->
- mi b1 = Some (b1', delta1) ->
- mi b2 = Some (b2', delta2) ->
- b1' <> b2'
- \/ low_bound m b1 >= high_bound m b1
- \/ low_bound m b2 >= high_bound m b2
- \/ high_bound m b1 + delta1 <= low_bound m b2 + delta2
- \/ high_bound m b2 + delta2 <= low_bound m b1 + delta1.
-
-Lemma store_mapped_inj:
- forall mi m1 m2 b1 ofs b2 delta v1 v2 chunk m1',
- mem_inj mi m1 m2 ->
- meminj_no_overlap mi m1 ->
- mi b1 = Some(b2, delta) ->
- store chunk m1 b1 ofs v1 = Some m1' ->
- (forall chunk', size_chunk chunk' = size_chunk chunk ->
- val_inj mi (Val.load_result chunk' v1) (Val.load_result chunk' v2)) ->
- exists m2',
- store chunk m2 b2 (ofs + delta) v2 = Some m2' /\ mem_inj mi m1' m2'.
-Proof.
- intros.
- assert (exists m2', store chunk m2 b2 (ofs + delta) v2 = Some m2') by eauto with mem.
- destruct H4 as [m2' STORE2].
- exists m2'; split. auto.
- red. intros chunk' b1' ofs' v b2' delta' CP LOAD1.
- assert (valid_access m1 chunk' b1' ofs') by eauto with mem.
- generalize (load_store_characterization _ _ _ _ _ _ H2 _ _ _ H4).
- destruct (load_store_classification chunk b1 ofs chunk' b1' ofs');
- intro.
- (* similar *)
- subst b1' ofs'.
- rewrite CP in H1. inv H1.
- rewrite LOAD1 in H5. inv H5.
- exists (Val.load_result chunk' v2). split.
- eapply load_store_similar; eauto.
- auto.
- (* disjoint *)
- rewrite LOAD1 in H5.
- destruct (H _ _ _ _ _ _ CP (sym_equal H5)) as [v2' [LOAD2 VCP]].
- exists v2'. split; auto.
- rewrite <- LOAD2. eapply load_store_other; eauto.
- destruct (eq_block b1 b1'). subst b1'.
- rewrite CP in H1; inv H1.
- right. elim o; [congruence | omega].
- assert (valid_access m1 chunk b1 ofs) by eauto with mem.
- generalize (H0 _ _ _ _ _ _ n H1 CP). intros [A | [A | [A | A]]].
- auto.
- inv H6. generalize (size_chunk_pos chunk). intro. omegaContradiction.
- inv H4. generalize (size_chunk_pos chunk'). intro. omegaContradiction.
- right. inv H4. inv H6. omega.
- (* overlapping *)
- subst b1'. rewrite CP in H1; inv H1.
- assert (exists v2', load chunk' m2' b2 (ofs' + delta) = Some v2') by eauto with mem.
- destruct H1 as [v2' LOAD2'].
- assert (v2' = Vundef). eapply load_store_overlap; eauto.
- omega. omega. omega.
- exists v2'; split. auto.
- replace v with Vundef by congruence. subst v2'. apply val_inj_undef.
- (* mismatch *)
- subst b1' ofs'. rewrite CP in H1; inv H1.
- assert (exists v2', load chunk' m2' b2 (ofs + delta) = Some v2') by eauto with mem.
- destruct H1 as [v2' LOAD2'].
- assert (v2' = Vundef). eapply load_store_mismatch; eauto.
- exists v2'; split. auto.
- replace v with Vundef by congruence. subst v2'. apply val_inj_undef.
-Qed.
-
-Definition inj_offset_aligned (delta: Z) (size: Z) : Prop :=
- forall chunk, size_chunk chunk <= size -> (align_chunk chunk | delta).
-
-Lemma alloc_parallel_inj:
- forall mi m1 m2 lo1 hi1 m1' b1 lo2 hi2 m2' b2 delta,
- mem_inj mi m1 m2 ->
- alloc m1 lo1 hi1 = (m1', b1) ->
- alloc m2 lo2 hi2 = (m2', b2) ->
- mi b1 = Some(b2, delta) ->
- lo2 <= lo1 + delta -> hi1 + delta <= hi2 ->
- inj_offset_aligned delta (hi1 - lo1) ->
- mem_inj mi m1' m2'.
-Proof.
- intros; red; intros.
- exploit (valid_access_alloc_inv m1); eauto with mem.
- intros [A | [A [B [C D]]]].
- assert (load chunk m1 b0 ofs = Some v1).
- rewrite <- H7. symmetry. eapply load_alloc_unchanged; eauto with mem.
- exploit H; eauto. intros [v2 [LOAD2 VINJ]].
- exists v2; split.
- rewrite <- LOAD2. eapply load_alloc_unchanged; eauto with mem.
- auto.
- subst b0. rewrite H2 in H6. inversion H6. subst b3 delta0.
- assert (v1 = Vundef). eapply load_alloc_same with (m1 := m1); eauto.
- subst v1.
- assert (exists v2, load chunk m2' b2 (ofs + delta) = Some v2).
- apply valid_access_load.
- eapply valid_access_alloc_same; eauto. omega. omega.
- apply Zdivide_plus_r; auto. apply H5. omega.
- destruct H8 as [v2 LOAD2].
- assert (v2 = Vundef). eapply load_alloc_same with (m1 := m2); eauto.
- subst v2.
- exists Vundef; split. auto. apply val_inj_undef.
-Qed.
-
-Lemma alloc_right_inj:
- forall mi m1 m2 lo hi b2 m2',
- mem_inj mi m1 m2 ->
- alloc m2 lo hi = (m2', b2) ->
- mem_inj mi m1 m2'.
-Proof.
- intros; red; intros.
- exploit H; eauto. intros [v2 [LOAD2 VINJ]].
- exists v2; split; auto.
- assert (valid_block m2 b0).
- apply valid_access_valid_block with chunk (ofs + delta).
- eauto with mem.
- rewrite <- LOAD2. eapply load_alloc_unchanged; eauto.
-Qed.
-
-Hypothesis val_inj_undef_any:
- forall mi v, val_inj mi Vundef v.
-
-Lemma alloc_left_unmapped_inj:
- forall mi m1 m2 lo hi b1 m1',
- mem_inj mi m1 m2 ->
- alloc m1 lo hi = (m1', b1) ->
- mi b1 = None ->
- mem_inj mi m1' m2.
-Proof.
- intros; red; intros.
- exploit (valid_access_alloc_inv m1); eauto with mem.
- intros [A | [A [B C]]].
- eapply H; eauto.
- rewrite <- H3. symmetry. eapply load_alloc_unchanged; eauto with mem.
- subst b0. congruence.
-Qed.
-
-Lemma alloc_left_mapped_inj:
- forall mi m1 m2 lo hi b1 m1' b2 delta,
- mem_inj mi m1 m2 ->
- alloc m1 lo hi = (m1', b1) ->
- mi b1 = Some(b2, delta) ->
- valid_block m2 b2 ->
- low_bound m2 b2 <= lo + delta -> hi + delta <= high_bound m2 b2 ->
- inj_offset_aligned delta (hi - lo) ->
- mem_inj mi m1' m2.
-Proof.
- intros; red; intros.
- exploit (valid_access_alloc_inv m1); eauto with mem.
- intros [A | [A [B [C D]]]].
- eapply H; eauto.
- rewrite <- H7. symmetry. eapply load_alloc_unchanged; eauto with mem.
- subst b0. rewrite H1 in H6. inversion H6. subst b3 delta0.
- assert (v1 = Vundef). eapply load_alloc_same with (m1 := m1); eauto.
- subst v1.
- assert (exists v2, load chunk m2 b2 (ofs + delta) = Some v2).
- apply valid_access_load. constructor. auto. omega. omega.
- apply Zdivide_plus_r; auto. apply H5. omega.
- destruct H8 as [v2 LOAD2]. exists v2; split. auto.
- apply val_inj_undef_any.
-Qed.
-
-Lemma free_parallel_inj:
- forall mi m1 m2 b1 b2 delta,
- mem_inj mi m1 m2 ->
- mi b1 = Some(b2, delta) ->
- (forall b delta', mi b = Some(b2, delta') -> b = b1) ->
- mem_inj mi (free m1 b1) (free m2 b2).
-Proof.
- intros; red; intros.
- exploit valid_access_free_inv; eauto with mem. intros [A B].
- assert (load chunk m1 b0 ofs = Some v1).
- rewrite <- H3. symmetry. apply load_free. auto.
- exploit H; eauto. intros [v2 [LOAD2 INJ]].
- exists v2; split.
- rewrite <- LOAD2. apply load_free.
- red; intro; subst b3. elim B. eauto.
- auto.
-Qed.
-
-Lemma free_left_inj:
- forall mi m1 m2 b1,
- mem_inj mi m1 m2 ->
- mem_inj mi (free m1 b1) m2.
-Proof.
- intros; red; intros.
- exploit valid_access_free_inv; eauto with mem. intros [A B].
- eapply H; eauto with mem.
- rewrite <- H1; symmetry; eapply load_free; eauto.
-Qed.
-
-Lemma free_list_left_inj:
- forall mi bl m1 m2,
- mem_inj mi m1 m2 ->
- mem_inj mi (free_list m1 bl) m2.
-Proof.
- induction bl; intros; simpl.
- auto.
- apply free_left_inj. auto.
-Qed.
-
-Lemma free_right_inj:
- forall mi m1 m2 b2,
- mem_inj mi m1 m2 ->
- (forall b1 delta chunk ofs,
- mi b1 = Some(b2, delta) -> ~(valid_access m1 chunk b1 ofs)) ->
- mem_inj mi m1 (free m2 b2).
-Proof.
- intros; red; intros.
- assert (b0 <> b2).
- red; intro; subst b0. elim (H0 b1 delta chunk ofs H1).
- eauto with mem.
- exploit H; eauto. intros [v2 [LOAD2 INJ]].
- exists v2; split; auto.
- rewrite <- LOAD2. apply load_free. auto.
-Qed.
-
-Lemma valid_pointer_inj:
- forall mi m1 m2 b1 ofs b2 delta,
- mi b1 = Some(b2, delta) ->
- mem_inj mi m1 m2 ->
- valid_pointer m1 b1 ofs = true ->
- valid_pointer m2 b2 (ofs + delta) = true.
-Proof.
- intros. rewrite valid_pointer_valid_access in H1.
- rewrite valid_pointer_valid_access. eauto with mem.
-Qed.
-
-End GENERIC_INJECT.
-
-(** ** Store extensions *)
-
-(** A store [m2] extends a store [m1] if [m2] can be obtained from [m1]
- by increasing the sizes of the memory blocks of [m1] (decreasing
- the low bounds, increasing the high bounds), while still keeping the
- same contents for block offsets that are valid in [m1]. *)
-
-Definition inject_id : meminj := fun b => Some(b, 0).
-
-Definition val_inj_id (mi: meminj) (v1 v2: val) : Prop := v1 = v2.
-
-Definition extends (m1 m2: mem) :=
- nextblock m1 = nextblock m2 /\ mem_inj val_inj_id inject_id m1 m2.
-
-Theorem extends_refl:
- forall (m: mem), extends m m.
-Proof.
- intros; split. auto.
- red; unfold inject_id; intros. inv H.
- exists v1; split. replace (ofs + 0) with ofs by omega. auto.
- unfold val_inj_id; auto.
-Qed.
-
-Theorem alloc_extends:
- forall (m1 m2 m1' m2': mem) (lo1 hi1 lo2 hi2: Z) (b1 b2: block),
- extends m1 m2 ->
- lo2 <= lo1 -> hi1 <= hi2 ->
- alloc m1 lo1 hi1 = (m1', b1) ->
- alloc m2 lo2 hi2 = (m2', b2) ->
- b1 = b2 /\ extends m1' m2'.
-Proof.
- intros. destruct H.
- assert (b1 = b2).
- transitivity (nextblock m1). eapply alloc_result; eauto.
- symmetry. rewrite H. eapply alloc_result; eauto.
- subst b2. split. auto. split.
- rewrite (nextblock_alloc _ _ _ _ _ H2).
- rewrite (nextblock_alloc _ _ _ _ _ H3).
- congruence.
- eapply alloc_parallel_inj; eauto.
- unfold val_inj_id; auto.
- unfold inject_id; eauto.
- omega. omega.
- red; intros. apply Zdivide_0.
-Qed.
-
-Theorem free_extends:
- forall (m1 m2: mem) (b: block),
- extends m1 m2 ->
- extends (free m1 b) (free m2 b).
-Proof.
- intros. destruct H. split.
- simpl; auto.
- eapply free_parallel_inj; eauto.
- unfold inject_id. eauto.
- unfold inject_id; intros. congruence.
-Qed.
-
-Theorem load_extends:
- forall (chunk: memory_chunk) (m1 m2: mem) (b: block) (ofs: Z) (v: val),
- extends m1 m2 ->
- load chunk m1 b ofs = Some v ->
- load chunk m2 b ofs = Some v.
-Proof.
- intros. destruct H.
- exploit H1; eauto. unfold inject_id. eauto.
- unfold val_inj_id. intros [v2 [LOAD EQ]].
- replace (ofs + 0) with ofs in LOAD by omega. congruence.
-Qed.
-
-Theorem store_within_extends:
- forall (chunk: memory_chunk) (m1 m2 m1': mem) (b: block) (ofs: Z) (v: val),
- extends m1 m2 ->
- store chunk m1 b ofs v = Some m1' ->
- exists m2', store chunk m2 b ofs v = Some m2' /\ extends m1' m2'.
-Proof.
- intros. destruct H.
- exploit store_mapped_inj; eauto.
- unfold val_inj_id; eauto.
- unfold meminj_no_overlap, inject_id; intros.
- inv H3. inv H4. auto.
- unfold inject_id; eauto.
- unfold val_inj_id; intros. eauto.
- intros [m2' [STORE MINJ]].
- exists m2'; split.
- replace (ofs + 0) with ofs in STORE by omega. auto.
- split.
- rewrite (nextblock_store _ _ _ _ _ _ H0).
- rewrite (nextblock_store _ _ _ _ _ _ STORE).
- auto.
- auto.
-Qed.
-
-Theorem store_outside_extends:
- forall (chunk: memory_chunk) (m1 m2 m2': mem) (b: block) (ofs: Z) (v: val),
- extends m1 m2 ->
- ofs + size_chunk chunk <= low_bound m1 b \/ high_bound m1 b <= ofs ->
- store chunk m2 b ofs v = Some m2' ->
- extends m1 m2'.
-Proof.
- intros. destruct H. split.
- rewrite (nextblock_store _ _ _ _ _ _ H1). auto.
- eapply store_outside_inj; eauto.
- unfold inject_id; intros. inv H3. omega.
-Qed.
-
-Theorem valid_pointer_extends:
- forall m1 m2 b ofs,
- extends m1 m2 -> valid_pointer m1 b ofs = true ->
- valid_pointer m2 b ofs = true.
-Proof.
- intros. destruct H.
- replace ofs with (ofs + 0) by omega.
- apply valid_pointer_inj with val_inj_id inject_id m1 b; auto.
-Qed.
-
-(** * The ``less defined than'' relation over memory states *)
-
-(** A memory state [m1] is less defined than [m2] if, for all addresses,
- the value [v1] read in [m1] at this address is less defined than
- the value [v2] read in [m2], that is, either [v1 = v2] or [v1 = Vundef]. *)
-
-Definition val_inj_lessdef (mi: meminj) (v1 v2: val) : Prop :=
- Val.lessdef v1 v2.
-
-Definition lessdef (m1 m2: mem) : Prop :=
- nextblock m1 = nextblock m2 /\
- mem_inj val_inj_lessdef inject_id m1 m2.
-
-Lemma lessdef_refl:
- forall m, lessdef m m.
-Proof.
- intros; split. auto.
- red; intros. unfold inject_id in H. inv H.
- exists v1; split. replace (ofs + 0) with ofs by omega. auto.
- red. constructor.
-Qed.
-
-Lemma load_lessdef:
- forall m1 m2 chunk b ofs v1,
- lessdef m1 m2 -> load chunk m1 b ofs = Some v1 ->
- exists v2, load chunk m2 b ofs = Some v2 /\ Val.lessdef v1 v2.
-Proof.
- intros. destruct H.
- exploit H1; eauto. unfold inject_id. eauto.
- intros [v2 [LOAD INJ]]. exists v2; split.
- replace ofs with (ofs + 0) by omega. auto.
- auto.
-Qed.
-
-Lemma loadv_lessdef:
- forall m1 m2 chunk addr1 addr2 v1,
- lessdef m1 m2 -> Val.lessdef addr1 addr2 ->
- loadv chunk m1 addr1 = Some v1 ->
- exists v2, loadv chunk m2 addr2 = Some v2 /\ Val.lessdef v1 v2.
-Proof.
- intros. inv H0.
- destruct addr2; simpl in *; try discriminate.
- eapply load_lessdef; eauto.
- simpl in H1; discriminate.
-Qed.
-
-Lemma store_lessdef:
- forall m1 m2 chunk b ofs v1 v2 m1',
- lessdef m1 m2 -> Val.lessdef v1 v2 ->
- store chunk m1 b ofs v1 = Some m1' ->
- exists m2', store chunk m2 b ofs v2 = Some m2' /\ lessdef m1' m2'.
-Proof.
- intros. destruct H.
- exploit store_mapped_inj; eauto.
- unfold val_inj_lessdef; intros; constructor.
- red; unfold inject_id; intros. inv H4. inv H5. auto.
- unfold inject_id; eauto.
- unfold val_inj_lessdef; intros.
- apply Val.load_result_lessdef. eexact H0.
- intros [m2' [STORE MINJ]].
- exists m2'; split. replace ofs with (ofs + 0) by omega. auto.
- split.
- rewrite (nextblock_store _ _ _ _ _ _ H1).
- rewrite (nextblock_store _ _ _ _ _ _ STORE).
- auto.
- auto.
-Qed.
-
-Lemma storev_lessdef:
- forall m1 m2 chunk addr1 v1 addr2 v2 m1',
- lessdef m1 m2 -> Val.lessdef addr1 addr2 -> Val.lessdef v1 v2 ->
- storev chunk m1 addr1 v1 = Some m1' ->
- exists m2', storev chunk m2 addr2 v2 = Some m2' /\ lessdef m1' m2'.
-Proof.
- intros. inv H0.
- destruct addr2; simpl in H2; try discriminate.
- simpl. eapply store_lessdef; eauto.
- discriminate.
-Qed.
-
-Lemma alloc_lessdef:
- forall m1 m2 lo hi b1 m1' b2 m2',
- lessdef m1 m2 -> alloc m1 lo hi = (m1', b1) -> alloc m2 lo hi = (m2', b2) ->
- b1 = b2 /\ lessdef m1' m2'.
-Proof.
- intros. destruct H.
- assert (b1 = b2).
- transitivity (nextblock m1). eapply alloc_result; eauto.
- symmetry. rewrite H. eapply alloc_result; eauto.
- subst b2. split. auto. split.
- rewrite (nextblock_alloc _ _ _ _ _ H0).
- rewrite (nextblock_alloc _ _ _ _ _ H1).
- congruence.
- eapply alloc_parallel_inj; eauto.
- unfold val_inj_lessdef; auto.
- unfold inject_id; eauto.
- omega. omega.
- red; intros. apply Zdivide_0.
-Qed.
-
-Lemma free_lessdef:
- forall m1 m2 b, lessdef m1 m2 -> lessdef (free m1 b) (free m2 b).
-Proof.
- intros. destruct H. split.
- simpl; auto.
- eapply free_parallel_inj; eauto.
- unfold inject_id. eauto.
- unfold inject_id; intros. congruence.
-Qed.
-
-Lemma free_left_lessdef:
- forall m1 m2 b,
- lessdef m1 m2 -> lessdef (free m1 b) m2.
-Proof.
- intros. destruct H. split.
- rewrite <- H. auto.
- apply free_left_inj; auto.
-Qed.
-
-Lemma free_right_lessdef:
- forall m1 m2 b,
- lessdef m1 m2 -> low_bound m1 b >= high_bound m1 b ->
- lessdef m1 (free m2 b).
-Proof.
- intros. destruct H. unfold lessdef. split.
- rewrite H. auto.
- apply free_right_inj; auto. intros. unfold inject_id in H2. inv H2.
- red; intro. inv H2. generalize (size_chunk_pos chunk); intro. omega.
-Qed.
-
-Lemma valid_block_lessdef:
- forall m1 m2 b, lessdef m1 m2 -> valid_block m1 b -> valid_block m2 b.
-Proof.
- unfold valid_block. intros. destruct H. rewrite <- H; auto.
-Qed.
-
-Lemma valid_pointer_lessdef:
- forall m1 m2 b ofs,
- lessdef m1 m2 -> valid_pointer m1 b ofs = true -> valid_pointer m2 b ofs = true.
-Proof.
- intros. destruct H.
- replace ofs with (ofs + 0) by omega.
- apply valid_pointer_inj with val_inj_lessdef inject_id m1 b; auto.
-Qed.
-
-(** ** Memory injections *)
-
-(** A memory injection [f] is a function from addresses to either [None]
- or [Some] of an address and an offset. It defines a correspondence
- between the blocks of two memory states [m1] and [m2]:
-- if [f b = None], the block [b] of [m1] has no equivalent in [m2];
-- if [f b = Some(b', ofs)], the block [b] of [m2] corresponds to
- a sub-block at offset [ofs] of the block [b'] in [m2].
-*)
-
-(** A memory injection defines a relation between values that is the
- identity relation, except for pointer values which are shifted
- as prescribed by the memory injection. *)
-
-Inductive val_inject (mi: meminj): val -> val -> Prop :=
- | val_inject_int:
- forall i, val_inject mi (Vint i) (Vint i)
- | val_inject_float:
- forall f, val_inject mi (Vfloat f) (Vfloat f)
- | val_inject_ptr:
- forall b1 ofs1 b2 ofs2 x,
- mi b1 = Some (b2, x) ->
- ofs2 = Int.add ofs1 (Int.repr x) ->
- val_inject mi (Vptr b1 ofs1) (Vptr b2 ofs2)
- | val_inject_undef: forall v,
- val_inject mi Vundef v.
-
-Hint Resolve val_inject_int val_inject_float val_inject_ptr
- val_inject_undef.
-
-Inductive val_list_inject (mi: meminj): list val -> list val-> Prop:=
- | val_nil_inject :
- val_list_inject mi nil nil
- | val_cons_inject : forall v v' vl vl' ,
- val_inject mi v v' -> val_list_inject mi vl vl'->
- val_list_inject mi (v :: vl) (v' :: vl').
-
-Hint Resolve val_nil_inject val_cons_inject.
-
-(** A memory state [m1] injects into another memory state [m2] via the
- memory injection [f] if the following conditions hold:
-- loads in [m1] must have matching loads in [m2] in the sense
- of the [mem_inj] predicate;
-- unallocated blocks in [m1] must be mapped to [None] by [f];
-- if [f b = Some(b', delta)], [b'] must be valid in [m2];
-- distinct blocks in [m1] are mapped to non-overlapping sub-blocks in [m2];
-- the sizes of [m2]'s blocks are representable with signed machine integers;
-- the offsets [delta] are representable with signed machine integers.
-*)
-
-Record mem_inject (f: meminj) (m1 m2: mem) : Prop :=
- mk_mem_inject {
- mi_inj:
- mem_inj val_inject f m1 m2;
- mi_freeblocks:
- forall b, ~(valid_block m1 b) -> f b = None;
- mi_mappedblocks:
- forall b b' delta, f b = Some(b', delta) -> valid_block m2 b';
- mi_no_overlap:
- meminj_no_overlap f m1;
- mi_range_1:
- forall b b' delta,
- f b = Some(b', delta) ->
- Int.min_signed <= delta <= Int.max_signed;
- mi_range_2:
- forall b b' delta,
- f b = Some(b', delta) ->
- delta = 0 \/ (Int.min_signed <= low_bound m2 b' /\ high_bound m2 b' <= Int.max_signed)
- }.
-
-
-(** The following lemmas establish the absence of machine integer overflow
- during address computations. *)
-
-Lemma address_inject:
- forall f m1 m2 chunk b1 ofs1 b2 delta,
- mem_inject f m1 m2 ->
- valid_access m1 chunk b1 (Int.signed ofs1) ->
- f b1 = Some (b2, delta) ->
- Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta.
-Proof.
- intros. inversion H.
- elim (mi_range_4 _ _ _ H1); intro.
- (* delta = 0 *)
- subst delta. change (Int.repr 0) with Int.zero.
- rewrite Int.add_zero. omega.
- (* delta <> 0 *)
- rewrite Int.add_signed.
- repeat rewrite Int.signed_repr. auto.
- eauto.
- assert (valid_access m2 chunk b2 (Int.signed ofs1 + delta)).
- eapply valid_access_inj; eauto.
- inv H3. generalize (size_chunk_pos chunk); omega.
- eauto.
-Qed.
-
-Lemma valid_pointer_inject_no_overflow:
- forall f m1 m2 b ofs b' x,
- mem_inject f m1 m2 ->
- valid_pointer m1 b (Int.signed ofs) = true ->
- f b = Some(b', x) ->
- Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed.
-Proof.
- intros. inv H. rewrite valid_pointer_valid_access in H0.
- assert (valid_access m2 Mint8unsigned b' (Int.signed ofs + x)).
- eapply valid_access_inj; eauto.
- inv H. change (size_chunk Mint8unsigned) with 1 in H4.
- rewrite Int.signed_repr; eauto.
- exploit mi_range_4; eauto. intros [A | [A B]].
- subst x. rewrite Zplus_0_r. apply Int.signed_range.
- omega.
-Qed.
-
-Lemma valid_pointer_inject:
- forall f m1 m2 b ofs b' ofs',
- mem_inject f m1 m2 ->
- valid_pointer m1 b (Int.signed ofs) = true ->
- val_inject f (Vptr b ofs) (Vptr b' ofs') ->
- valid_pointer m2 b' (Int.signed ofs') = true.
-Proof.
- intros. inv H1.
- exploit valid_pointer_inject_no_overflow; eauto. intro NOOV.
- inv H. rewrite Int.add_signed. rewrite Int.signed_repr; auto.
- rewrite Int.signed_repr; eauto.
- eapply valid_pointer_inj; eauto.
-Qed.
-
-Lemma different_pointers_inject:
- forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
- mem_inject f m m' ->
- b1 <> b2 ->
- valid_pointer m b1 (Int.signed ofs1) = true ->
- valid_pointer m b2 (Int.signed ofs2) = true ->
- f b1 = Some (b1', delta1) ->
- f b2 = Some (b2', delta2) ->
- b1' <> b2' \/
- Int.signed (Int.add ofs1 (Int.repr delta1)) <>
- Int.signed (Int.add ofs2 (Int.repr delta2)).
-Proof.
- intros.
- rewrite valid_pointer_valid_access in H1.
- rewrite valid_pointer_valid_access in H2.
- rewrite (address_inject _ _ _ _ _ _ _ _ H H1 H3).
- rewrite (address_inject _ _ _ _ _ _ _ _ H H2 H4).
- inv H1. simpl in H7. inv H2. simpl in H10.
- exploit (mi_no_overlap _ _ _ H); eauto.
- intros [A | [A | [A | [A | A]]]].
- auto. omegaContradiction. omegaContradiction.
- right. omega. right. omega.
-Qed.
-
-(** Relation between injections and loads. *)
-
-Lemma load_inject:
- forall f m1 m2 chunk b1 ofs b2 delta v1,
- mem_inject f m1 m2 ->
- load chunk m1 b1 ofs = Some v1 ->
- f b1 = Some (b2, delta) ->
- exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2.
-Proof.
- intros. inversion H.
- eapply mi_inj0; eauto.
-Qed.
-
-Lemma loadv_inject:
- forall f m1 m2 chunk a1 a2 v1,
- mem_inject f m1 m2 ->
- loadv chunk m1 a1 = Some v1 ->
- val_inject f a1 a2 ->
- exists v2, loadv chunk m2 a2 = Some v2 /\ val_inject f v1 v2.
-Proof.
- intros. inv H1; simpl in H0; try discriminate.
- exploit load_inject; eauto. intros [v2 [LOAD INJ]].
- exists v2; split; auto. simpl.
- replace (Int.signed (Int.add ofs1 (Int.repr x)))
- with (Int.signed ofs1 + x).
- auto. symmetry. eapply address_inject; eauto with mem.
-Qed.
-
-(** Relation between injections and stores. *)
-
-Inductive val_content_inject (f: meminj): memory_chunk -> val -> val -> Prop :=
- | val_content_inject_base:
- forall chunk v1 v2,
- val_inject f v1 v2 ->
- val_content_inject f chunk v1 v2
- | val_content_inject_8:
- forall chunk n1 n2,
- chunk = Mint8unsigned \/ chunk = Mint8signed ->
- Int.zero_ext 8 n1 = Int.zero_ext 8 n2 ->
- val_content_inject f chunk (Vint n1) (Vint n2)
- | val_content_inject_16:
- forall chunk n1 n2,
- chunk = Mint16unsigned \/ chunk = Mint16signed ->
- Int.zero_ext 16 n1 = Int.zero_ext 16 n2 ->
- val_content_inject f chunk (Vint n1) (Vint n2)
- | val_content_inject_32:
- forall f1 f2,
- Float.singleoffloat f1 = Float.singleoffloat f2 ->
- val_content_inject f Mfloat32 (Vfloat f1) (Vfloat f2).
-
-Hint Resolve val_content_inject_base.
-
-Lemma load_result_inject:
- forall f chunk v1 v2 chunk',
- val_content_inject f chunk v1 v2 ->
- size_chunk chunk = size_chunk chunk' ->
- val_inject f (Val.load_result chunk' v1) (Val.load_result chunk' v2).
-Proof.
- intros. inv H; simpl.
- inv H1; destruct chunk'; simpl; econstructor; eauto.
-
- elim H1; intro; subst chunk;
- destruct chunk'; simpl in H0; try discriminate; simpl.
- replace (Int.sign_ext 8 n1) with (Int.sign_ext 8 n2).
- constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto.
- rewrite H2. constructor.
- replace (Int.sign_ext 8 n1) with (Int.sign_ext 8 n2).
- constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto.
- rewrite H2. constructor.
-
- elim H1; intro; subst chunk;
- destruct chunk'; simpl in H0; try discriminate; simpl.
- replace (Int.sign_ext 16 n1) with (Int.sign_ext 16 n2).
- constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto.
- rewrite H2. constructor.
- replace (Int.sign_ext 16 n1) with (Int.sign_ext 16 n2).
- constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto.
- rewrite H2. constructor.
-
- destruct chunk'; simpl in H0; try discriminate; simpl.
- constructor. rewrite H1; constructor.
-Qed.
-
-Lemma store_mapped_inject_1 :
- forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2,
- mem_inject f m1 m2 ->
- store chunk m1 b1 ofs v1 = Some n1 ->
- f b1 = Some (b2, delta) ->
- val_content_inject f chunk v1 v2 ->
- exists n2,
- store chunk m2 b2 (ofs + delta) v2 = Some n2
- /\ mem_inject f n1 n2.
-Proof.
- intros. inversion H.
- exploit store_mapped_inj; eauto.
- intros; constructor.
- intros. apply load_result_inject with chunk; eauto.
- intros [n2 [STORE MINJ]].
- exists n2; split. auto. constructor.
- (* inj *)
- auto.
- (* freeblocks *)
- intros. apply mi_freeblocks0. red; intro. elim H3. eauto with mem.
- (* mappedblocks *)
- intros. eauto with mem.
- (* no_overlap *)
- red; intros.
- repeat rewrite (low_bound_store _ _ _ _ _ _ H0).
- repeat rewrite (high_bound_store _ _ _ _ _ _ H0).
- eapply mi_no_overlap0; eauto.
- (* range *)
- auto.
- intros.
- repeat rewrite (low_bound_store _ _ _ _ _ _ STORE).
- repeat rewrite (high_bound_store _ _ _ _ _ _ STORE).
- eapply mi_range_4; eauto.
-Qed.
-
-Lemma store_mapped_inject:
- forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2,
- mem_inject f m1 m2 ->
- store chunk m1 b1 ofs v1 = Some n1 ->
- f b1 = Some (b2, delta) ->
- val_inject f v1 v2 ->
- exists n2,
- store chunk m2 b2 (ofs + delta) v2 = Some n2
- /\ mem_inject f n1 n2.
-Proof.
- intros. eapply store_mapped_inject_1; eauto.
-Qed.
-
-Lemma store_unmapped_inject:
- forall f chunk m1 b1 ofs v1 n1 m2,
- mem_inject f m1 m2 ->
- store chunk m1 b1 ofs v1 = Some n1 ->
- f b1 = None ->
- mem_inject f n1 m2.
-Proof.
- intros. inversion H.
- constructor.
- (* inj *)
- eapply store_unmapped_inj; eauto.
- (* freeblocks *)
- intros. apply mi_freeblocks0. red; intros; elim H2; eauto with mem.
- (* mappedblocks *)
- intros. eapply mi_mappedblocks0; eauto with mem.
- (* no_overlap *)
- red; intros.
- repeat rewrite (low_bound_store _ _ _ _ _ _ H0).
- repeat rewrite (high_bound_store _ _ _ _ _ _ H0).
- eapply mi_no_overlap0; eauto.
- (* range *)
- auto. auto.
-Qed.
-
-Lemma storev_mapped_inject_1:
- forall f chunk m1 a1 v1 n1 m2 a2 v2,
- mem_inject f m1 m2 ->
- storev chunk m1 a1 v1 = Some n1 ->
- val_inject f a1 a2 ->
- val_content_inject f chunk v1 v2 ->
- exists n2,
- storev chunk m2 a2 v2 = Some n2 /\ mem_inject f n1 n2.
-Proof.
- intros. inv H1; simpl in H0; try discriminate.
- simpl. replace (Int.signed (Int.add ofs1 (Int.repr x)))
- with (Int.signed ofs1 + x).
- eapply store_mapped_inject_1; eauto.
- symmetry. eapply address_inject; eauto with mem.
-Qed.
-
-Lemma storev_mapped_inject:
- forall f chunk m1 a1 v1 n1 m2 a2 v2,
- mem_inject f m1 m2 ->
- storev chunk m1 a1 v1 = Some n1 ->
- val_inject f a1 a2 ->
- val_inject f v1 v2 ->
- exists n2,
- storev chunk m2 a2 v2 = Some n2 /\ mem_inject f n1 n2.
-Proof.
- intros. eapply storev_mapped_inject_1; eauto.
-Qed.
-
-(** Relation between injections and [free] *)
-
-Lemma meminj_no_overlap_free:
- forall mi m b,
- meminj_no_overlap mi m ->
- meminj_no_overlap mi (free m b).
-Proof.
- intros; red; intros.
- assert (low_bound (free m b) b >= high_bound (free m b) b).
- rewrite low_bound_free_same; rewrite high_bound_free_same; auto.
- omega.
- destruct (eq_block b1 b); destruct (eq_block b2 b); subst; auto.
- repeat (rewrite low_bound_free; auto).
- repeat (rewrite high_bound_free; auto).
-Qed.
-
-Lemma meminj_no_overlap_free_list:
- forall mi m bl,
- meminj_no_overlap mi m ->
- meminj_no_overlap mi (free_list m bl).
-Proof.
- induction bl; simpl; intros. auto.
- apply meminj_no_overlap_free. auto.
-Qed.
-
-Lemma free_inject:
- forall f m1 m2 l b,
- (forall b1 delta, f b1 = Some(b, delta) -> In b1 l) ->
- mem_inject f m1 m2 ->
- mem_inject f (free_list m1 l) (free m2 b).
-Proof.
- intros. inversion H0. constructor.
- (* inj *)
- apply free_right_inj. apply free_list_left_inj. auto.
- intros; red; intros.
- elim (valid_access_free_list_inv _ _ _ _ _ H2); intros.
- elim H3; eauto.
- (* freeblocks *)
- intros. apply mi_freeblocks0. red; intro; elim H1.
- apply valid_block_free_list_1; auto.
- (* mappedblocks *)
- intros. apply valid_block_free_1. eauto.
- (* overlap *)
- apply meminj_no_overlap_free_list; auto.
- (* range *)
- auto.
- intros. destruct (eq_block b' b). subst b'.
- rewrite low_bound_free_same; rewrite high_bound_free_same.
- right; compute; intuition congruence.
- rewrite low_bound_free; auto. rewrite high_bound_free; auto.
- eauto.
-Qed.
-
-(** Monotonicity properties of memory injections. *)
-
-Definition inject_incr (f1 f2: meminj) : Prop :=
- forall b, f1 b = f2 b \/ f1 b = None.
-
-Lemma inject_incr_refl :
- forall f , inject_incr f f .
-Proof. unfold inject_incr . intros. left . auto . Qed.
-
-Lemma inject_incr_trans :
- forall f1 f2 f3,
- inject_incr f1 f2 -> inject_incr f2 f3 -> inject_incr f1 f3 .
-Proof .
- unfold inject_incr; intros.
- generalize (H b); generalize (H0 b); intuition congruence.
-Qed.
-
-Lemma val_inject_incr:
- forall f1 f2 v v',
- inject_incr f1 f2 ->
- val_inject f1 v v' ->
- val_inject f2 v v'.
-Proof.
- intros. inversion H0.
- constructor.
- constructor.
- elim (H b1); intro.
- apply val_inject_ptr with x. congruence. auto.
- congruence.
- constructor.
-Qed.
-
-Lemma val_list_inject_incr:
- forall f1 f2 vl vl' ,
- inject_incr f1 f2 -> val_list_inject f1 vl vl' ->
- val_list_inject f2 vl vl'.
-Proof.
- induction vl; intros; inv H0. auto.
- constructor. eapply val_inject_incr; eauto. auto.
-Qed.
-
-Hint Resolve inject_incr_refl val_inject_incr val_list_inject_incr.
-
-(** Properties of injections and allocations. *)
-
-Definition extend_inject
- (b: block) (x: option (block * Z)) (f: meminj) : meminj :=
- fun (b': block) => if zeq b' b then x else f b'.
-
-Lemma extend_inject_incr:
- forall f b x,
- f b = None ->
- inject_incr f (extend_inject b x f).
-Proof.
- intros; red; intros. unfold extend_inject.
- destruct (zeq b0 b). subst b0; auto. auto.
-Qed.
-
-Lemma alloc_right_inject:
- forall f m1 m2 lo hi m2' b,
- mem_inject f m1 m2 ->
- alloc m2 lo hi = (m2', b) ->
- mem_inject f m1 m2'.
-Proof.
- intros. inversion H. constructor.
- eapply alloc_right_inj; eauto.
- auto.
- intros. eauto with mem.
- auto.
- auto.
- intros. replace (low_bound m2' b') with (low_bound m2 b').
- replace (high_bound m2' b') with (high_bound m2 b').
- eauto.
- symmetry. eapply high_bound_alloc_other; eauto.
- symmetry. eapply low_bound_alloc_other; eauto.
-Qed.
-
-Lemma alloc_unmapped_inject:
- forall f m1 m2 lo hi m1' b,
- mem_inject f m1 m2 ->
- alloc m1 lo hi = (m1', b) ->
- mem_inject (extend_inject b None f) m1' m2 /\
- inject_incr f (extend_inject b None f).
-Proof.
- intros. inversion H.
- assert (inject_incr f (extend_inject b None f)).
- apply extend_inject_incr. apply mi_freeblocks0. eauto with mem.
- split; auto. constructor.
- (* inj *)
- eapply alloc_left_unmapped_inj; eauto.
- red; intros. unfold extend_inject in H2.
- destruct (zeq b1 b). congruence.
- exploit mi_inj0; eauto. intros [v2 [LOAD VINJ]].
- exists v2; split. auto.
- apply val_inject_incr with f; auto.
- unfold extend_inject. apply zeq_true.
- (* freeblocks *)
- intros. unfold extend_inject. destruct (zeq b0 b). auto.
- apply mi_freeblocks0; red; intro. elim H2. eauto with mem.
- (* mappedblocks *)
- intros. unfold extend_inject in H2. destruct (zeq b0 b).
- discriminate. eauto.
- (* overlap *)
- red; unfold extend_inject, update; intros.
- repeat rewrite (low_bound_alloc _ _ _ _ _ H0).
- repeat rewrite (high_bound_alloc _ _ _ _ _ H0).
- destruct (zeq b1 b); try discriminate.
- destruct (zeq b2 b); try discriminate.
- eauto.
- (* range *)
- unfold extend_inject; intros.
- destruct (zeq b0 b). discriminate. eauto.
- unfold extend_inject; intros.
- destruct (zeq b0 b). discriminate. eauto.
-Qed.
-
-Lemma alloc_mapped_inject:
- forall f m1 m2 lo hi m1' b b' ofs,
- mem_inject f m1 m2 ->
- alloc m1 lo hi = (m1', b) ->
- valid_block m2 b' ->
- Int.min_signed <= ofs <= Int.max_signed ->
- Int.min_signed <= low_bound m2 b' ->
- high_bound m2 b' <= Int.max_signed ->
- low_bound m2 b' <= lo + ofs ->
- hi + ofs <= high_bound m2 b' ->
- inj_offset_aligned ofs (hi-lo) ->
- (forall b0 ofs0,
- f b0 = Some (b', ofs0) ->
- high_bound m1 b0 + ofs0 <= lo + ofs \/
- hi + ofs <= low_bound m1 b0 + ofs0) ->
- mem_inject (extend_inject b (Some (b', ofs)) f) m1' m2 /\
- inject_incr f (extend_inject b (Some (b', ofs)) f).
-Proof.
- intros. inversion H.
- assert (inject_incr f (extend_inject b (Some (b', ofs)) f)).
- apply extend_inject_incr. apply mi_freeblocks0. eauto with mem.
- split; auto.
- constructor.
- (* inj *)
- eapply alloc_left_mapped_inj; eauto.
- red; intros. unfold extend_inject in H10.
- rewrite zeq_false in H10.
- exploit mi_inj0; eauto. intros [v2 [LOAD VINJ]].
- exists v2; split. auto. eapply val_inject_incr; eauto.
- eauto with mem.
- unfold extend_inject. apply zeq_true.
- (* freeblocks *)
- intros. unfold extend_inject. rewrite zeq_false.
- apply mi_freeblocks0. red; intro. elim H10; eauto with mem.
- apply sym_not_equal; eauto with mem.
- (* mappedblocks *)
- unfold extend_inject; intros.
- destruct (zeq b0 b). inv H10. auto. eauto.
- (* overlap *)
- red; unfold extend_inject, update; intros.
- repeat rewrite (low_bound_alloc _ _ _ _ _ H0).
- repeat rewrite (high_bound_alloc _ _ _ _ _ H0).
- destruct (zeq b1 b); [inv H11|idtac];
- (destruct (zeq b2 b); [inv H12|idtac]).
- congruence.
- destruct (zeq b1' b2'). subst b2'. generalize (H8 _ _ H12). tauto. auto.
- destruct (zeq b1' b2'). subst b2'. generalize (H8 _ _ H11). tauto. auto.
- eauto.
- (* range *)
- unfold extend_inject; intros.
- destruct (zeq b0 b). inv H10. auto. eauto.
- unfold extend_inject; intros.
- destruct (zeq b0 b). inv H10. auto. eauto.
-Qed.
-
-Lemma alloc_parallel_inject:
- forall f m1 m2 lo hi m1' m2' b1 b2,
- mem_inject f m1 m2 ->
- alloc m1 lo hi = (m1', b1) ->
- alloc m2 lo hi = (m2', b2) ->
- Int.min_signed <= lo -> hi <= Int.max_signed ->
- mem_inject (extend_inject b1 (Some(b2, 0)) f) m1' m2' /\
- inject_incr f (extend_inject b1 (Some(b2, 0)) f).
-Proof.
- intros.
- eapply alloc_mapped_inject; eauto.
- eapply alloc_right_inject; eauto.
- eauto with mem.
- compute; intuition congruence.
- rewrite (low_bound_alloc_same _ _ _ _ _ H1). auto.
- rewrite (high_bound_alloc_same _ _ _ _ _ H1). auto.
- rewrite (low_bound_alloc_same _ _ _ _ _ H1). omega.
- rewrite (high_bound_alloc_same _ _ _ _ _ H1). omega.
- red; intros. apply Zdivide_0.
- intros. elimtype False. inv H.
- exploit mi_mappedblocks0; eauto.
- change (~ valid_block m2 b2). eauto with mem.
-Qed.
-
-Definition meminj_init (m: mem) : meminj :=
- fun (b: block) => if zlt b m.(nextblock) then Some(b, 0) else None.
-
-Definition mem_inject_neutral (m: mem) : Prop :=
- forall f chunk b ofs v,
- load chunk m b ofs = Some v -> val_inject f v v.
-
-Lemma init_inject:
- forall m,
- mem_inject_neutral m ->
- mem_inject (meminj_init m) m m.
-Proof.
- intros; constructor.
- (* inj *)
- red; intros. unfold meminj_init in H0.
- destruct (zlt b1 (nextblock m)); inversion H0.
- subst b2 delta. exists v1; split.
- rewrite Zplus_0_r. auto. eapply H; eauto.
- (* free blocks *)
- unfold valid_block, meminj_init; intros.
- apply zlt_false. omega.
- (* mapped blocks *)
- unfold valid_block, meminj_init; intros.
- destruct (zlt b (nextblock m)); inversion H0. subst b'; auto.
- (* overlap *)
- red; unfold meminj_init; intros.
- destruct (zlt b1 (nextblock m)); inversion H1.
- destruct (zlt b2 (nextblock m)); inversion H2.
- left; congruence.
- (* range *)
- unfold meminj_init; intros.
- destruct (zlt b (nextblock m)); inversion H0. subst delta.
- compute; intuition congruence.
- unfold meminj_init; intros.
- destruct (zlt b (nextblock m)); inversion H0. subst delta.
- auto.
-Qed.
-
-Remark getN_setN_inject:
- forall f m v n1 p1 n2 p2,
- val_inject f (getN n2 p2 m) (getN n2 p2 m) ->
- val_inject f v v ->
- val_inject f (getN n2 p2 (setN n1 p1 v m))
- (getN n2 p2 (setN n1 p1 v m)).
-Proof.
- intros.
- destruct (getN_setN_characterization m v n1 p1 n2 p2)
- as [A | [A | A]]; rewrite A; auto.
-Qed.
-
-Remark getN_contents_init_data_inject:
- forall f n ofs id pos,
- val_inject f (getN n ofs (contents_init_data pos id))
- (getN n ofs (contents_init_data pos id)).
-Proof.
- induction id; simpl; intros.
- repeat rewrite getN_init. constructor.
- destruct a; auto; apply getN_setN_inject; auto.
-Qed.
-
-Lemma alloc_init_data_neutral:
- forall m id m' b,
- mem_inject_neutral m ->
- alloc_init_data m id = (m', b) ->
- mem_inject_neutral m'.
-Proof.
- intros. injection H0; intros A B.
- red; intros.
- exploit load_inv; eauto. intros [C D].
- rewrite <- B in D; simpl in D. rewrite A in D.
- unfold update in D. destruct (zeq b0 b).
- subst b0. rewrite D. simpl.
- apply load_result_inject with chunk. constructor.
- apply getN_contents_init_data_inject. auto.
- apply H with chunk b0 ofs. unfold load.
- rewrite in_bounds_true. congruence.
- inversion C. constructor.
- generalize H2. unfold valid_block. rewrite <- B; simpl.
- rewrite A. unfold block in n; intros. omega.
- replace (low_bound m b0) with (low_bound m' b0). auto.
- unfold low_bound; rewrite <- B; simpl; rewrite A. rewrite update_o; auto.
- replace (high_bound m b0) with (high_bound m' b0). auto.
- unfold high_bound; rewrite <- B; simpl; rewrite A. rewrite update_o; auto.
- auto.
-Qed.
-
-(** ** Memory shifting *)
-
-(** A special case of memory injection where blocks are not coalesced:
- each source block injects in a distinct target block. *)
-
-Definition memshift := block -> option Z.
-
-Definition meminj_of_shift (mi: memshift) : meminj :=
- fun b => match mi b with None => None | Some x => Some (b, x) end.
-
-Definition val_shift (mi: memshift) (v1 v2: val): Prop :=
- val_inject (meminj_of_shift mi) v1 v2.
-
-Record mem_shift (f: memshift) (m1 m2: mem) : Prop :=
- mk_mem_shift {
- ms_inj:
- mem_inj val_inject (meminj_of_shift f) m1 m2;
- ms_samedomain:
- nextblock m1 = nextblock m2;
- ms_domain:
- forall b, match f b with Some _ => b < nextblock m1 | None => b >= nextblock m1 end;
- ms_range_1:
- forall b delta,
- f b = Some delta ->
- Int.min_signed <= delta <= Int.max_signed;
- ms_range_2:
- forall b delta,
- f b = Some delta ->
- Int.min_signed <= low_bound m2 b /\ high_bound m2 b <= Int.max_signed
- }.
-
-(** The following lemmas establish the absence of machine integer overflow
- during address computations. *)
-
-Lemma address_shift:
- forall f m1 m2 chunk b ofs1 delta,
- mem_shift f m1 m2 ->
- valid_access m1 chunk b (Int.signed ofs1) ->
- f b = Some delta ->
- Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta.
-Proof.
- intros. inversion H.
- elim (ms_range_4 _ _ H1); intros.
- rewrite Int.add_signed.
- repeat rewrite Int.signed_repr. auto.
- eauto.
- assert (valid_access m2 chunk b (Int.signed ofs1 + delta)).
- eapply valid_access_inj with (mi := meminj_of_shift f); eauto.
- unfold meminj_of_shift. rewrite H1; auto.
- inv H4. generalize (size_chunk_pos chunk); omega.
- eauto.
-Qed.
-
-Lemma valid_pointer_shift_no_overflow:
- forall f m1 m2 b ofs x,
- mem_shift f m1 m2 ->
- valid_pointer m1 b (Int.signed ofs) = true ->
- f b = Some x ->
- Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed.
-Proof.
- intros. inv H. rewrite valid_pointer_valid_access in H0.
- assert (valid_access m2 Mint8unsigned b (Int.signed ofs + x)).
- eapply valid_access_inj with (mi := meminj_of_shift f); eauto.
- unfold meminj_of_shift. rewrite H1; auto.
- inv H. change (size_chunk Mint8unsigned) with 1 in H4.
- rewrite Int.signed_repr; eauto.
- exploit ms_range_4; eauto. intros [A B]. omega.
-Qed.
-
-Lemma valid_pointer_shift:
- forall f m1 m2 b ofs b' ofs',
- mem_shift f m1 m2 ->
- valid_pointer m1 b (Int.signed ofs) = true ->
- val_shift f (Vptr b ofs) (Vptr b' ofs') ->
- valid_pointer m2 b' (Int.signed ofs') = true.
-Proof.
- intros. unfold val_shift in H1. inv H1.
- assert (f b = Some x).
- unfold meminj_of_shift in H5. destruct (f b); congruence.
- exploit valid_pointer_shift_no_overflow; eauto. intro NOOV.
- inv H. rewrite Int.add_signed. rewrite Int.signed_repr; auto.
- rewrite Int.signed_repr; eauto.
- eapply valid_pointer_inj; eauto.
-Qed.
-
-(** Relation between shifts and loads. *)
-
-Lemma load_shift:
- forall f m1 m2 chunk b ofs delta v1,
- mem_shift f m1 m2 ->
- load chunk m1 b ofs = Some v1 ->
- f b = Some delta ->
- exists v2, load chunk m2 b (ofs + delta) = Some v2 /\ val_shift f v1 v2.
-Proof.
- intros. inversion H.
- unfold val_shift. eapply ms_inj0; eauto.
- unfold meminj_of_shift; rewrite H1; auto.
-Qed.
-
-Lemma loadv_shift:
- forall f m1 m2 chunk a1 a2 v1,
- mem_shift f m1 m2 ->
- loadv chunk m1 a1 = Some v1 ->
- val_shift f a1 a2 ->
- exists v2, loadv chunk m2 a2 = Some v2 /\ val_shift f v1 v2.
-Proof.
- intros. unfold val_shift in H1. inv H1; simpl in H0; try discriminate.
- generalize H2. unfold meminj_of_shift. caseEq (f b1); intros; inv H3.
- exploit load_shift; eauto. intros [v2 [LOAD INJ]].
- exists v2; split; auto. simpl.
- replace (Int.signed (Int.add ofs1 (Int.repr x)))
- with (Int.signed ofs1 + x).
- auto. symmetry. eapply address_shift; eauto with mem.
-Qed.
-
-(** Relation between shifts and stores. *)
-
-Lemma store_within_shift:
- forall f chunk m1 b ofs v1 n1 m2 delta v2,
- mem_shift f m1 m2 ->
- store chunk m1 b ofs v1 = Some n1 ->
- f b = Some delta ->
- val_shift f v1 v2 ->
- exists n2,
- store chunk m2 b (ofs + delta) v2 = Some n2
- /\ mem_shift f n1 n2.
-Proof.
- intros. inversion H.
- exploit store_mapped_inj; eauto.
- intros; constructor.
- red. intros until delta2. unfold meminj_of_shift.
- destruct (f b1). destruct (f b2). intros. inv H4. inv H5. auto.
- congruence. congruence.
- unfold meminj_of_shift. rewrite H1. auto.
- intros. apply load_result_inject with chunk; eauto.
- unfold val_shift in H2. eauto.
- intros [n2 [STORE MINJ]].
- exists n2; split. auto. constructor.
- (* inj *)
- auto.
- (* samedomain *)
- rewrite (nextblock_store _ _ _ _ _ _ H0).
- rewrite (nextblock_store _ _ _ _ _ _ STORE).
- auto.
- (* domain *)
- rewrite (nextblock_store _ _ _ _ _ _ H0). auto.
- (* range *)
- auto.
- intros.
- repeat rewrite (low_bound_store _ _ _ _ _ _ STORE).
- repeat rewrite (high_bound_store _ _ _ _ _ _ STORE).
- eapply ms_range_4; eauto.
-Qed.
-
-Lemma store_outside_shift:
- forall f chunk m1 b ofs m2 v m2' delta,
- mem_shift f m1 m2 ->
- f b = Some delta ->
- high_bound m1 b + delta <= ofs
- \/ ofs + size_chunk chunk <= low_bound m1 b + delta ->
- store chunk m2 b ofs v = Some m2' ->
- mem_shift f m1 m2'.
-Proof.
- intros. inversion H. constructor.
- (* inj *)
- eapply store_outside_inj; eauto.
- unfold meminj_of_shift. intros b' d'. caseEq (f b'); intros; inv H4.
- congruence.
- (* samedomain *)
- rewrite (nextblock_store _ _ _ _ _ _ H2).
- auto.
- (* domain *)
- auto.
- (* range *)
- auto.
- intros.
- repeat rewrite (low_bound_store _ _ _ _ _ _ H2).
- repeat rewrite (high_bound_store _ _ _ _ _ _ H2).
- eapply ms_range_4; eauto.
-Qed.
-
-Lemma storev_shift:
- forall f chunk m1 a1 v1 n1 m2 a2 v2,
- mem_shift f m1 m2 ->
- storev chunk m1 a1 v1 = Some n1 ->
- val_shift f a1 a2 ->
- val_shift f v1 v2 ->
- exists n2,
- storev chunk m2 a2 v2 = Some n2 /\ mem_shift f n1 n2.
-Proof.
- intros. unfold val_shift in H1. inv H1; simpl in H0; try discriminate.
- generalize H3. unfold meminj_of_shift. caseEq (f b1); intros; inv H4.
- exploit store_within_shift; eauto. intros [n2 [A B]].
- exists n2; split; auto.
- unfold storev.
- replace (Int.signed (Int.add ofs1 (Int.repr x)))
- with (Int.signed ofs1 + x).
- auto. symmetry. eapply address_shift; eauto with mem.
-Qed.
-
-(** Relation between shifts and [free]. *)
-
-Lemma free_shift:
- forall f m1 m2 b,
- mem_shift f m1 m2 ->
- mem_shift f (free m1 b) (free m2 b).
-Proof.
- intros. inv H. constructor.
- (* inj *)
- apply free_right_inj. apply free_left_inj; auto.
- intros until ofs. unfold meminj_of_shift. caseEq (f b1); intros; inv H0.
- apply valid_access_free_2.
- (* samedomain *)
- simpl. auto.
- (* domain *)
- simpl. auto.
- (* range *)
- auto.
- intros. destruct (eq_block b0 b).
- subst b0. rewrite low_bound_free_same. rewrite high_bound_free_same.
- vm_compute; intuition congruence.
- rewrite low_bound_free; auto. rewrite high_bound_free; auto. eauto.
-Qed.
-
-(** Relation between shifts and allocation. *)
-
-Definition shift_incr (f1 f2: memshift) : Prop :=
- forall b, f1 b = f2 b \/ f1 b = None.
-
-Remark shift_incr_inject_incr:
- forall f1 f2,
- shift_incr f1 f2 -> inject_incr (meminj_of_shift f1) (meminj_of_shift f2).
-Proof.
- intros. unfold meminj_of_shift. red. intros.
- elim (H b); intro. rewrite H0. auto. rewrite H0. auto.
-Qed.
-
-Lemma val_shift_incr:
- forall f1 f2 v1 v2,
- shift_incr f1 f2 -> val_shift f1 v1 v2 -> val_shift f2 v1 v2.
-Proof.
- unfold val_shift; intros.
- apply val_inject_incr with (meminj_of_shift f1).
- apply shift_incr_inject_incr. auto. auto.
-Qed.
-
-(***
-Remark mem_inj_incr:
- forall f1 f2 m1 m2,
- inject_incr f1 f2 -> mem_inj val_inject f1 m1 m2 -> mem_inj val_inject f2 m1 m2.
-Proof.
- intros; red; intros.
- destruct (H b1). rewrite <- H3 in H1.
- exploit H0; eauto. intros [v2 [A B]].
- exists v2; split. auto. apply val_inject_incr with f1; auto.
- congruence.
-***)
-
-Lemma alloc_shift:
- forall f m1 m2 lo1 hi1 m1' b delta lo2 hi2,
- mem_shift f m1 m2 ->
- alloc m1 lo1 hi1 = (m1', b) ->
- lo2 <= lo1 + delta -> hi1 + delta <= hi2 ->
- Int.min_signed <= delta <= Int.max_signed ->
- Int.min_signed <= lo2 -> hi2 <= Int.max_signed ->
- inj_offset_aligned delta (hi1-lo1) ->
- exists f', exists m2',
- alloc m2 lo2 hi2 = (m2', b)
- /\ mem_shift f' m1' m2'
- /\ shift_incr f f'
- /\ f' b = Some delta.
-Proof.
- intros. inv H. caseEq (alloc m2 lo2 hi2). intros m2' b' ALLOC2.
- assert (b' = b).
- rewrite (alloc_result _ _ _ _ _ H0).
- rewrite (alloc_result _ _ _ _ _ ALLOC2).
- auto.
- subst b'.
- assert (f b = None).
- generalize (ms_domain0 b).
- rewrite (alloc_result _ _ _ _ _ H0).
- destruct (f (nextblock m1)).
- intros. omegaContradiction.
- auto.
- set (f' := fun (b': block) => if zeq b' b then Some delta else f b').
- assert (shift_incr f f').
- red; unfold f'; intros.
- destruct (zeq b0 b); auto.
- subst b0. auto.
- exists f'; exists m2'.
- split. auto.
- (* mem_shift *)
- split. constructor.
- (* inj *)
- assert (mem_inj val_inject (meminj_of_shift f') m1 m2).
- red; intros.
- assert (meminj_of_shift f b1 = Some (b2, delta0)).
- rewrite <- H8. unfold meminj_of_shift, f'.
- destruct (zeq b1 b); auto.
- subst b1.
- assert (valid_block m1 b) by eauto with mem.
- assert (~valid_block m1 b) by eauto with mem.
- contradiction.
- exploit ms_inj0; eauto. intros [v2 [A B]].
- exists v2; split; auto.
- apply val_inject_incr with (meminj_of_shift f).
- apply shift_incr_inject_incr. auto. auto.
- eapply alloc_parallel_inj; eauto.
- unfold meminj_of_shift, f'. rewrite zeq_true. auto.
- (* samedomain *)
- rewrite (nextblock_alloc _ _ _ _ _ H0).
- rewrite (nextblock_alloc _ _ _ _ _ ALLOC2).
- congruence.
- (* domain *)
- intros. unfold f'.
- rewrite (nextblock_alloc _ _ _ _ _ H0).
- rewrite (alloc_result _ _ _ _ _ H0).
- destruct (zeq b0 (nextblock m1)). omega.
- generalize (ms_domain0 b0). destruct (f b0); omega.
- (* range *)
- unfold f'; intros. destruct (zeq b0 b). congruence. eauto.
- unfold f'; intros.
- rewrite (low_bound_alloc _ _ _ _ _ ALLOC2).
- rewrite (high_bound_alloc _ _ _ _ _ ALLOC2).
- destruct (zeq b0 b). auto. eauto.
- (* shift_incr *)
- split. auto.
- (* f' b = delta *)
- unfold f'. apply zeq_true.
-Qed.
-
-(** ** Relation between signed and unsigned loads and stores *)
-
-(** Target processors do not distinguish between signed and unsigned
- stores of 8- and 16-bit quantities. We show these are equivalent. *)
-
-(** Signed 8- and 16-bit stores can be performed like unsigned stores. *)
-
-Remark in_bounds_equiv:
- forall chunk1 chunk2 m b ofs (A: Type) (a1 a2: A),
- size_chunk chunk1 = size_chunk chunk2 ->
- (if in_bounds m chunk1 b ofs then a1 else a2) =
- (if in_bounds m chunk2 b ofs then a1 else a2).
-Proof.
- intros. destruct (in_bounds m chunk1 b ofs).
- rewrite in_bounds_true. auto. eapply valid_access_compat; eauto.
- destruct (in_bounds m chunk2 b ofs); auto.
- elim n. eapply valid_access_compat with (chunk1 := chunk2); eauto.
-Qed.
-
-Lemma storev_8_signed_unsigned:
- forall m a v,
- storev Mint8signed m a v = storev Mint8unsigned m a v.
-Proof.
- intros. unfold storev. destruct a; auto.
- unfold store. rewrite (in_bounds_equiv Mint8signed Mint8unsigned).
- auto. auto.
-Qed.
-
-Lemma storev_16_signed_unsigned:
- forall m a v,
- storev Mint16signed m a v = storev Mint16unsigned m a v.
-Proof.
- intros. unfold storev. destruct a; auto.
- unfold store. rewrite (in_bounds_equiv Mint16signed Mint16unsigned).
- auto. auto.
-Qed.
-
-(** Likewise, some target processors (e.g. the PowerPC) do not have
- a ``load 8-bit signed integer'' instruction.
- We show that it can be synthesized as a ``load 8-bit unsigned integer''
- followed by a sign extension. *)
-
-Lemma loadv_8_signed_unsigned:
- forall m a,
- loadv Mint8signed m a = option_map (Val.sign_ext 8) (loadv Mint8unsigned m a).
-Proof.
- intros. unfold Mem.loadv. destruct a; try reflexivity.
- unfold load. rewrite (in_bounds_equiv Mint8signed Mint8unsigned).
- destruct (in_bounds m Mint8unsigned b (Int.signed i)); auto.
- simpl.
- destruct (getN 0 (Int.signed i) (contents (blocks m b))); auto.
- simpl. rewrite Int.sign_ext_zero_ext. auto. compute; auto.
- auto.
-Qed.
-
diff --git a/common/Memdata.v b/common/Memdata.v
new file mode 100644
index 0000000..2c5fdb6
--- /dev/null
+++ b/common/Memdata.v
@@ -0,0 +1,1058 @@
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+
+(** * Properties of memory chunks *)
+
+(** Memory reads and writes are performed by quantities called memory chunks,
+ encoding the type, size and signedness of the chunk being addressed.
+ The following functions extract the size information from a chunk. *)
+
+Definition size_chunk (chunk: memory_chunk) : Z :=
+ match chunk with
+ | Mint8signed => 1
+ | Mint8unsigned => 1
+ | Mint16signed => 2
+ | Mint16unsigned => 2
+ | Mint32 => 4
+ | Mfloat32 => 4
+ | Mfloat64 => 8
+ end.
+
+Lemma size_chunk_pos:
+ forall chunk, size_chunk chunk > 0.
+Proof.
+ intros. destruct chunk; simpl; omega.
+Qed.
+
+Definition size_chunk_nat (chunk: memory_chunk) : nat :=
+ nat_of_Z(size_chunk chunk).
+
+Lemma size_chunk_conv:
+ forall chunk, size_chunk chunk = Z_of_nat (size_chunk_nat chunk).
+Proof.
+ intros. destruct chunk; reflexivity.
+Qed.
+
+Lemma size_chunk_nat_pos:
+ forall chunk, exists n, size_chunk_nat chunk = S n.
+Proof.
+ intros.
+ generalize (size_chunk_pos chunk). rewrite size_chunk_conv.
+ destruct (size_chunk_nat chunk).
+ simpl; intros; omegaContradiction.
+ intros; exists n; auto.
+Qed.
+
+(** Memory reads and writes must respect alignment constraints:
+ the byte offset of the location being addressed should be an exact
+ multiple of the natural alignment for the chunk being addressed.
+ This natural alignment is defined by the following
+ [align_chunk] function. Some target architectures
+ (e.g. the PowerPC) have no alignment constraints, which we could
+ reflect by taking [align_chunk chunk = 1]. However, other architectures
+ have stronger alignment requirements. The following definition is
+ appropriate for PowerPC and ARM. *)
+
+Definition align_chunk (chunk: memory_chunk) : Z :=
+ match chunk with
+ | Mint8signed => 1
+ | Mint8unsigned => 1
+ | Mint16signed => 2
+ | Mint16unsigned => 2
+ | _ => 4
+ end.
+
+Lemma align_chunk_pos:
+ forall chunk, align_chunk chunk > 0.
+Proof.
+ intro. destruct chunk; simpl; omega.
+Qed.
+
+Lemma align_size_chunk_divides:
+ forall chunk, (align_chunk chunk | size_chunk chunk).
+Proof.
+ intros. destruct chunk; simpl; try apply Zdivide_refl. exists 2; auto.
+Qed.
+
+Lemma align_chunk_compat:
+ forall chunk1 chunk2,
+ size_chunk chunk1 = size_chunk chunk2 -> align_chunk chunk1 = align_chunk chunk2.
+Proof.
+ intros chunk1 chunk2.
+ destruct chunk1; destruct chunk2; simpl; congruence.
+Qed.
+
+(** The type (integer/pointer or float) of a chunk. *)
+
+Definition type_of_chunk (c: memory_chunk) : typ :=
+ match c with
+ | Mint8signed => Tint
+ | Mint8unsigned => Tint
+ | Mint16signed => Tint
+ | Mint16unsigned => Tint
+ | Mint32 => Tint
+ | Mfloat32 => Tfloat
+ | Mfloat64 => Tfloat
+ end.
+
+(** * Memory values *)
+
+(** A ``memory value'' is a byte-sized quantity that describes the current
+ content of a memory cell. It can be either:
+- a concrete 8-bit integer;
+- a byte-sized fragment of an opaque pointer;
+- the special constant [Undef] that represents uninitialized memory.
+*)
+
+(** Values stored in memory cells. *)
+
+Inductive memval: Type :=
+ | Undef: memval
+ | Byte: byte -> memval
+ | Pointer: block -> int -> nat -> memval.
+
+(** * Encoding and decoding integers *)
+
+(** We define functions to convert between integers and lists of bytes
+ according to a given memory chunk. *)
+
+Parameter big_endian: bool.
+
+Definition rev_if_le (l: list byte) : list byte :=
+ if big_endian then l else List.rev l.
+
+Lemma rev_if_le_involutive:
+ forall l, rev_if_le (rev_if_le l) = l.
+Proof.
+ intros; unfold rev_if_le; destruct big_endian.
+ auto.
+ apply List.rev_involutive.
+Qed.
+
+Lemma rev_if_le_length:
+ forall l, length (rev_if_le l) = length l.
+Proof.
+ intros; unfold rev_if_le; destruct big_endian.
+ auto.
+ apply List.rev_length.
+Qed.
+
+Definition encode_int (c: memory_chunk) (x: int) : list byte :=
+ let n := Int.unsigned x in
+ rev_if_le (match c with
+ | Mint8signed | Mint8unsigned =>
+ Byte.repr n :: nil
+ | Mint16signed | Mint16unsigned =>
+ Byte.repr (n/256) :: Byte.repr n :: nil
+ | Mint32 =>
+ Byte.repr (n/16777216) :: Byte.repr (n/65536) :: Byte.repr (n/256) :: Byte.repr n :: nil
+ | Mfloat32 =>
+ Byte.zero :: Byte.zero :: Byte.zero :: Byte.zero :: nil
+ | Mfloat64 =>
+ Byte.zero :: Byte.zero :: Byte.zero :: Byte.zero ::
+ Byte.zero :: Byte.zero :: Byte.zero :: Byte.zero :: nil
+ end).
+
+Definition decode_int (c: memory_chunk) (b: list byte) : int :=
+ match c, rev_if_le b with
+ | Mint8signed, b1 :: nil =>
+ Int.sign_ext 8 (Int.repr (Byte.unsigned b1))
+ | Mint8unsigned, b1 :: nil =>
+ Int.repr (Byte.unsigned b1)
+ | Mint16signed, b1 :: b2 :: nil =>
+ Int.sign_ext 16 (Int.repr (Byte.unsigned b1 * 256 + Byte.unsigned b2))
+ | Mint16unsigned, b1 :: b2 :: nil =>
+ Int.repr (Byte.unsigned b1 * 256 + Byte.unsigned b2)
+ | Mint32, b1 :: b2 :: b3 :: b4 :: nil =>
+ Int.repr (Byte.unsigned b1 * 16777216 + Byte.unsigned b2 * 65536
+ + Byte.unsigned b3 * 256 + Byte.unsigned b4)
+ | _, _ => Int.zero
+ end.
+
+Lemma encode_int_length:
+ forall chunk n, length(encode_int chunk n) = size_chunk_nat chunk.
+Proof.
+ intros. unfold encode_int. rewrite rev_if_le_length.
+ destruct chunk; reflexivity.
+Qed.
+
+Lemma decode_encode_int8unsigned: forall n,
+ decode_int Mint8unsigned (encode_int Mint8unsigned n) = Int.zero_ext 8 n.
+Proof.
+ intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive.
+ simpl. auto.
+Qed.
+
+Lemma decode_encode_int8signed: forall n,
+ decode_int Mint8signed (encode_int Mint8signed n) = Int.sign_ext 8 n.
+Proof.
+ intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive. simpl.
+ change (Int.repr (Int.unsigned n mod Byte.modulus))
+ with (Int.zero_ext 8 n).
+ apply Int.sign_ext_zero_ext. compute; auto.
+Qed.
+
+Remark recombine_16:
+ forall x,
+ (x / 256) mod Byte.modulus * 256 + x mod Byte.modulus = x mod (two_p 16).
+Proof.
+ intros. symmetry. apply (Zmod_recombine x 256 256); omega.
+Qed.
+
+Lemma decode_encode_int16unsigned: forall n,
+ decode_int Mint16unsigned (encode_int Mint16unsigned n) = Int.zero_ext 16 n.
+Proof.
+ intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive. simpl.
+ rewrite recombine_16. auto.
+Qed.
+
+Lemma decode_encode_int16signed: forall n,
+ decode_int Mint16signed (encode_int Mint16signed n) = Int.sign_ext 16 n.
+Proof.
+ intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive. simpl.
+ rewrite recombine_16.
+ fold (Int.zero_ext 16 n). apply Int.sign_ext_zero_ext. compute; auto.
+Qed.
+
+Remark recombine_32:
+ forall x,
+ (x / 16777216) mod Byte.modulus * 16777216
+ + (x / 65536) mod Byte.modulus * 65536
+ + (x / 256) mod Byte.modulus * 256
+ + x mod Byte.modulus =
+ x mod Int.modulus.
+Proof.
+ intros. change Byte.modulus with 256.
+ exploit (Zmod_recombine x 65536 65536). omega. omega. intro EQ1.
+ exploit (Zmod_recombine x 256 256). omega. omega.
+ change (256 * 256) with 65536. intro EQ2.
+ exploit (Zmod_recombine (x/65536) 256 256). omega. omega.
+ rewrite Zdiv_Zdiv. change (65536*256) with 16777216. change (256 * 256) with 65536.
+ intro EQ3.
+ change Int.modulus with (65536 * 65536).
+ rewrite EQ1. rewrite EQ2. rewrite EQ3. omega.
+ omega. omega.
+Qed.
+
+Lemma decode_encode_int32: forall n,
+ decode_int Mint32 (encode_int Mint32 n) = n.
+Proof.
+ intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive. simpl.
+ rewrite recombine_32.
+ transitivity (Int.repr (Int.unsigned n)). 2: apply Int.repr_unsigned.
+ apply Int.eqm_samerepr. apply Int.eqm_sym. red. apply Int.eqmod_mod.
+ apply Int.modulus_pos.
+Qed.
+
+Lemma encode_int8_signed_unsigned: forall n,
+ encode_int Mint8signed n = encode_int Mint8unsigned n.
+Proof.
+ intros; reflexivity.
+Qed.
+
+Remark encode_8_mod:
+ forall x y,
+ Int.eqmod (two_p 8) (Int.unsigned x) (Int.unsigned y) ->
+ encode_int Mint8unsigned x = encode_int Mint8unsigned y.
+Proof.
+ intros. unfold encode_int. decEq. decEq. apply Byte.eqm_samerepr. exact H.
+Qed.
+
+Lemma encode_int8_zero_ext:
+ forall x,
+ encode_int Mint8unsigned (Int.zero_ext 8 x) = encode_int Mint8unsigned x.
+Proof.
+ intros. apply encode_8_mod. apply Int.eqmod_sym.
+ apply Int.eqmod_two_p_zero_ext. compute; auto.
+Qed.
+
+Lemma encode_int8_sign_ext:
+ forall x,
+ encode_int Mint8signed (Int.sign_ext 8 x) = encode_int Mint8signed x.
+Proof.
+ intros. repeat rewrite encode_int8_signed_unsigned.
+ apply encode_8_mod. apply Int.eqmod_sym.
+ apply Int.eqmod_two_p_sign_ext. compute; auto.
+Qed.
+
+Lemma encode_int16_signed_unsigned: forall n,
+ encode_int Mint16signed n = encode_int Mint16unsigned n.
+Proof.
+ intros; reflexivity.
+Qed.
+
+Remark encode_16_mod:
+ forall x y,
+ Int.eqmod (two_p 16) (Int.unsigned x) (Int.unsigned y) ->
+ encode_int Mint16unsigned x = encode_int Mint16unsigned y.
+Proof.
+ intros. unfold encode_int. decEq.
+ set (x' := Int.unsigned x) in *.
+ set (y' := Int.unsigned y) in *.
+ assert (Int.eqmod (two_p 8) x' y').
+ eapply Int.eqmod_divides; eauto. exists (two_p 8); auto.
+ assert (Int.eqmod (two_p 8) (x' / 256) (y' / 256)).
+ destruct H as [k EQ].
+ exists k. rewrite EQ.
+ replace (k * two_p 16) with ((k * two_p 8) * two_p 8).
+ rewrite Zplus_comm. rewrite Z_div_plus. omega.
+ omega. rewrite <- Zmult_assoc. auto.
+ decEq. apply Byte.eqm_samerepr. exact H1.
+ decEq. apply Byte.eqm_samerepr. exact H0.
+Qed.
+
+Lemma encode_int16_zero_ext:
+ forall x,
+ encode_int Mint16unsigned (Int.zero_ext 16 x) = encode_int Mint16unsigned x.
+Proof.
+ intros. apply encode_16_mod. apply Int.eqmod_sym.
+ apply (Int.eqmod_two_p_zero_ext 16). compute; auto.
+Qed.
+
+Lemma encode_int16_sign_ext:
+ forall x,
+ encode_int Mint16signed (Int.sign_ext 16 x) = encode_int Mint16signed x.
+Proof.
+ intros. repeat rewrite encode_int16_signed_unsigned.
+ apply encode_16_mod. apply Int.eqmod_sym.
+ apply Int.eqmod_two_p_sign_ext. compute; auto.
+Qed.
+
+Lemma decode_int8_zero_ext:
+ forall l,
+ Int.zero_ext 8 (decode_int Mint8unsigned l) = decode_int Mint8unsigned l.
+Proof.
+ intros; simpl. destruct (rev_if_le l); auto. destruct l0; auto.
+ unfold Int.zero_ext. decEq.
+ generalize (Byte.unsigned_range i). intro.
+ rewrite Int.unsigned_repr. apply Zmod_small. assumption.
+ assert (Byte.modulus < Int.max_unsigned). vm_compute. auto.
+ omega.
+Qed.
+
+Lemma decode_int8_sign_ext:
+ forall l,
+ Int.sign_ext 8 (decode_int Mint8signed l) = decode_int Mint8signed l.
+Proof.
+ intros; simpl. destruct (rev_if_le l); auto. destruct l0; auto.
+ rewrite Int.sign_ext_idem. auto. vm_compute; auto.
+Qed.
+
+Lemma decode_int16_zero_ext:
+ forall l,
+ Int.zero_ext 16 (decode_int Mint16unsigned l) = decode_int Mint16unsigned l.
+Proof.
+ intros; simpl. destruct (rev_if_le l); auto. destruct l0; auto. destruct l0; auto.
+ unfold Int.zero_ext. decEq.
+ generalize (Byte.unsigned_range i) (Byte.unsigned_range i0).
+ change Byte.modulus with 256. intros.
+ assert (0 <= Byte.unsigned i * 256 + Byte.unsigned i0 < 65536). omega.
+ rewrite Int.unsigned_repr. apply Zmod_small. assumption.
+ assert (65536 < Int.max_unsigned). vm_compute. auto.
+ omega.
+Qed.
+
+Lemma decode_int16_sign_ext:
+ forall l,
+ Int.sign_ext 16 (decode_int Mint16signed l) = decode_int Mint16signed l.
+Proof.
+ intros; simpl. destruct (rev_if_le l); auto. destruct l0; auto. destruct l0; auto.
+ rewrite Int.sign_ext_idem. auto. vm_compute; auto.
+Qed.
+
+Lemma decode_int8_signed_unsigned:
+ forall l,
+ decode_int Mint8signed l = Int.sign_ext 8 (decode_int Mint8unsigned l).
+Proof.
+ unfold decode_int; intros. destruct (rev_if_le l); auto. destruct l0; auto.
+Qed.
+
+Lemma decode_int16_signed_unsigned:
+ forall l,
+ decode_int Mint16signed l = Int.sign_ext 16 (decode_int Mint16unsigned l).
+Proof.
+ unfold decode_int; intros. destruct (rev_if_le l); auto.
+ destruct l0; auto. destruct l0; auto.
+Qed.
+
+(** * Encoding and decoding floats *)
+
+Parameter encode_float: memory_chunk -> float -> list byte.
+Parameter decode_float: memory_chunk -> list byte -> float.
+
+Axiom encode_float_length:
+ forall chunk n, length(encode_float chunk n) = size_chunk_nat chunk.
+
+(* More realistic:
+ decode_float Mfloat32 (encode_float Mfloat32 (Float.singleoffloat n)) =
+ Float.singleoffloat n
+*)
+Axiom decode_encode_float32: forall n,
+ decode_float Mfloat32 (encode_float Mfloat32 n) = Float.singleoffloat n.
+Axiom decode_encode_float64: forall n,
+ decode_float Mfloat64 (encode_float Mfloat64 n) = n.
+
+Axiom encode_float32_singleoffloat: forall n,
+ encode_float Mfloat32 (Float.singleoffloat n) = encode_float Mfloat32 n.
+
+Axiom encode_float8_signed_unsigned: forall n,
+ encode_float Mint8signed n = encode_float Mint8unsigned n.
+Axiom encode_float16_signed_unsigned: forall n,
+ encode_float Mint16signed n = encode_float Mint16unsigned n.
+
+Axiom encode_float32_cast:
+ forall f,
+ encode_float Mfloat32 (Float.singleoffloat f) = encode_float Mfloat32 f.
+
+Axiom decode_float32_cast:
+ forall l,
+ Float.singleoffloat (decode_float Mfloat32 l) = decode_float Mfloat32 l.
+
+(** * Encoding and decoding values *)
+
+Definition inj_bytes (bl: list byte) : list memval :=
+ List.map Byte bl.
+
+Fixpoint proj_bytes (vl: list memval) : option (list byte) :=
+ match vl with
+ | nil => Some nil
+ | Byte b :: vl' =>
+ match proj_bytes vl' with None => None | Some bl => Some(b :: bl) end
+ | _ => None
+ end.
+
+Remark length_inj_bytes:
+ forall bl, length (inj_bytes bl) = length bl.
+Proof.
+ intros. apply List.map_length.
+Qed.
+
+Remark proj_inj_bytes:
+ forall bl, proj_bytes (inj_bytes bl) = Some bl.
+Proof.
+ induction bl; simpl. auto. rewrite IHbl. auto.
+Qed.
+
+Lemma inj_proj_bytes:
+ forall cl bl, proj_bytes cl = Some bl -> cl = inj_bytes bl.
+Proof.
+ induction cl; simpl; intros.
+ inv H; auto.
+ destruct a; try congruence. destruct (proj_bytes cl); inv H.
+ simpl. decEq. auto.
+Qed.
+
+Fixpoint inj_pointer (n: nat) (b: block) (ofs: int) {struct n}: list memval :=
+ match n with
+ | O => nil
+ | S m => Pointer b ofs m :: inj_pointer m b ofs
+ end.
+
+Fixpoint check_pointer (n: nat) (b: block) (ofs: int) (vl: list memval)
+ {struct n} : bool :=
+ match n, vl with
+ | O, nil => true
+ | S m, Pointer b' ofs' m' :: vl' =>
+ eq_block b b' && Int.eq_dec ofs ofs' && beq_nat m m' && check_pointer m b ofs vl'
+ | _, _ => false
+ end.
+
+Definition proj_pointer (vl: list memval) : val :=
+ match vl with
+ | Pointer b ofs n :: vl' =>
+ if check_pointer (size_chunk_nat Mint32) b ofs vl
+ then Vptr b ofs
+ else Vundef
+ | _ => Vundef
+ end.
+
+Definition encode_val (chunk: memory_chunk) (v: val) : list memval :=
+ match v, chunk with
+ | Vptr b ofs, Mint32 => inj_pointer (size_chunk_nat Mint32) b ofs
+ | Vint n, _ => inj_bytes (encode_int chunk n)
+ | Vfloat f, _ => inj_bytes (encode_float chunk f)
+ | _, _ => list_repeat (size_chunk_nat chunk) Undef
+ end.
+
+Definition decode_val (chunk: memory_chunk) (vl: list memval) : val :=
+ match proj_bytes vl with
+ | Some bl =>
+ match chunk with
+ | Mint8signed | Mint8unsigned
+ | Mint16signed | Mint16unsigned | Mint32 =>
+ Vint(decode_int chunk bl)
+ | Mfloat32 | Mfloat64 =>
+ Vfloat(decode_float chunk bl)
+ end
+ | None =>
+ match chunk with
+ | Mint32 => proj_pointer vl
+ | _ => Vundef
+ end
+ end.
+
+(*
+Lemma inj_pointer_length:
+ forall b ofs n, List.length(inj_pointer n b ofs) = n.
+Proof.
+ induction n; simpl; congruence.
+Qed.
+*)
+
+Lemma encode_val_length:
+ forall chunk v, length(encode_val chunk v) = size_chunk_nat chunk.
+Proof.
+ intros. destruct v; simpl.
+ apply length_list_repeat.
+ rewrite length_inj_bytes. apply encode_int_length.
+ rewrite length_inj_bytes. apply encode_float_length.
+ destruct chunk; try (apply length_list_repeat). reflexivity.
+Qed.
+
+Lemma check_inj_pointer:
+ forall b ofs n, check_pointer n b ofs (inj_pointer n b ofs) = true.
+Proof.
+ induction n; simpl. auto.
+ unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_true.
+ rewrite <- beq_nat_refl. simpl; auto.
+Qed.
+
+Definition decode_encode_val (v1: val) (chunk1 chunk2: memory_chunk) (v2: val) : Prop :=
+ match v1, chunk1, chunk2 with
+ | Vundef, _, _ => v2 = Vundef
+ | Vint n, Mint8signed, Mint8signed => v2 = Vint(Int.sign_ext 8 n)
+ | Vint n, Mint8unsigned, Mint8signed => v2 = Vint(Int.sign_ext 8 n)
+ | Vint n, Mint8signed, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n)
+ | Vint n, Mint8unsigned, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n)
+ | Vint n, Mint16signed, Mint16signed => v2 = Vint(Int.sign_ext 16 n)
+ | Vint n, Mint16unsigned, Mint16signed => v2 = Vint(Int.sign_ext 16 n)
+ | Vint n, Mint16signed, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n)
+ | Vint n, Mint16unsigned, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n)
+ | Vint n, Mint32, Mint32 => v2 = Vint n
+ | Vint n, Mint32, Mfloat32 => v2 = Vfloat(decode_float Mfloat32 (encode_int Mint32 n))
+ | Vint n, _, _ => True (* nothing interesting to say about v2 *)
+ | Vptr b ofs, Mint32, Mint32 => v2 = Vptr b ofs
+ | Vptr b ofs, _, _ => v2 = Vundef
+ | Vfloat f, Mfloat32, Mfloat32 => v2 = Vfloat(Float.singleoffloat f)
+ | Vfloat f, Mfloat32, Mint32 => v2 = Vint(decode_int Mint32 (encode_float Mfloat32 f))
+ | Vfloat f, Mfloat64, Mfloat64 => v2 = Vfloat f
+ | Vfloat f, _, _ => True (* nothing interesting to say about v2 *)
+ end.
+
+Lemma decode_encode_val_general:
+ forall v chunk1 chunk2,
+ decode_encode_val v chunk1 chunk2 (decode_val chunk2 (encode_val chunk1 v)).
+Proof.
+ intros. destruct v.
+(* Vundef *)
+ simpl. destruct (size_chunk_nat_pos chunk1) as [psz EQ].
+ rewrite EQ. simpl.
+ unfold decode_val. simpl. destruct chunk2; auto.
+(* Vint *)
+ simpl.
+ destruct chunk1; auto; destruct chunk2; auto; unfold decode_val;
+ rewrite proj_inj_bytes.
+ rewrite decode_encode_int8signed. auto.
+ rewrite encode_int8_signed_unsigned. rewrite decode_encode_int8unsigned. auto.
+ rewrite <- encode_int8_signed_unsigned. rewrite decode_encode_int8signed. auto.
+ rewrite decode_encode_int8unsigned. auto.
+ rewrite decode_encode_int16signed. auto.
+ rewrite encode_int16_signed_unsigned. rewrite decode_encode_int16unsigned. auto.
+ rewrite <- encode_int16_signed_unsigned. rewrite decode_encode_int16signed. auto.
+ rewrite decode_encode_int16unsigned. auto.
+ rewrite decode_encode_int32. auto.
+ auto.
+(* Vfloat *)
+ unfold decode_val, encode_val, decode_encode_val;
+ destruct chunk1; auto; destruct chunk2; auto; unfold decode_val;
+ rewrite proj_inj_bytes.
+ auto.
+ rewrite decode_encode_float32. auto.
+ rewrite decode_encode_float64. auto.
+(* Vptr *)
+ unfold decode_val, encode_val, decode_encode_val;
+ destruct chunk1; auto; destruct chunk2; auto.
+ simpl. generalize (check_inj_pointer b i (size_chunk_nat Mint32)).
+ simpl. intro. rewrite H. auto.
+Qed.
+
+Lemma decode_encode_val_similar:
+ forall v1 chunk1 chunk2 v2,
+ type_of_chunk chunk1 = type_of_chunk chunk2 ->
+ size_chunk chunk1 = size_chunk chunk2 ->
+ Val.has_type v1 (type_of_chunk chunk1) ->
+ decode_encode_val v1 chunk1 chunk2 v2 ->
+ v2 = Val.load_result chunk2 v1.
+Proof.
+ intros.
+ destruct v1.
+ simpl in *. destruct chunk2; simpl; auto.
+ red in H1.
+ destruct chunk1; simpl in H1; try contradiction;
+ destruct chunk2; simpl in *; discriminate || auto.
+ red in H1.
+ destruct chunk1; simpl in H1; try contradiction;
+ destruct chunk2; simpl in *; discriminate || auto.
+ red in H1.
+ destruct chunk1; simpl in H1; try contradiction;
+ destruct chunk2; simpl in *; discriminate || auto.
+Qed.
+
+Lemma decode_val_type:
+ forall chunk cl,
+ Val.has_type (decode_val chunk cl) (type_of_chunk chunk).
+Proof.
+ intros. unfold decode_val.
+ destruct (proj_bytes cl).
+ destruct chunk; simpl; auto.
+ destruct chunk; simpl; auto.
+ unfold proj_pointer. destruct cl; try (exact I).
+ destruct m; try (exact I).
+ destruct (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n :: cl));
+ exact I.
+Qed.
+
+Lemma encode_val_int8_signed_unsigned:
+ forall v, encode_val Mint8signed v = encode_val Mint8unsigned v.
+Proof.
+ intros. destruct v; simpl; auto. rewrite encode_float8_signed_unsigned; auto.
+Qed.
+
+Lemma encode_val_int16_signed_unsigned:
+ forall v, encode_val Mint16signed v = encode_val Mint16unsigned v.
+Proof.
+ intros. destruct v; simpl; auto. rewrite encode_float16_signed_unsigned; auto.
+Qed.
+
+Lemma encode_val_int8_zero_ext:
+ forall n, encode_val Mint8unsigned (Vint (Int.zero_ext 8 n)) = encode_val Mint8unsigned (Vint n).
+Proof.
+ intros; unfold encode_val. rewrite encode_int8_zero_ext. auto.
+Qed.
+
+Lemma encode_val_int8_sign_ext:
+ forall n, encode_val Mint8signed (Vint (Int.sign_ext 8 n)) = encode_val Mint8signed (Vint n).
+Proof.
+ intros; unfold encode_val. rewrite encode_int8_sign_ext. auto.
+Qed.
+
+Lemma encode_val_int16_zero_ext:
+ forall n, encode_val Mint16unsigned (Vint (Int.zero_ext 16 n)) = encode_val Mint16unsigned (Vint n).
+Proof.
+ intros; unfold encode_val. rewrite encode_int16_zero_ext. auto.
+Qed.
+
+Lemma encode_val_int16_sign_ext:
+ forall n, encode_val Mint16signed (Vint (Int.sign_ext 16 n)) = encode_val Mint16signed (Vint n).
+Proof.
+ intros; unfold encode_val. rewrite encode_int16_sign_ext. auto.
+Qed.
+
+Lemma decode_val_int_inv:
+ forall chunk cl n,
+ decode_val chunk cl = Vint n ->
+ type_of_chunk chunk = Tint /\
+ exists bytes, proj_bytes cl = Some bytes /\ n = decode_int chunk bytes.
+Proof.
+ intros until n. unfold decode_val. destruct (proj_bytes cl).
+Opaque decode_int.
+ destruct chunk; intro EQ; inv EQ; split; auto; exists l; auto.
+ destruct chunk; try congruence. unfold proj_pointer.
+ destruct cl; try congruence. destruct m; try congruence.
+ destruct (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n0 :: cl));
+ congruence.
+Qed.
+
+Lemma decode_val_float_inv:
+ forall chunk cl f,
+ decode_val chunk cl = Vfloat f ->
+ type_of_chunk chunk = Tfloat /\
+ exists bytes, proj_bytes cl = Some bytes /\ f = decode_float chunk bytes.
+Proof.
+ intros until f. unfold decode_val. destruct (proj_bytes cl).
+ destruct chunk; intro EQ; inv EQ; split; auto; exists l; auto.
+ destruct chunk; try congruence. unfold proj_pointer.
+ destruct cl; try congruence. destruct m; try congruence.
+ destruct (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n :: cl));
+ congruence.
+Qed.
+
+Lemma decode_val_cast:
+ forall chunk l,
+ let v := decode_val chunk l in
+ match chunk with
+ | Mint8signed => v = Val.sign_ext 8 v
+ | Mint8unsigned => v = Val.zero_ext 8 v
+ | Mint16signed => v = Val.sign_ext 16 v
+ | Mint16unsigned => v = Val.zero_ext 16 v
+ | Mfloat32 => v = Val.singleoffloat v
+ | _ => True
+ end.
+Proof.
+ unfold decode_val; intros; destruct chunk; auto; destruct (proj_bytes l); auto.
+ unfold Val.sign_ext. decEq. symmetry. apply decode_int8_sign_ext.
+ unfold Val.zero_ext. decEq. symmetry. apply decode_int8_zero_ext.
+ unfold Val.sign_ext. decEq. symmetry. apply decode_int16_sign_ext.
+ unfold Val.zero_ext. decEq. symmetry. apply decode_int16_zero_ext.
+ unfold Val.singleoffloat. decEq. symmetry. apply decode_float32_cast.
+Qed.
+
+(** Pointers cannot be forged. *)
+
+Definition memval_valid_first (mv: memval) : Prop :=
+ match mv with
+ | Pointer b ofs n => n = pred (size_chunk_nat Mint32)
+ | _ => True
+ end.
+
+Definition memval_valid_cont (mv: memval) : Prop :=
+ match mv with
+ | Pointer b ofs n => n <> pred (size_chunk_nat Mint32)
+ | _ => True
+ end.
+
+Inductive encoding_shape: list memval -> Prop :=
+ | encoding_shape_intro: forall mv1 mvl,
+ memval_valid_first mv1 ->
+ (forall mv, In mv mvl -> memval_valid_cont mv) ->
+ encoding_shape (mv1 :: mvl).
+
+Lemma encode_val_shape:
+ forall chunk v, encoding_shape (encode_val chunk v).
+Proof.
+ intros.
+ destruct (size_chunk_nat_pos chunk) as [sz1 EQ].
+ assert (encoding_shape (list_repeat (size_chunk_nat chunk) Undef)).
+ rewrite EQ; simpl; constructor. exact I.
+ intros. replace mv with Undef. exact I. symmetry; eapply in_list_repeat; eauto.
+ assert (forall bl, length bl = size_chunk_nat chunk ->
+ encoding_shape (inj_bytes bl)).
+ intros. destruct bl; simpl in *. congruence.
+ constructor. exact I. unfold inj_bytes. intros.
+ exploit list_in_map_inv; eauto. intros [x [A B]]. subst mv. exact I.
+ destruct v; simpl.
+ auto.
+ apply H0. apply encode_int_length.
+ apply H0. apply encode_float_length.
+ destruct chunk; auto.
+ constructor. red. auto.
+ simpl; intros. intuition; subst mv; red; simpl; congruence.
+Qed.
+
+Lemma check_pointer_inv:
+ forall b ofs n mv,
+ check_pointer n b ofs mv = true -> mv = inj_pointer n b ofs.
+Proof.
+ induction n; destruct mv; simpl.
+ auto.
+ congruence.
+ congruence.
+ destruct m; try congruence. intro.
+ destruct (andb_prop _ _ H). destruct (andb_prop _ _ H0).
+ destruct (andb_prop _ _ H2).
+ decEq. decEq. symmetry; eapply proj_sumbool_true; eauto.
+ symmetry; eapply proj_sumbool_true; eauto.
+ symmetry; apply beq_nat_true; auto.
+ auto.
+Qed.
+
+Inductive decoding_shape: list memval -> Prop :=
+ | decoding_shape_intro: forall mv1 mvl,
+ memval_valid_first mv1 -> mv1 <> Undef ->
+ (forall mv, In mv mvl -> memval_valid_cont mv /\ mv <> Undef) ->
+ decoding_shape (mv1 :: mvl).
+
+Lemma decode_val_shape:
+ forall chunk mvl,
+ List.length mvl = size_chunk_nat chunk ->
+ decode_val chunk mvl = Vundef \/ decoding_shape mvl.
+Proof.
+ intros. destruct (size_chunk_nat_pos chunk) as [sz EQ].
+ unfold decode_val.
+ caseEq (proj_bytes mvl).
+ intros bl PROJ. right. exploit inj_proj_bytes; eauto. intros. subst mvl.
+ destruct bl; simpl in H. congruence. simpl. constructor.
+ red; auto. congruence.
+ unfold inj_bytes; intros. exploit list_in_map_inv; eauto. intros [b [A B]].
+ subst mv. split. red; auto. congruence.
+ intros. destruct chunk; auto. unfold proj_pointer.
+ destruct mvl; auto. destruct m; auto.
+ caseEq (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n :: mvl)); auto.
+ intros. right. exploit check_pointer_inv; eauto. simpl; intros; inv H2.
+ constructor. red. auto. congruence.
+ simpl; intros. intuition; subst mv; simpl; congruence.
+Qed.
+
+Lemma encode_val_pointer_inv:
+ forall chunk v b ofs n mvl,
+ encode_val chunk v = Pointer b ofs n :: mvl ->
+ chunk = Mint32 /\ v = Vptr b ofs /\ mvl = inj_pointer (pred (size_chunk_nat Mint32)) b ofs.
+Proof.
+ intros until mvl.
+ destruct (size_chunk_nat_pos chunk) as [sz SZ].
+ unfold encode_val. rewrite SZ. destruct v.
+ simpl. congruence.
+ generalize (encode_int_length chunk i). destruct (encode_int chunk i); simpl; congruence.
+ generalize (encode_float_length chunk f). destruct (encode_float chunk f); simpl; congruence.
+ destruct chunk; try (simpl; congruence).
+ simpl. intuition congruence.
+Qed.
+
+Lemma decode_val_pointer_inv:
+ forall chunk mvl b ofs,
+ decode_val chunk mvl = Vptr b ofs ->
+ chunk = Mint32 /\ mvl = inj_pointer (size_chunk_nat Mint32) b ofs.
+Proof.
+ intros until ofs; unfold decode_val.
+ destruct (proj_bytes mvl).
+ destruct chunk; congruence.
+ destruct chunk; try congruence.
+ unfold proj_pointer. destruct mvl. congruence. destruct m; try congruence.
+ case_eq (check_pointer (size_chunk_nat Mint32) b0 i (Pointer b0 i n :: mvl)); intros.
+ inv H0. split; auto. apply check_pointer_inv; auto.
+ congruence.
+Qed.
+
+Inductive pointer_encoding_shape: list memval -> Prop :=
+ | pointer_encoding_shape_intro: forall mv1 mvl,
+ ~memval_valid_cont mv1 ->
+ (forall mv, In mv mvl -> ~memval_valid_first mv) ->
+ pointer_encoding_shape (mv1 :: mvl).
+
+Lemma encode_pointer_shape:
+ forall b ofs, pointer_encoding_shape (encode_val Mint32 (Vptr b ofs)).
+Proof.
+ intros. simpl. constructor.
+ unfold memval_valid_cont. red; intro. elim H. auto.
+ unfold memval_valid_first. simpl; intros; intuition; subst mv; congruence.
+Qed.
+
+Lemma decode_pointer_shape:
+ forall chunk mvl b ofs,
+ decode_val chunk mvl = Vptr b ofs ->
+ chunk = Mint32 /\ pointer_encoding_shape mvl.
+Proof.
+ intros. exploit decode_val_pointer_inv; eauto. intros [A B].
+ split; auto. subst mvl. apply encode_pointer_shape.
+Qed.
+
+(*
+Lemma proj_bytes_none:
+ forall mv,
+ match mv with Byte _ => False | _ => True end ->
+ forall mvl,
+ In mv mvl ->
+ proj_bytes mvl = None.
+Proof.
+ induction mvl; simpl; intros.
+ elim H0.
+ destruct a; auto. destruct H0. subst mv. contradiction.
+ rewrite (IHmvl H0); auto.
+Qed.
+
+Lemma decode_val_undef:
+ forall chunk mv mv1 mvl,
+ match mv with
+ | Pointer b ofs n => n = pred (size_chunk_nat Mint32)
+ | Undef => True
+ | _ => False
+ end ->
+ In mv mvl ->
+ decode_val chunk (mv1 :: mvl) = Vundef.
+Proof.
+ intros. unfold decode_val.
+ replace (proj_bytes (mv1 :: mvl)) with (@None (list byte)).
+ destruct chunk; auto. unfold proj_pointer. destruct mv1; auto.
+ case_eq (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n :: mvl)); intros.
+ exploit check_pointer_inv; eauto. simpl. intros. inv H2.
+ simpl in H0. intuition; subst mv; simpl in H; congruence.
+ auto.
+ symmetry. apply proj_bytes_none with mv.
+ destruct mv; tauto. auto with coqlib.
+Qed.
+
+*)
+
+(** * Compatibility with memory injections *)
+
+(** Relating two memory values according to a memory injection. *)
+
+Inductive memval_inject (f: meminj): memval -> memval -> Prop :=
+ | memval_inject_byte:
+ forall n, memval_inject f (Byte n) (Byte n)
+ | memval_inject_ptr:
+ forall b1 ofs1 b2 ofs2 delta n,
+ f b1 = Some (b2, delta) ->
+ ofs2 = Int.add ofs1 (Int.repr delta) ->
+ memval_inject f (Pointer b1 ofs1 n) (Pointer b2 ofs2 n)
+ | memval_inject_undef:
+ forall mv, memval_inject f Undef mv.
+
+Lemma memval_inject_incr:
+ forall f f' v1 v2, memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2.
+Proof.
+ intros. inv H; econstructor. rewrite (H0 _ _ _ H1). reflexivity. auto.
+Qed.
+
+(** [decode_val], applied to lists of memory values that are pairwise
+ related by [memval_inject], returns values that are related by [val_inject]. *)
+
+Lemma proj_bytes_inject:
+ forall f vl vl',
+ list_forall2 (memval_inject f) vl vl' ->
+ forall bl,
+ proj_bytes vl = Some bl ->
+ proj_bytes vl' = Some bl.
+Proof.
+ induction 1; simpl. congruence.
+ inv H; try congruence.
+ destruct (proj_bytes al); intros.
+ inv H. rewrite (IHlist_forall2 l); auto.
+ congruence.
+Qed.
+
+Lemma check_pointer_inject:
+ forall f vl vl',
+ list_forall2 (memval_inject f) vl vl' ->
+ forall n b ofs b' delta,
+ check_pointer n b ofs vl = true ->
+ f b = Some(b', delta) ->
+ check_pointer n b' (Int.add ofs (Int.repr delta)) vl' = true.
+Proof.
+ induction 1; intros; destruct n; simpl in *; auto.
+ inv H; auto.
+ destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H).
+ destruct (andb_prop _ _ H5).
+ assert (n = n0) by (apply beq_nat_true; auto).
+ assert (b = b0) by (eapply proj_sumbool_true; eauto).
+ assert (ofs = ofs1) by (eapply proj_sumbool_true; eauto).
+ subst. rewrite H3 in H2; inv H2.
+ unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_true.
+ rewrite <- beq_nat_refl. simpl. eauto.
+ congruence.
+Qed.
+
+Lemma proj_pointer_inject:
+ forall f vl1 vl2,
+ list_forall2 (memval_inject f) vl1 vl2 ->
+ val_inject f (proj_pointer vl1) (proj_pointer vl2).
+Proof.
+ intros. unfold proj_pointer.
+ inversion H; subst. auto. inversion H0; subst; auto.
+ case_eq (check_pointer (size_chunk_nat Mint32) b0 ofs1 (Pointer b0 ofs1 n :: al)); intros.
+ exploit check_pointer_inject. eexact H. eauto. eauto.
+ intro. rewrite H4. econstructor; eauto.
+ constructor.
+Qed.
+
+Lemma proj_bytes_not_inject:
+ forall f vl vl',
+ list_forall2 (memval_inject f) vl vl' ->
+ proj_bytes vl = None -> proj_bytes vl' <> None -> In Undef vl.
+Proof.
+ induction 1; simpl; intros.
+ congruence.
+ inv H; try congruence.
+ right. apply IHlist_forall2.
+ destruct (proj_bytes al); congruence.
+ destruct (proj_bytes bl); congruence.
+ auto.
+Qed.
+
+Lemma check_pointer_undef:
+ forall n b ofs vl,
+ In Undef vl -> check_pointer n b ofs vl = false.
+Proof.
+ induction n; intros; simpl.
+ destruct vl. elim H. auto.
+ destruct vl. auto.
+ destruct m; auto. simpl in H; destruct H. congruence.
+ rewrite IHn; auto. apply andb_false_r.
+Qed.
+
+Lemma proj_pointer_undef:
+ forall vl, In Undef vl -> proj_pointer vl = Vundef.
+Proof.
+ intros; unfold proj_pointer.
+ destruct vl; auto. destruct m; auto.
+ rewrite check_pointer_undef. auto. auto.
+Qed.
+
+Theorem decode_val_inject:
+ forall f vl1 vl2 chunk,
+ list_forall2 (memval_inject f) vl1 vl2 ->
+ val_inject f (decode_val chunk vl1) (decode_val chunk vl2).
+Proof.
+ intros. unfold decode_val.
+ case_eq (proj_bytes vl1); intros.
+ exploit proj_bytes_inject; eauto. intros. rewrite H1.
+ destruct chunk; constructor.
+ destruct chunk; auto.
+ case_eq (proj_bytes vl2); intros.
+ rewrite proj_pointer_undef. auto. eapply proj_bytes_not_inject; eauto. congruence.
+ apply proj_pointer_inject; auto.
+Qed.
+
+(** Symmetrically, [encode_val], applied to values related by [val_inject],
+ returns lists of memory values that are pairwise
+ related by [memval_inject]. *)
+
+Lemma inj_bytes_inject:
+ forall f bl, list_forall2 (memval_inject f) (inj_bytes bl) (inj_bytes bl).
+Proof.
+ induction bl; constructor; auto. constructor.
+Qed.
+
+Lemma repeat_Undef_inject_any:
+ forall f vl,
+ list_forall2 (memval_inject f) (list_repeat (length vl) Undef) vl.
+Proof.
+ induction vl; simpl; constructor; auto. constructor.
+Qed.
+
+Lemma repeat_Undef_inject_self:
+ forall f n,
+ list_forall2 (memval_inject f) (list_repeat n Undef) (list_repeat n Undef).
+Proof.
+ induction n; simpl; constructor; auto. constructor.
+Qed.
+
+Theorem encode_val_inject:
+ forall f v1 v2 chunk,
+ val_inject f v1 v2 ->
+ list_forall2 (memval_inject f) (encode_val chunk v1) (encode_val chunk v2).
+Proof.
+ intros. inv H; simpl.
+ apply inj_bytes_inject.
+ apply inj_bytes_inject.
+ destruct chunk; try apply repeat_Undef_inject_self.
+ unfold inj_pointer; simpl; repeat econstructor; auto.
+ replace (size_chunk_nat chunk) with (length (encode_val chunk v2)).
+ apply repeat_Undef_inject_any. apply encode_val_length.
+Qed.
+
+(** The identity injection has interesting properties. *)
+
+Definition inject_id : meminj := fun b => Some(b, 0).
+
+Lemma val_inject_id:
+ forall v1 v2,
+ val_inject inject_id v1 v2 <-> Val.lessdef v1 v2.
+Proof.
+ intros; split; intros.
+ inv H. constructor. constructor.
+ unfold inject_id in H0. inv H0. rewrite Int.add_zero. constructor.
+ constructor.
+ inv H. destruct v2; econstructor. unfold inject_id; reflexivity. rewrite Int.add_zero; auto.
+ constructor.
+Qed.
+
+Lemma memval_inject_id:
+ forall mv, memval_inject inject_id mv mv.
+Proof.
+ destruct mv; econstructor. unfold inject_id; reflexivity. rewrite Int.add_zero; auto.
+Qed.
+
diff --git a/common/Memdataaux.ml b/common/Memdataaux.ml
new file mode 100644
index 0000000..3a39428
--- /dev/null
+++ b/common/Memdataaux.ml
@@ -0,0 +1,68 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+open Camlcoq
+open Integers
+open AST
+
+let big_endian =
+ match Configuration.arch with
+ | "powerpc" -> true
+ | "arm" -> false
+ | _ -> assert false
+
+let encode_float chunk f =
+ match chunk with
+ | Mint8unsigned | Mint8signed ->
+ [Byte.zero]
+ | Mint16unsigned | Mint16signed ->
+ [Byte.zero; Byte.zero]
+ | Mint32 ->
+ [Byte.zero; Byte.zero; Byte.zero; Byte.zero]
+ | Mfloat32 ->
+ let bits = Int32.bits_of_float f in
+ let byte n =
+ coqint_of_camlint
+ (Int32.logand (Int32.shift_right_logical bits n) 0xFFl) in
+ if big_endian then
+ [byte 24; byte 16; byte 8; byte 0]
+ else
+ [byte 0; byte 8; byte 16; byte 24]
+ | Mfloat64 ->
+ let bits = Int64.bits_of_float f in
+ let byte n =
+ coqint_of_camlint
+ (Int64.to_int32
+ (Int64.logand (Int64.shift_right_logical bits n) 0xFFL)) in
+ if big_endian then
+ [byte 56; byte 48; byte 40; byte 32; byte 24; byte 16; byte 8; byte 0]
+ else
+ [byte 0; byte 8; byte 16; byte 24; byte 32; byte 40; byte 48; byte 56]
+
+let decode_float chunk bytes =
+ match chunk with
+ | Mfloat32 ->
+ let combine accu b =
+ Int32.logor (Int32.shift_left accu 8) (camlint_of_coqint b) in
+ Int32.float_of_bits
+ (List.fold_left combine 0l
+ (if big_endian then bytes else List.rev bytes))
+ | Mfloat64 ->
+ let combine accu b =
+ Int64.logor (Int64.shift_left accu 8)
+ (Int64.of_int32 (camlint_of_coqint b)) in
+ Int64.float_of_bits
+ (List.fold_left combine 0L
+ (if big_endian then bytes else List.rev bytes))
+ | _ ->
+ 0.0 (* unspecified *)
+
diff --git a/common/Memory.v b/common/Memory.v
new file mode 100644
index 0000000..3092021
--- /dev/null
+++ b/common/Memory.v
@@ -0,0 +1,2844 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* Sandrine Blazy, ENSIIE and 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 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. *)
+(* *)
+(* *********************************************************************)
+
+(** This file develops the memory model that is used in the dynamic
+ semantics of all the languages used in the compiler.
+ It defines a type [mem] of memory states, the following 4 basic
+ operations over memory states, and their properties:
+- [load]: read a memory chunk at a given address;
+- [store]: store a memory chunk at a given address;
+- [alloc]: allocate a fresh memory block;
+- [free]: invalidate a memory block.
+*)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Export Memdata.
+Require Export Memtype.
+
+Definition update (A: Type) (x: Z) (v: A) (f: Z -> A) : Z -> A :=
+ fun y => if zeq y x then v else f y.
+
+Implicit Arguments update [A].
+
+Lemma update_s:
+ forall (A: Type) (x: Z) (v: A) (f: Z -> A),
+ update x v f x = v.
+Proof.
+ intros; unfold update. apply zeq_true.
+Qed.
+
+Lemma update_o:
+ forall (A: Type) (x: Z) (v: A) (f: Z -> A) (y: Z),
+ x <> y -> update x v f y = f y.
+Proof.
+ intros; unfold update. apply zeq_false; auto.
+Qed.
+
+Module Mem : MEM.
+
+Record mem_ : Type := mkmem {
+ contents: block -> Z -> memval;
+ access: block -> Z -> bool;
+ bound: block -> Z * Z;
+ next: block;
+ next_pos: next > 0;
+ next_noaccess: forall b ofs, b >= next -> access b ofs = false;
+ bound_noaccess: forall b ofs, ofs < fst(bound b) \/ ofs >= snd(bound b) -> access b ofs = false
+}.
+
+Definition mem := mem_.
+
+(** * Validity of blocks and accesses *)
+
+(** A block address is valid if it was previously allocated. It remains valid
+ even after being freed. *)
+
+Definition nextblock (m: mem) : block := m.(next).
+
+Theorem nextblock_pos:
+ forall m, nextblock m > 0.
+Proof next_pos.
+
+Definition valid_block (m: mem) (b: block) :=
+ b < nextblock m.
+
+Theorem valid_not_valid_diff:
+ forall m b b', valid_block m b -> ~(valid_block m b') -> b <> b'.
+Proof.
+ intros; red; intros. subst b'. contradiction.
+Qed.
+
+Hint Local Resolve valid_not_valid_diff: mem.
+
+(** Permissions *)
+
+Definition perm (m: mem) (b: block) (ofs: Z) (p: permission) : Prop :=
+ m.(access) b ofs = true.
+
+Theorem perm_implies:
+ forall m b ofs p1 p2, perm m b ofs p1 -> perm_order p1 p2 -> perm m b ofs p2.
+Proof.
+ unfold perm; auto.
+Qed.
+
+Hint Local Resolve perm_implies: mem.
+
+Theorem perm_valid_block:
+ forall m b ofs p, perm m b ofs p -> valid_block m b.
+Proof.
+ unfold perm; intros.
+ destruct (zlt b m.(next)).
+ auto.
+ assert (access m b ofs = false). eapply next_noaccess; eauto.
+ congruence.
+Qed.
+
+Hint Local Resolve perm_valid_block: mem.
+
+Theorem perm_dec:
+ forall m b ofs p, {perm m b ofs p} + {~ perm m b ofs p}.
+Proof.
+ unfold perm; intros.
+ destruct (access m b ofs). left; auto. right; congruence.
+Qed.
+
+Definition range_perm (m: mem) (b: block) (lo hi: Z) (p: permission) : Prop :=
+ forall ofs, lo <= ofs < hi -> perm m b ofs p.
+
+Theorem range_perm_implies:
+ forall m b lo hi p1 p2,
+ range_perm m b lo hi p1 -> perm_order p1 p2 -> range_perm m b lo hi p2.
+Proof.
+ unfold range_perm; intros; eauto with mem.
+Qed.
+
+Hint Local Resolve range_perm_implies: mem.
+
+Lemma range_perm_dec:
+ forall m b lo hi p, {range_perm m b lo hi p} + {~ range_perm m b lo hi p}.
+Proof.
+ intros.
+ assert (forall n, 0 <= n ->
+ {range_perm m b lo (lo + n) p} + {~ range_perm m b lo (lo + n) p}).
+ apply natlike_rec2.
+ left. red; intros. omegaContradiction.
+ intros. destruct H0.
+ destruct (perm_dec m b (lo + z) p).
+ left. red; intros. destruct (zeq ofs (lo + z)). congruence. apply r. omega.
+ right; red; intro. elim n. apply H0. omega.
+ right; red; intro. elim n. red; intros. apply H0. omega.
+ destruct (zlt lo hi).
+ replace hi with (lo + (hi - lo)) by omega. apply H. omega.
+ left; red; intros. omegaContradiction.
+Qed.
+
+(** [valid_access m chunk b ofs p] holds if a memory access
+ of the given chunk is possible in [m] at address [b, ofs]
+ with permissions [p].
+ This means:
+- The range of bytes accessed all have permission [p].
+- The offset [ofs] is aligned.
+*)
+
+Definition valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) (p: permission): Prop :=
+ range_perm m b ofs (ofs + size_chunk chunk) p
+ /\ (align_chunk chunk | ofs).
+
+Theorem valid_access_writable_any:
+ forall m chunk b ofs p,
+ valid_access m chunk b ofs Writable ->
+ valid_access m chunk b ofs p.
+Proof.
+ intros. inv H. constructor; auto with mem.
+Qed.
+
+Theorem valid_access_implies:
+ forall m chunk b ofs p1 p2,
+ valid_access m chunk b ofs p1 -> perm_order p1 p2 ->
+ valid_access m chunk b ofs p2.
+Proof.
+ intros. inv H. constructor; eauto with mem.
+Qed.
+
+Hint Local Resolve valid_access_implies: mem.
+
+Theorem valid_access_valid_block:
+ forall m chunk b ofs,
+ valid_access m chunk b ofs Nonempty ->
+ valid_block m b.
+Proof.
+ intros. destruct H.
+ assert (perm m b ofs Nonempty).
+ apply H. generalize (size_chunk_pos chunk). omega.
+ eauto with mem.
+Qed.
+
+Hint Local Resolve valid_access_valid_block: mem.
+
+Lemma valid_access_perm:
+ forall m chunk b ofs p,
+ valid_access m chunk b ofs p ->
+ perm m b ofs p.
+Proof.
+ intros. destruct H. apply H. generalize (size_chunk_pos chunk). omega.
+Qed.
+
+Lemma valid_access_compat:
+ forall m chunk1 chunk2 b ofs p,
+ size_chunk chunk1 = size_chunk chunk2 ->
+ valid_access m chunk1 b ofs p->
+ valid_access m chunk2 b ofs p.
+Proof.
+ intros. inv H0. rewrite H in H1. constructor; auto.
+ rewrite <- (align_chunk_compat _ _ H). auto.
+Qed.
+
+Lemma valid_access_dec:
+ forall m chunk b ofs p,
+ {valid_access m chunk b ofs p} + {~ valid_access m chunk b ofs p}.
+Proof.
+ intros.
+ destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) p).
+ destruct (Zdivide_dec (align_chunk chunk) ofs (align_chunk_pos chunk)).
+ left; constructor; auto.
+ right; red; intro V; inv V; contradiction.
+ right; red; intro V; inv V; contradiction.
+Qed.
+
+(** [valid_pointer] is a boolean-valued function that says whether
+ the byte at the given location is nonempty. *)
+
+Definition valid_pointer (m: mem) (b: block) (ofs: Z): bool :=
+ perm_dec m b ofs Nonempty.
+
+Theorem valid_pointer_nonempty_perm:
+ forall m b ofs,
+ valid_pointer m b ofs = true <-> perm m b ofs Nonempty.
+Proof.
+ intros. unfold valid_pointer.
+ destruct (perm_dec m b ofs Nonempty); simpl;
+ intuition congruence.
+Qed.
+
+Theorem valid_pointer_valid_access:
+ forall m b ofs,
+ valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty.
+Proof.
+ intros. rewrite valid_pointer_nonempty_perm.
+ split; intros.
+ split. simpl; red; intros. replace ofs0 with ofs by omega. auto.
+ simpl. apply Zone_divide.
+ destruct H. apply H. simpl. omega.
+Qed.
+
+(** Bounds *)
+
+(** Each block has a low bound and a high bound, determined at allocation time
+ and invariant afterward. The crucial properties of bounds is
+ that any offset below the low bound or above the high bound is
+ empty. *)
+
+Definition bounds (m: mem) (b: block) : Z*Z := m.(bound) b.
+
+Notation low_bound m b := (fst(bounds m b)).
+Notation high_bound m b := (snd(bounds m b)).
+
+Theorem perm_in_bounds:
+ forall m b ofs p, perm m b ofs p -> low_bound m b <= ofs < high_bound m b.
+Proof.
+ unfold perm, bounds. intros.
+ destruct (zlt ofs (fst (bound m b))).
+ exploit bound_noaccess. left; eauto. congruence.
+ destruct (zlt ofs (snd (bound m b))).
+ omega.
+ exploit bound_noaccess. right; eauto. congruence.
+Qed.
+
+Theorem range_perm_in_bounds:
+ forall m b lo hi p,
+ range_perm m b lo hi p -> lo < hi -> low_bound m b <= lo /\ hi <= high_bound m b.
+Proof.
+ intros. split.
+ exploit (perm_in_bounds m b lo p). apply H. omega. omega.
+ exploit (perm_in_bounds m b (hi-1) p). apply H. omega. omega.
+Qed.
+
+Theorem valid_access_in_bounds:
+ forall m chunk b ofs p,
+ valid_access m chunk b ofs p ->
+ low_bound m b <= ofs /\ ofs + size_chunk chunk <= high_bound m b.
+Proof.
+ intros. inv H. apply range_perm_in_bounds with p; auto.
+ generalize (size_chunk_pos chunk). omega.
+Qed.
+
+Hint Local Resolve perm_in_bounds range_perm_in_bounds valid_access_in_bounds.
+
+(** * Store operations *)
+
+(** The initial store *)
+
+Program Definition empty: mem :=
+ mkmem (fun b ofs => Undef)
+ (fun b ofs => false)
+ (fun b => (0,0))
+ 1 _ _ _.
+Next Obligation.
+ omega.
+Qed.
+
+Definition nullptr: block := 0.
+
+(** Allocation of a fresh block with the given bounds. Return an updated
+ memory state and the address of the fresh block, which initially contains
+ undefined cells. Note that allocation never fails: we model an
+ infinite memory. *)
+
+Program Definition alloc (m: mem) (lo hi: Z) :=
+ (mkmem (update m.(next)
+ (fun ofs => Undef)
+ m.(contents))
+ (update m.(next)
+ (fun ofs => zle lo ofs && zlt ofs hi)
+ m.(access))
+ (update m.(next) (lo, hi) m.(bound))
+ (Zsucc m.(next))
+ _ _ _,
+ m.(next)).
+Next Obligation.
+ generalize (next_pos m). omega.
+Qed.
+Next Obligation.
+ rewrite update_o. apply next_noaccess. omega. omega.
+Qed.
+Next Obligation.
+ unfold update in *. destruct (zeq b (next m)).
+ simpl in H. destruct H.
+ unfold proj_sumbool. rewrite zle_false. auto. omega.
+ unfold proj_sumbool. rewrite zlt_false. apply andb_false_r. auto.
+ apply bound_noaccess. auto.
+Qed.
+
+(** Freeing a block between the given bounds.
+ Return the updated memory state where the given range of the given block
+ has been invalidated: future reads and writes to this
+ range will fail. Requires write permission on the given range. *)
+
+Program Definition unchecked_free (m: mem) (b: block) (lo hi: Z): mem :=
+ mkmem m.(contents)
+ (update b
+ (fun ofs => if zle lo ofs && zlt ofs hi then false else m.(access) b ofs)
+ m.(access))
+ m.(bound)
+ m.(next) _ _ _.
+Next Obligation.
+ apply next_pos.
+Qed.
+Next Obligation.
+ unfold update. destruct (zeq b0 b). subst b0.
+ destruct (zle lo ofs); simpl; auto.
+ destruct (zlt ofs hi); simpl; auto.
+ apply next_noaccess; auto.
+ apply next_noaccess; auto.
+ apply next_noaccess; auto.
+Qed.
+Next Obligation.
+ unfold update. destruct (zeq b0 b). subst b0.
+ destruct (zle lo ofs); simpl; auto.
+ destruct (zlt ofs hi); simpl; auto.
+ apply bound_noaccess; auto.
+ apply bound_noaccess; auto.
+ apply bound_noaccess; auto.
+Qed.
+
+Definition free (m: mem) (b: block) (lo hi: Z): option mem :=
+ if range_perm_dec m b lo hi Freeable
+ then Some(unchecked_free m b lo hi)
+ else None.
+
+Fixpoint free_list (m: mem) (l: list (block * Z * Z)) {struct l}: option mem :=
+ match l with
+ | nil => Some m
+ | (b, lo, hi) :: l' =>
+ match free m b lo hi with
+ | None => None
+ | Some m' => free_list m' l'
+ end
+ end.
+
+(** Memory reads. *)
+
+(** Reading N adjacent bytes in a block content. *)
+
+Fixpoint getN (n: nat) (p: Z) (c: Z -> memval) {struct n}: list memval :=
+ match n with
+ | O => nil
+ | S n' => c p :: getN n' (p + 1) c
+ end.
+
+(** [load chunk m b ofs] perform a read in memory state [m], at address
+ [b] and offset [ofs]. It returns the value of the memory chunk
+ at that address. [None] is returned if the accessed bytes
+ are not readable. *)
+
+Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z): option val :=
+ if valid_access_dec m chunk b ofs Readable
+ then Some(decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(contents) b)))
+ else None.
+
+(** [loadv chunk m addr] is similar, but the address and offset are given
+ as a single value [addr], which must be a pointer value. *)
+
+Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val :=
+ match addr with
+ | Vptr b ofs => load chunk m b (Int.signed ofs)
+ | _ => None
+ end.
+
+(** [loadbytes m b ofs n] reads [n] consecutive bytes starting at
+ location [(b, ofs)]. Returns [None] if the accessed locations are
+ not readable or do not contain bytes. *)
+
+Definition loadbytes (m: mem) (b: block) (ofs n: Z): option (list byte) :=
+ if range_perm_dec m b ofs (ofs + n) Readable
+ then proj_bytes (getN (nat_of_Z n) ofs (m.(contents) b))
+ else None.
+
+(** Memory stores. *)
+
+(** Writing N adjacent bytes in a block content. *)
+
+Fixpoint setN (vl: list memval) (p: Z) (c: Z -> memval) {struct vl}: Z -> memval :=
+ match vl with
+ | nil => c
+ | v :: vl' => setN vl' (p + 1) (update p v c)
+ end.
+
+Definition unchecked_store (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val): mem :=
+ mkmem (update b
+ (setN (encode_val chunk v) ofs (m.(contents) b))
+ m.(contents))
+ m.(access)
+ m.(bound)
+ m.(next)
+ m.(next_pos)
+ m.(next_noaccess)
+ m.(bound_noaccess).
+
+(** [store chunk m b ofs v] perform a write in memory state [m].
+ Value [v] is stored at address [b] and offset [ofs].
+ Return the updated memory store, or [None] if the accessed bytes
+ are not writable. *)
+
+Definition store (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val): option mem :=
+ if valid_access_dec m chunk b ofs Writable
+ then Some(unchecked_store chunk m b ofs v)
+ else None.
+
+(** [storev chunk m addr v] is similar, but the address and offset are given
+ as a single value [addr], which must be a pointer value. *)
+
+Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem :=
+ match addr with
+ | Vptr b ofs => store chunk m b (Int.signed ofs) v
+ | _ => None
+ end.
+
+(** * Properties of the memory operations *)
+
+(** Properties of the empty store. *)
+
+Theorem nextblock_empty: nextblock empty = 1.
+Proof. reflexivity. Qed.
+
+Theorem perm_empty: forall b ofs p, ~perm empty b ofs p.
+Proof.
+ intros. unfold perm, empty; simpl. congruence.
+Qed.
+
+Theorem valid_access_empty: forall chunk b ofs p, ~valid_access empty chunk b ofs p.
+Proof.
+ intros. red; intros. elim (perm_empty b ofs p). apply H.
+ generalize (size_chunk_pos chunk); omega.
+Qed.
+
+(** ** Properties related to [load] *)
+
+Theorem valid_access_load:
+ forall m chunk b ofs,
+ valid_access m chunk b ofs Readable ->
+ exists v, load chunk m b ofs = Some v.
+Proof.
+ intros. econstructor. unfold load. rewrite pred_dec_true; eauto.
+Qed.
+
+Theorem load_valid_access:
+ forall m chunk b ofs v,
+ load chunk m b ofs = Some v ->
+ valid_access m chunk b ofs Readable.
+Proof.
+ intros until v. unfold load.
+ destruct (valid_access_dec m chunk b ofs Readable); intros.
+ auto.
+ congruence.
+Qed.
+
+Lemma load_result:
+ forall chunk m b ofs v,
+ load chunk m b ofs = Some v ->
+ v = decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(contents) b)).
+Proof.
+ intros until v. unfold load.
+ destruct (valid_access_dec m chunk b ofs Readable); intros.
+ congruence.
+ congruence.
+Qed.
+
+Hint Local Resolve load_valid_access valid_access_load: mem.
+
+Theorem load_type:
+ forall m chunk b ofs v,
+ load chunk m b ofs = Some v ->
+ Val.has_type v (type_of_chunk chunk).
+Proof.
+ intros. exploit load_result; eauto; intros. rewrite H0.
+ apply decode_val_type.
+Qed.
+
+Theorem load_cast:
+ forall m chunk b ofs v,
+ load chunk m b ofs = Some v ->
+ match chunk with
+ | Mint8signed => v = Val.sign_ext 8 v
+ | Mint8unsigned => v = Val.zero_ext 8 v
+ | Mint16signed => v = Val.sign_ext 16 v
+ | Mint16unsigned => v = Val.zero_ext 16 v
+ | Mfloat32 => v = Val.singleoffloat v
+ | _ => True
+ end.
+Proof.
+ intros. exploit load_result; eauto.
+ set (l := getN (size_chunk_nat chunk) ofs (contents m b)).
+ intros. subst v. apply decode_val_cast.
+Qed.
+
+Theorem load_int8_signed_unsigned:
+ forall m b ofs,
+ load Mint8signed m b ofs = option_map (Val.sign_ext 8) (load Mint8unsigned m b ofs).
+Proof.
+ intros. unfold load.
+ change (size_chunk_nat Mint8signed) with (size_chunk_nat Mint8unsigned).
+ set (cl := getN (size_chunk_nat Mint8unsigned) ofs (contents m b)).
+ destruct (valid_access_dec m Mint8signed b ofs Readable).
+ rewrite pred_dec_true; auto. unfold decode_val.
+ destruct (proj_bytes cl); auto. rewrite decode_int8_signed_unsigned. auto.
+ rewrite pred_dec_false; auto.
+Qed.
+
+Theorem load_int16_signed_unsigned:
+ forall m b ofs,
+ load Mint16signed m b ofs = option_map (Val.sign_ext 16) (load Mint16unsigned m b ofs).
+Proof.
+ intros. unfold load.
+ change (size_chunk_nat Mint16signed) with (size_chunk_nat Mint16unsigned).
+ set (cl := getN (size_chunk_nat Mint16unsigned) ofs (contents m b)).
+ destruct (valid_access_dec m Mint16signed b ofs Readable).
+ rewrite pred_dec_true; auto. unfold decode_val.
+ destruct (proj_bytes cl); auto. rewrite decode_int16_signed_unsigned. auto.
+ rewrite pred_dec_false; auto.
+Qed.
+
+Theorem loadbytes_load:
+ forall chunk m b ofs bytes,
+ loadbytes m b ofs (size_chunk chunk) = Some bytes ->
+ (align_chunk chunk | ofs) ->
+ load chunk m b ofs =
+ Some(match type_of_chunk chunk with
+ | Tint => Vint(decode_int chunk bytes)
+ | Tfloat => Vfloat(decode_float chunk bytes)
+ end).
+Proof.
+ unfold loadbytes, load; intros.
+ destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) Readable);
+ try congruence.
+ rewrite pred_dec_true. decEq. unfold size_chunk_nat.
+ unfold decode_val; rewrite H. destruct chunk; auto.
+ split; auto.
+Qed.
+
+Theorem load_int_loadbytes:
+ forall chunk m b ofs n,
+ load chunk m b ofs = Some(Vint n) ->
+ type_of_chunk chunk = Tint /\
+ exists bytes, loadbytes m b ofs (size_chunk chunk) = Some bytes
+ /\ n = decode_int chunk bytes.
+Proof.
+ intros. exploit load_valid_access; eauto. intros [A B].
+ exploit decode_val_int_inv. symmetry. eapply load_result; eauto.
+ intros [C [bytes [D E]]].
+ split. auto. exists bytes; split.
+ unfold loadbytes. rewrite pred_dec_true; auto. auto.
+Qed.
+
+Theorem load_float_loadbytes:
+ forall chunk m b ofs f,
+ load chunk m b ofs = Some(Vfloat f) ->
+ type_of_chunk chunk = Tfloat /\
+ exists bytes, loadbytes m b ofs (size_chunk chunk) = Some bytes
+ /\ f = decode_float chunk bytes.
+Proof.
+ intros. exploit load_valid_access; eauto. intros [A B].
+ exploit decode_val_float_inv. symmetry. eapply load_result; eauto.
+ intros [C [bytes [D E]]].
+ split. auto. exists bytes; split.
+ unfold loadbytes. rewrite pred_dec_true; auto. auto.
+Qed.
+
+Lemma getN_length:
+ forall c n p, length (getN n p c) = n.
+Proof.
+ induction n; simpl; intros. auto. decEq; auto.
+Qed.
+
+Theorem loadbytes_length:
+ forall m b ofs n bytes,
+ loadbytes m b ofs n = Some bytes ->
+ length bytes = nat_of_Z n.
+Proof.
+ unfold loadbytes; intros.
+ destruct (range_perm_dec m b ofs (ofs + n) Readable); try congruence.
+ exploit inj_proj_bytes; eauto. intros.
+ transitivity (length (inj_bytes bytes)).
+ symmetry. unfold inj_bytes. apply List.map_length.
+ rewrite <- H0. apply getN_length.
+Qed.
+
+Lemma getN_concat:
+ forall c n1 n2 p,
+ getN (n1 + n2)%nat p c = getN n1 p c ++ getN n2 (p + Z_of_nat n1) c.
+Proof.
+ induction n1; intros.
+ simpl. decEq. omega.
+ rewrite inj_S. simpl. decEq.
+ replace (p + Zsucc (Z_of_nat n1)) with ((p + 1) + Z_of_nat n1) by omega.
+ auto.
+Qed.
+
+Theorem loadbytes_concat:
+ forall m b ofs n1 n2 bytes1 bytes2,
+ loadbytes m b ofs n1 = Some bytes1 ->
+ loadbytes m b (ofs + n1) n2 = Some bytes2 ->
+ n1 >= 0 -> n2 >= 0 ->
+ loadbytes m b ofs (n1 + n2) = Some(bytes1 ++ bytes2).
+Proof.
+ unfold loadbytes; intros.
+ destruct (range_perm_dec m b ofs (ofs + n1) Readable); try congruence.
+ destruct (range_perm_dec m b (ofs + n1) (ofs + n1 + n2) Readable); try congruence.
+ rewrite pred_dec_true. rewrite nat_of_Z_plus; auto.
+ rewrite getN_concat. rewrite nat_of_Z_eq; auto.
+ rewrite (inj_proj_bytes _ _ H). rewrite (inj_proj_bytes _ _ H0).
+ unfold inj_bytes. rewrite <- List.map_app. apply proj_inj_bytes.
+ red; intros.
+ assert (ofs0 < ofs + n1 \/ ofs0 >= ofs + n1) by omega.
+ destruct H4. apply r; omega. apply r0; omega.
+Qed.
+
+Theorem loadbytes_split:
+ forall m b ofs n1 n2 bytes,
+ loadbytes m b ofs (n1 + n2) = Some bytes ->
+ n1 >= 0 -> n2 >= 0 ->
+ exists bytes1, exists bytes2,
+ loadbytes m b ofs n1 = Some bytes1
+ /\ loadbytes m b (ofs + n1) n2 = Some bytes2
+ /\ bytes = bytes1 ++ bytes2.
+Proof.
+ unfold loadbytes; intros.
+ destruct (range_perm_dec m b ofs (ofs + (n1 + n2)) Readable);
+ try congruence.
+ rewrite nat_of_Z_plus in H; auto. rewrite getN_concat in H.
+ rewrite nat_of_Z_eq in H; auto.
+ repeat rewrite pred_dec_true.
+ exploit inj_proj_bytes; eauto. unfold inj_bytes. intros.
+ exploit list_append_map_inv; eauto. intros [l1 [l2 [P [Q R]]]].
+ exists l1; exists l2; intuition.
+ rewrite <- P. apply proj_inj_bytes.
+ rewrite <- Q. apply proj_inj_bytes.
+ red; intros; apply r; omega.
+ red; intros; apply r; omega.
+Qed.
+
+(** ** Properties related to [store] *)
+
+Theorem valid_access_store:
+ forall m1 chunk b ofs v,
+ valid_access m1 chunk b ofs Writable ->
+ { m2: mem | store chunk m1 b ofs v = Some m2 }.
+Proof.
+ intros. econstructor. unfold store. rewrite pred_dec_true; auto.
+Qed.
+
+Hint Local Resolve valid_access_store: mem.
+
+Section STORE.
+Variable chunk: memory_chunk.
+Variable m1: mem.
+Variable b: block.
+Variable ofs: Z.
+Variable v: val.
+Variable m2: mem.
+Hypothesis STORE: store chunk m1 b ofs v = Some m2.
+
+Lemma store_result:
+ m2 = unchecked_store chunk m1 b ofs v.
+Proof.
+ unfold store in STORE.
+ destruct (valid_access_dec m1 chunk b ofs Writable).
+ congruence.
+ congruence.
+Qed.
+
+Theorem perm_store_1:
+ forall b' ofs' p, perm m1 b' ofs' p -> perm m2 b' ofs' p.
+Proof.
+ intros. rewrite store_result. exact H.
+Qed.
+
+Theorem perm_store_2:
+ forall b' ofs' p, perm m2 b' ofs' p -> perm m1 b' ofs' p.
+Proof.
+ intros. rewrite store_result in H. exact H.
+Qed.
+
+Hint Local Resolve perm_store_1 perm_store_2: mem.
+
+Theorem nextblock_store:
+ nextblock m2 = nextblock m1.
+Proof.
+ intros. rewrite store_result. reflexivity.
+Qed.
+
+Theorem store_valid_block_1:
+ forall b', valid_block m1 b' -> valid_block m2 b'.
+Proof.
+ unfold valid_block; intros. rewrite nextblock_store; auto.
+Qed.
+
+Theorem store_valid_block_2:
+ forall b', valid_block m2 b' -> valid_block m1 b'.
+Proof.
+ unfold valid_block; intros. rewrite nextblock_store in H; auto.
+Qed.
+
+Hint Local Resolve store_valid_block_1 store_valid_block_2: mem.
+
+Theorem store_valid_access_1:
+ forall chunk' b' ofs' p,
+ valid_access m1 chunk' b' ofs' p -> valid_access m2 chunk' b' ofs' p.
+Proof.
+ intros. inv H. constructor; try red; auto with mem.
+Qed.
+
+Theorem store_valid_access_2:
+ forall chunk' b' ofs' p,
+ valid_access m2 chunk' b' ofs' p -> valid_access m1 chunk' b' ofs' p.
+Proof.
+ intros. inv H. constructor; try red; auto with mem.
+Qed.
+
+Theorem store_valid_access_3:
+ valid_access m1 chunk b ofs Writable.
+Proof.
+ unfold store in STORE. destruct (valid_access_dec m1 chunk b ofs Writable).
+ auto.
+ congruence.
+Qed.
+
+Hint Local Resolve store_valid_access_1 store_valid_access_2
+ store_valid_access_3: mem.
+
+Theorem bounds_store:
+ forall b', bounds m2 b' = bounds m1 b'.
+Proof.
+ intros. rewrite store_result. simpl. auto.
+Qed.
+
+Remark setN_other:
+ forall vl c p q,
+ (forall r, p <= r < p + Z_of_nat (length vl) -> r <> q) ->
+ setN vl p c q = c q.
+Proof.
+ induction vl; intros; simpl.
+ auto.
+ simpl length in H. rewrite inj_S in H.
+ transitivity (update p a c q).
+ apply IHvl. intros. apply H. omega.
+ apply update_o. apply H. omega.
+Qed.
+
+Remark setN_outside:
+ forall vl c p q,
+ q < p \/ q >= p + Z_of_nat (length vl) ->
+ setN vl p c q = c q.
+Proof.
+ intros. apply setN_other.
+ intros. omega.
+Qed.
+
+Remark getN_setN_same:
+ forall vl p c,
+ getN (length vl) p (setN vl p c) = vl.
+Proof.
+ induction vl; intros; simpl.
+ auto.
+ decEq.
+ rewrite setN_outside. apply update_s. omega.
+ apply IHvl.
+Qed.
+
+Remark getN_setN_outside:
+ forall vl q c n p,
+ p + Z_of_nat n <= q \/ q + Z_of_nat (length vl) <= p ->
+ getN n p (setN vl q c) = getN n p c.
+Proof.
+ induction n; intros; simpl.
+ auto.
+ rewrite inj_S in H. decEq.
+ apply setN_outside. omega.
+ apply IHn. omega.
+Qed.
+
+Theorem load_store_similar:
+ forall chunk',
+ size_chunk chunk' = size_chunk chunk ->
+ exists v', load chunk' m2 b ofs = Some v' /\ decode_encode_val v chunk chunk' v'.
+Proof.
+ intros.
+ exploit (valid_access_load m2 chunk').
+ eapply valid_access_compat. symmetry; eauto. eauto with mem.
+ intros [v' LOAD].
+ exists v'; split; auto.
+ exploit load_result; eauto. intros B.
+ rewrite B. rewrite store_result; simpl.
+ rewrite update_s.
+ replace (size_chunk_nat chunk') with (length (encode_val chunk v)).
+ rewrite getN_setN_same. apply decode_encode_val_general.
+ rewrite encode_val_length. repeat rewrite size_chunk_conv in H.
+ apply inj_eq_rev; auto.
+Qed.
+
+Theorem load_store_same:
+ Val.has_type v (type_of_chunk chunk) ->
+ load chunk m2 b ofs = Some (Val.load_result chunk v).
+Proof.
+ intros.
+ destruct (load_store_similar chunk) as [v' [A B]]. auto.
+ rewrite A. decEq. eapply decode_encode_val_similar; eauto.
+Qed.
+
+Theorem load_store_other:
+ forall chunk' b' ofs',
+ b' <> b
+ \/ ofs' + size_chunk chunk' <= ofs
+ \/ ofs + size_chunk chunk <= ofs' ->
+ load chunk' m2 b' ofs' = load chunk' m1 b' ofs'.
+Proof.
+ intros. unfold load.
+ destruct (valid_access_dec m1 chunk' b' ofs' Readable).
+ rewrite pred_dec_true.
+ decEq. decEq. rewrite store_result; unfold unchecked_store; simpl.
+ unfold update. destruct (zeq b' b). subst b'.
+ apply getN_setN_outside. rewrite encode_val_length. repeat rewrite <- size_chunk_conv.
+ intuition.
+ auto.
+ eauto with mem.
+ rewrite pred_dec_false. auto.
+ eauto with mem.
+Qed.
+
+Theorem loadbytes_store_same:
+ loadbytes m2 b ofs (size_chunk chunk) =
+ match v with
+ | Vundef => None
+ | Vint n => Some(encode_int chunk n)
+ | Vfloat n => Some(encode_float chunk n)
+ | Vptr _ _ => None
+ end.
+Proof.
+ intros.
+ assert (valid_access m2 chunk b ofs Readable) by eauto with mem.
+ unfold loadbytes. rewrite pred_dec_true. rewrite store_result; simpl.
+ rewrite update_s.
+ replace (nat_of_Z (size_chunk chunk))
+ with (length (encode_val chunk v)).
+ rewrite getN_setN_same.
+ destruct (size_chunk_nat_pos chunk) as [sz1 EQ].
+ unfold encode_val; destruct v.
+ rewrite EQ; auto.
+ apply proj_inj_bytes.
+ apply proj_inj_bytes.
+ rewrite EQ; destruct chunk; auto.
+ apply encode_val_length.
+ apply H.
+Qed.
+
+Theorem loadbytes_store_other:
+ forall b' ofs' n,
+ b' <> b
+ \/ n <= 0
+ \/ ofs' + n <= ofs
+ \/ ofs + size_chunk chunk <= ofs' ->
+ loadbytes m2 b' ofs' n = loadbytes m1 b' ofs' n.
+Proof.
+ intros. unfold loadbytes.
+ destruct (range_perm_dec m1 b' ofs' (ofs' + n) Readable).
+ rewrite pred_dec_true.
+ decEq. rewrite store_result; unfold unchecked_store; simpl.
+ unfold update. destruct (zeq b' b). subst b'.
+ destruct H. congruence.
+ destruct (zle n 0).
+ rewrite (nat_of_Z_neg _ z). auto.
+ destruct H. omegaContradiction.
+ apply getN_setN_outside. rewrite encode_val_length. rewrite <- size_chunk_conv.
+ rewrite nat_of_Z_eq. auto. omega.
+ auto.
+ red; intros. eauto with mem.
+ rewrite pred_dec_false. auto.
+ red; intro; elim n0; red; intros; eauto with mem.
+Qed.
+
+Lemma setN_property:
+ forall (P: memval -> Prop) vl p q c,
+ (forall v, In v vl -> P v) ->
+ p <= q < p + Z_of_nat (length vl) ->
+ P(setN vl p c q).
+Proof.
+ induction vl; intros.
+ simpl in H0. omegaContradiction.
+ simpl length in H0. rewrite inj_S in H0. simpl.
+ destruct (zeq p q). subst q. rewrite setN_outside. rewrite update_s.
+ auto with coqlib. omega.
+ apply IHvl. auto with coqlib. omega.
+Qed.
+
+Lemma getN_in:
+ forall c q n p,
+ p <= q < p + Z_of_nat n ->
+ In (c q) (getN n p c).
+Proof.
+ induction n; intros.
+ simpl in H; omegaContradiction.
+ rewrite inj_S in H. simpl. destruct (zeq p q).
+ subst q. auto.
+ right. apply IHn. omega.
+Qed.
+
+Theorem load_pointer_store:
+ forall chunk' b' ofs' v_b v_o,
+ load chunk' m2 b' ofs' = Some(Vptr v_b v_o) ->
+ (chunk = Mint32 /\ v = Vptr v_b v_o /\ chunk' = Mint32 /\ b' = b /\ ofs' = ofs)
+ \/ (b' <> b \/ ofs' + size_chunk chunk' <= ofs \/ ofs + size_chunk chunk <= ofs').
+Proof.
+ intros. exploit load_result; eauto. rewrite store_result; simpl.
+ unfold update. destruct (zeq b' b); auto. subst b'. intro DEC.
+ destruct (zle (ofs' + size_chunk chunk') ofs); auto.
+ destruct (zle (ofs + size_chunk chunk) ofs'); auto.
+ destruct (size_chunk_nat_pos chunk) as [sz SZ].
+ destruct (size_chunk_nat_pos chunk') as [sz' SZ'].
+ exploit decode_pointer_shape; eauto. intros [CHUNK' PSHAPE]. clear CHUNK'.
+ generalize (encode_val_shape chunk v). intro VSHAPE.
+ set (c := contents m1 b) in *.
+ set (c' := setN (encode_val chunk v) ofs c) in *.
+ destruct (zeq ofs ofs').
+
+(* 1. ofs = ofs': must be same chunks and same value *)
+ subst ofs'. inv VSHAPE.
+ exploit decode_val_pointer_inv; eauto. intros [A B].
+ subst chunk'. simpl in B. inv B.
+ generalize H4. unfold c'. rewrite <- H0. simpl.
+ rewrite setN_outside; try omega. rewrite update_s. intros.
+ exploit (encode_val_pointer_inv chunk v v_b v_o).
+ rewrite <- H0. subst mv1. eauto. intros [C [D E]].
+ left; auto.
+
+ destruct (zlt ofs ofs').
+
+(* 2. ofs < ofs':
+
+ ofs ofs' ofs+|chunk|
+ [-------------------] write
+ [-------------------] read
+
+ The byte at ofs' satisfies memval_valid_cont (consequence of write).
+ For the read to return a pointer, it must satisfy ~memval_valid_cont.
+*)
+ elimtype False.
+ assert (~memval_valid_cont (c' ofs')).
+ rewrite SZ' in PSHAPE. simpl in PSHAPE. inv PSHAPE. auto.
+ assert (memval_valid_cont (c' ofs')).
+ inv VSHAPE. unfold c'. rewrite <- H1. simpl.
+ apply setN_property. auto.
+ assert (length mvl = sz).
+ generalize (encode_val_length chunk v). rewrite <- H1. rewrite SZ.
+ simpl; congruence.
+ rewrite H4. rewrite size_chunk_conv in z0. omega.
+ contradiction.
+
+(* 3. ofs > ofs':
+
+ ofs' ofs ofs'+|chunk'|
+ [-------------------] write
+ [----------------] read
+
+ The byte at ofs satisfies memval_valid_first (consequence of write).
+ For the read to return a pointer, it must satisfy ~memval_valid_first.
+*)
+ elimtype False.
+ assert (memval_valid_first (c' ofs)).
+ inv VSHAPE. unfold c'. rewrite <- H0. simpl.
+ rewrite setN_outside. rewrite update_s. auto. omega.
+ assert (~memval_valid_first (c' ofs)).
+ rewrite SZ' in PSHAPE. simpl in PSHAPE. inv PSHAPE.
+ apply H4. apply getN_in. rewrite size_chunk_conv in z.
+ rewrite SZ' in z. rewrite inj_S in z. omega.
+ contradiction.
+Qed.
+
+End STORE.
+
+Hint Local Resolve perm_store_1 perm_store_2: mem.
+Hint Local Resolve store_valid_block_1 store_valid_block_2: mem.
+Hint Local Resolve store_valid_access_1 store_valid_access_2
+ store_valid_access_3: mem.
+
+Theorem load_store_pointer_overlap:
+ forall chunk m1 b ofs v_b v_o m2 chunk' ofs' v,
+ store chunk m1 b ofs (Vptr v_b v_o) = Some m2 ->
+ load chunk' m2 b ofs' = Some v ->
+ ofs' <> ofs ->
+ ofs' + size_chunk chunk' > ofs ->
+ ofs + size_chunk chunk > ofs' ->
+ v = Vundef.
+Proof.
+ intros.
+ exploit store_result; eauto. intro ST.
+ exploit load_result; eauto. intro LD.
+ rewrite LD; clear LD.
+Opaque encode_val.
+ rewrite ST; simpl.
+ rewrite update_s.
+ set (c := contents m1 b).
+ set (c' := setN (encode_val chunk (Vptr v_b v_o)) ofs c).
+ destruct (decode_val_shape chunk' (getN (size_chunk_nat chunk') ofs' c'))
+ as [OK | VSHAPE].
+ apply getN_length.
+ exact OK.
+ elimtype False.
+ destruct (size_chunk_nat_pos chunk) as [sz SZ].
+ destruct (size_chunk_nat_pos chunk') as [sz' SZ'].
+ assert (ENC: encode_val chunk (Vptr v_b v_o) = list_repeat (size_chunk_nat chunk) Undef
+ \/ pointer_encoding_shape (encode_val chunk (Vptr v_b v_o))).
+ destruct chunk; try (left; reflexivity).
+ right. apply encode_pointer_shape.
+ assert (GET: getN (size_chunk_nat chunk) ofs c' = encode_val chunk (Vptr v_b v_o)).
+ unfold c'. rewrite <- (encode_val_length chunk (Vptr v_b v_o)).
+ apply getN_setN_same.
+ destruct (zlt ofs ofs').
+
+(* ofs < ofs':
+
+ ofs ofs' ofs+|chunk|
+ [-------------------] write
+ [-------------------] read
+
+ The byte at ofs' is Undef or not memval_valid_first (because write of pointer).
+ The byte at ofs' must be memval_valid_first and not Undef (otherwise load returns Vundef).
+*)
+ assert (memval_valid_first (c' ofs') /\ c' ofs' <> Undef).
+ rewrite SZ' in VSHAPE. simpl in VSHAPE. inv VSHAPE. auto.
+ assert (~memval_valid_first (c' ofs') \/ c' ofs' = Undef).
+ unfold c'. destruct ENC.
+ right. apply setN_property. rewrite H5. intros. eapply in_list_repeat; eauto.
+ rewrite encode_val_length. rewrite <- size_chunk_conv. omega.
+ left. revert H5. rewrite <- GET. rewrite SZ. simpl. intros. inv H5.
+ apply setN_property. apply H9. rewrite getN_length.
+ rewrite size_chunk_conv in H3. rewrite SZ in H3. rewrite inj_S in H3. omega.
+ intuition.
+
+(* ofs > ofs':
+
+ ofs' ofs ofs'+|chunk'|
+ [-------------------] write
+ [----------------] read
+
+ The byte at ofs is Undef or not memval_valid_cont (because write of pointer).
+ The byte at ofs must be memval_valid_cont and not Undef (otherwise load returns Vundef).
+*)
+ assert (memval_valid_cont (c' ofs) /\ c' ofs <> Undef).
+ rewrite SZ' in VSHAPE. simpl in VSHAPE. inv VSHAPE.
+ apply H8. apply getN_in. rewrite size_chunk_conv in H2.
+ rewrite SZ' in H2. rewrite inj_S in H2. omega.
+ assert (~memval_valid_cont (c' ofs) \/ c' ofs = Undef).
+ elim ENC.
+ rewrite <- GET. rewrite SZ. simpl. intros. right; congruence.
+ rewrite <- GET. rewrite SZ. simpl. intros. inv H5. auto.
+ intuition.
+Qed.
+
+Theorem load_store_pointer_mismatch:
+ forall chunk m1 b ofs v_b v_o m2 chunk' v,
+ store chunk m1 b ofs (Vptr v_b v_o) = Some m2 ->
+ load chunk' m2 b ofs = Some v ->
+ chunk <> Mint32 \/ chunk' <> Mint32 ->
+ v = Vundef.
+Proof.
+ intros.
+ exploit store_result; eauto. intro ST.
+ exploit load_result; eauto. intro LD.
+ rewrite LD; clear LD.
+Opaque encode_val.
+ rewrite ST; simpl.
+ rewrite update_s.
+ set (c1 := contents m1 b).
+ set (e := encode_val chunk (Vptr v_b v_o)).
+ destruct (size_chunk_nat_pos chunk) as [sz SZ].
+ destruct (size_chunk_nat_pos chunk') as [sz' SZ'].
+ assert (match e with
+ | Undef :: _ => True
+ | Pointer _ _ _ :: _ => chunk = Mint32
+ | _ => False
+ end).
+Transparent encode_val.
+ unfold e, encode_val. rewrite SZ. destruct chunk; simpl; auto.
+ destruct e as [ | e1 el]. contradiction.
+ rewrite SZ'. simpl. rewrite setN_outside. rewrite update_s.
+ destruct e1; try contradiction.
+ destruct chunk'; auto.
+ destruct chunk'; auto. intuition.
+ omega.
+Qed.
+
+Lemma store_similar_chunks:
+ forall chunk1 chunk2 v1 v2 m b ofs,
+ encode_val chunk1 v1 = encode_val chunk2 v2 ->
+ store chunk1 m b ofs v1 = store chunk2 m b ofs v2.
+Proof.
+ intros. unfold store.
+ assert (size_chunk chunk1 = size_chunk chunk2).
+ repeat rewrite size_chunk_conv.
+ rewrite <- (encode_val_length chunk1 v1).
+ rewrite <- (encode_val_length chunk2 v2).
+ congruence.
+ unfold store.
+ destruct (valid_access_dec m chunk1 b ofs Writable).
+ rewrite pred_dec_true. unfold unchecked_store. congruence.
+ eapply valid_access_compat; eauto.
+ rewrite pred_dec_false; auto.
+ red; intro; elim n. apply valid_access_compat with chunk2; auto.
+Qed.
+
+Theorem store_signed_unsigned_8:
+ forall m b ofs v,
+ store Mint8signed m b ofs v = store Mint8unsigned m b ofs v.
+Proof. intros. apply store_similar_chunks. apply encode_val_int8_signed_unsigned. Qed.
+
+Theorem store_signed_unsigned_16:
+ forall m b ofs v,
+ store Mint16signed m b ofs v = store Mint16unsigned m b ofs v.
+Proof. intros. apply store_similar_chunks. apply encode_val_int16_signed_unsigned. Qed.
+
+Theorem store_int8_zero_ext:
+ forall m b ofs n,
+ store Mint8unsigned m b ofs (Vint (Int.zero_ext 8 n)) =
+ store Mint8unsigned m b ofs (Vint n).
+Proof. intros. apply store_similar_chunks. apply encode_val_int8_zero_ext. Qed.
+
+Theorem store_int8_sign_ext:
+ forall m b ofs n,
+ store Mint8signed m b ofs (Vint (Int.sign_ext 8 n)) =
+ store Mint8signed m b ofs (Vint n).
+Proof. intros. apply store_similar_chunks. apply encode_val_int8_sign_ext. Qed.
+
+Theorem store_int16_zero_ext:
+ forall m b ofs n,
+ store Mint16unsigned m b ofs (Vint (Int.zero_ext 16 n)) =
+ store Mint16unsigned m b ofs (Vint n).
+Proof. intros. apply store_similar_chunks. apply encode_val_int16_zero_ext. Qed.
+
+Theorem store_int16_sign_ext:
+ forall m b ofs n,
+ store Mint16signed m b ofs (Vint (Int.sign_ext 16 n)) =
+ store Mint16signed m b ofs (Vint n).
+Proof. intros. apply store_similar_chunks. apply encode_val_int16_sign_ext. Qed.
+
+Theorem store_float32_truncate:
+ forall m b ofs n,
+ store Mfloat32 m b ofs (Vfloat (Float.singleoffloat n)) =
+ store Mfloat32 m b ofs (Vfloat n).
+Proof. intros. apply store_similar_chunks. simpl. decEq. apply encode_float32_cast. Qed.
+
+(** ** Properties related to [alloc]. *)
+
+Section ALLOC.
+
+Variable m1: mem.
+Variables lo hi: Z.
+Variable m2: mem.
+Variable b: block.
+Hypothesis ALLOC: alloc m1 lo hi = (m2, b).
+
+Theorem nextblock_alloc:
+ nextblock m2 = Zsucc (nextblock m1).
+Proof.
+ injection ALLOC; intros. rewrite <- H0; auto.
+Qed.
+
+Theorem alloc_result:
+ b = nextblock m1.
+Proof.
+ injection ALLOC; auto.
+Qed.
+
+Theorem valid_block_alloc:
+ forall b', valid_block m1 b' -> valid_block m2 b'.
+Proof.
+ unfold valid_block; intros. rewrite nextblock_alloc. omega.
+Qed.
+
+Theorem fresh_block_alloc:
+ ~(valid_block m1 b).
+Proof.
+ unfold valid_block. rewrite alloc_result. omega.
+Qed.
+
+Theorem valid_new_block:
+ valid_block m2 b.
+Proof.
+ unfold valid_block. rewrite alloc_result. rewrite nextblock_alloc. omega.
+Qed.
+
+Hint Local Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem.
+
+Theorem valid_block_alloc_inv:
+ forall b', valid_block m2 b' -> b' = b \/ valid_block m1 b'.
+Proof.
+ unfold valid_block; intros.
+ rewrite nextblock_alloc in H. rewrite alloc_result.
+ unfold block; omega.
+Qed.
+
+Theorem perm_alloc_1:
+ forall b' ofs p, perm m1 b' ofs p -> perm m2 b' ofs p.
+Proof.
+ unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl.
+ subst b. unfold update. destruct (zeq b' (next m1)); auto.
+ assert (access m1 b' ofs = false). apply next_noaccess. omega. congruence.
+Qed.
+
+Theorem perm_alloc_2:
+ forall ofs, lo <= ofs < hi -> perm m2 b ofs Writable.
+Proof.
+ unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl.
+ subst b. rewrite update_s. unfold proj_sumbool. rewrite zle_true.
+ rewrite zlt_true. auto. omega. omega.
+Qed.
+
+Theorem perm_alloc_3:
+ forall ofs p, ofs < lo \/ hi <= ofs -> ~perm m2 b ofs p.
+Proof.
+ unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl.
+ subst b. rewrite update_s. unfold proj_sumbool.
+ destruct H. rewrite zle_false. simpl. congruence. omega.
+ rewrite zlt_false. rewrite andb_false_r. congruence. omega.
+Qed.
+
+Hint Local Resolve perm_alloc_1 perm_alloc_2 perm_alloc_3: mem.
+
+Theorem perm_alloc_inv:
+ forall b' ofs p,
+ perm m2 b' ofs p ->
+ if zeq b' b then lo <= ofs < hi else perm m1 b' ofs p.
+Proof.
+ intros until p; unfold perm. inv ALLOC. simpl.
+ unfold update. destruct (zeq b' (next m1)); intros.
+ destruct (andb_prop _ _ H).
+ split; eapply proj_sumbool_true; eauto.
+ auto.
+Qed.
+
+Theorem valid_access_alloc_other:
+ forall chunk b' ofs p,
+ valid_access m1 chunk b' ofs p ->
+ valid_access m2 chunk b' ofs p.
+Proof.
+ intros. inv H. constructor; auto with mem.
+ red; auto with mem.
+Qed.
+
+Theorem valid_access_alloc_same:
+ forall chunk ofs,
+ lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) ->
+ valid_access m2 chunk b ofs Writable.
+Proof.
+ intros. constructor; auto with mem.
+ red; intros. apply perm_alloc_2. omega.
+Qed.
+
+Hint Local Resolve valid_access_alloc_other valid_access_alloc_same: mem.
+
+Theorem valid_access_alloc_inv:
+ forall chunk b' ofs p,
+ valid_access m2 chunk b' ofs p ->
+ if eq_block b' b
+ then lo <= ofs /\ ofs + size_chunk chunk <= hi /\ (align_chunk chunk | ofs)
+ else valid_access m1 chunk b' ofs p.
+Proof.
+ intros. inv H.
+ generalize (size_chunk_pos chunk); intro.
+ unfold eq_block. destruct (zeq b' b). subst b'.
+ assert (perm m2 b ofs p). apply H0. omega.
+ assert (perm m2 b (ofs + size_chunk chunk - 1) p). apply H0. omega.
+ exploit perm_alloc_inv. eexact H2. rewrite zeq_true. intro.
+ exploit perm_alloc_inv. eexact H3. rewrite zeq_true. intro.
+ intuition omega.
+ split; auto. red; intros.
+ exploit perm_alloc_inv. apply H0. eauto. rewrite zeq_false; auto.
+Qed.
+
+Theorem bounds_alloc:
+ forall b', bounds m2 b' = if eq_block b' b then (lo, hi) else bounds m1 b'.
+Proof.
+ injection ALLOC; intros. rewrite <- H; rewrite <- H0; simpl.
+ unfold update. auto.
+Qed.
+
+Theorem bounds_alloc_same:
+ bounds m2 b = (lo, hi).
+Proof.
+ rewrite bounds_alloc. apply dec_eq_true.
+Qed.
+
+Theorem bounds_alloc_other:
+ forall b', b' <> b -> bounds m2 b' = bounds m1 b'.
+Proof.
+ intros. rewrite bounds_alloc. apply dec_eq_false. auto.
+Qed.
+
+Theorem load_alloc_unchanged:
+ forall chunk b' ofs,
+ valid_block m1 b' ->
+ load chunk m2 b' ofs = load chunk m1 b' ofs.
+Proof.
+ intros. unfold load.
+ destruct (valid_access_dec m2 chunk b' ofs Readable).
+ exploit valid_access_alloc_inv; eauto. destruct (eq_block b' b); intros.
+ subst b'. elimtype False. eauto with mem.
+ rewrite pred_dec_true; auto.
+ injection ALLOC; intros. rewrite <- H2; simpl.
+ rewrite update_o. auto. rewrite H1. apply sym_not_equal; eauto with mem.
+ rewrite pred_dec_false. auto.
+ eauto with mem.
+Qed.
+
+Theorem load_alloc_other:
+ forall chunk b' ofs v,
+ load chunk m1 b' ofs = Some v ->
+ load chunk m2 b' ofs = Some v.
+Proof.
+ intros. rewrite <- H. apply load_alloc_unchanged. eauto with mem.
+Qed.
+
+Theorem load_alloc_same:
+ forall chunk ofs v,
+ load chunk m2 b ofs = Some v ->
+ v = Vundef.
+Proof.
+ intros. exploit load_result; eauto. intro. rewrite H0.
+ injection ALLOC; intros. rewrite <- H2; simpl. rewrite <- H1.
+ rewrite update_s. destruct chunk; reflexivity.
+Qed.
+
+Theorem load_alloc_same':
+ forall chunk ofs,
+ lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) ->
+ load chunk m2 b ofs = Some Vundef.
+Proof.
+ intros. assert (exists v, load chunk m2 b ofs = Some v).
+ apply valid_access_load. constructor; auto.
+ red; intros. eapply perm_implies. apply perm_alloc_2. omega. auto with mem.
+ destruct H2 as [v LOAD]. rewrite LOAD. decEq.
+ eapply load_alloc_same; eauto.
+Qed.
+
+End ALLOC.
+
+Hint Local Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem.
+Hint Local Resolve valid_access_alloc_other valid_access_alloc_same: mem.
+
+(** ** Properties related to [free]. *)
+
+Theorem range_perm_free:
+ forall m1 b lo hi,
+ range_perm m1 b lo hi Freeable ->
+ { m2: mem | free m1 b lo hi = Some m2 }.
+Proof.
+ intros; unfold free. rewrite pred_dec_true; auto. econstructor; eauto.
+Qed.
+
+Section FREE.
+
+Variable m1: mem.
+Variable bf: block.
+Variables lo hi: Z.
+Variable m2: mem.
+Hypothesis FREE: free m1 bf lo hi = Some m2.
+
+Theorem free_range_perm:
+ range_perm m1 bf lo hi Writable.
+Proof.
+ unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Freeable).
+ auto. congruence.
+Qed.
+
+Lemma free_result:
+ m2 = unchecked_free m1 bf lo hi.
+Proof.
+ unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Freeable).
+ congruence. congruence.
+Qed.
+
+Theorem nextblock_free:
+ nextblock m2 = nextblock m1.
+Proof.
+ rewrite free_result; reflexivity.
+Qed.
+
+Theorem valid_block_free_1:
+ forall b, valid_block m1 b -> valid_block m2 b.
+Proof.
+ intros. rewrite free_result. assumption.
+Qed.
+
+Theorem valid_block_free_2:
+ forall b, valid_block m2 b -> valid_block m1 b.
+Proof.
+ intros. rewrite free_result in H. assumption.
+Qed.
+
+Hint Local Resolve valid_block_free_1 valid_block_free_2: mem.
+
+Theorem perm_free_1:
+ forall b ofs p,
+ b <> bf \/ ofs < lo \/ hi <= ofs ->
+ perm m1 b ofs p ->
+ perm m2 b ofs p.
+Proof.
+ intros. rewrite free_result. unfold perm, unchecked_free; simpl.
+ unfold update. destruct (zeq b bf). subst b.
+ destruct (zle lo ofs); simpl.
+ destruct (zlt ofs hi); simpl.
+ elimtype False; intuition.
+ auto. auto.
+ auto.
+Qed.
+
+Theorem perm_free_2:
+ forall ofs p, lo <= ofs < hi -> ~ perm m2 bf ofs p.
+Proof.
+ intros. rewrite free_result. unfold perm, unchecked_free; simpl.
+ rewrite update_s. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true.
+ simpl. congruence. omega. omega.
+Qed.
+
+Theorem perm_free_3:
+ forall b ofs p,
+ perm m2 b ofs p -> perm m1 b ofs p.
+Proof.
+ intros until p. rewrite free_result. unfold perm, unchecked_free; simpl.
+ unfold update. destruct (zeq b bf). subst b.
+ destruct (zle lo ofs); simpl.
+ destruct (zlt ofs hi); simpl.
+ congruence. auto. auto.
+ auto.
+Qed.
+
+Theorem valid_access_free_1:
+ forall chunk b ofs p,
+ valid_access m1 chunk b ofs p ->
+ b <> bf \/ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs ->
+ valid_access m2 chunk b ofs p.
+Proof.
+ intros. inv H. constructor; auto with mem.
+ red; intros. eapply perm_free_1; eauto.
+ destruct (zlt lo hi). intuition. right. omega.
+Qed.
+
+Theorem valid_access_free_2:
+ forall chunk ofs p,
+ lo < hi -> ofs + size_chunk chunk > lo -> ofs < hi ->
+ ~(valid_access m2 chunk bf ofs p).
+Proof.
+ intros; red; intros. inv H2.
+ generalize (size_chunk_pos chunk); intros.
+ destruct (zlt ofs lo).
+ elim (perm_free_2 lo p).
+ omega. apply H3. omega.
+ elim (perm_free_2 ofs p).
+ omega. apply H3. omega.
+Qed.
+
+Theorem valid_access_free_inv_1:
+ forall chunk b ofs p,
+ valid_access m2 chunk b ofs p ->
+ valid_access m1 chunk b ofs p.
+Proof.
+ intros. destruct H. split; auto.
+ red; intros. generalize (H ofs0 H1).
+ rewrite free_result. unfold perm, unchecked_free; simpl.
+ unfold update. destruct (zeq b bf). subst b.
+ destruct (zle lo ofs0); simpl.
+ destruct (zlt ofs0 hi); simpl.
+ congruence. auto. auto. auto.
+Qed.
+
+Theorem valid_access_free_inv_2:
+ forall chunk ofs p,
+ valid_access m2 chunk bf ofs p ->
+ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs.
+Proof.
+ intros.
+ destruct (zlt lo hi); auto.
+ destruct (zle (ofs + size_chunk chunk) lo); auto.
+ destruct (zle hi ofs); auto.
+ elim (valid_access_free_2 chunk ofs p); auto. omega.
+Qed.
+
+Theorem bounds_free:
+ forall b, bounds m2 b = bounds m1 b.
+Proof.
+ intros. rewrite free_result; simpl. auto.
+Qed.
+
+Theorem load_free:
+ forall chunk b ofs,
+ b <> bf \/ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs ->
+ load chunk m2 b ofs = load chunk m1 b ofs.
+Proof.
+ intros. unfold load.
+ destruct (valid_access_dec m2 chunk b ofs Readable).
+ rewrite pred_dec_true.
+ rewrite free_result; auto.
+ apply valid_access_free_inv_1; auto.
+ rewrite pred_dec_false; auto.
+ red; intro; elim n. eapply valid_access_free_1; eauto.
+Qed.
+
+End FREE.
+
+Hint Local Resolve valid_block_free_1 valid_block_free_2
+ perm_free_1 perm_free_2 perm_free_3
+ valid_access_free_1 valid_access_free_inv_1: mem.
+
+(** * Generic injections *)
+
+(** A memory state [m1] generically injects into another memory state [m2] via the
+ memory injection [f] if the following conditions hold:
+- each access in [m2] that corresponds to a valid access in [m1]
+ is itself valid;
+- the memory value associated in [m1] to an accessible address
+ must inject into [m2]'s memory value at the corersponding address.
+*)
+
+Record mem_inj (f: meminj) (m1 m2: mem) : Prop :=
+ mk_mem_inj {
+ mi_access:
+ forall b1 b2 delta chunk ofs p,
+ f b1 = Some(b2, delta) ->
+ valid_access m1 chunk b1 ofs p ->
+ valid_access m2 chunk b2 (ofs + delta) p;
+ mi_memval:
+ forall b1 ofs b2 delta,
+ f b1 = Some(b2, delta) ->
+ perm m1 b1 ofs Nonempty ->
+ memval_inject f (m1.(contents) b1 ofs) (m2.(contents) b2 (ofs + delta))
+ }.
+
+(** Preservation of permissions *)
+
+Lemma perm_inj:
+ forall f m1 m2 b1 ofs p b2 delta,
+ mem_inj f m1 m2 ->
+ perm m1 b1 ofs p ->
+ f b1 = Some(b2, delta) ->
+ perm m2 b2 (ofs + delta) p.
+Proof.
+ intros.
+ assert (valid_access m1 Mint8unsigned b1 ofs p).
+ split. red; intros. simpl in H2. replace ofs0 with ofs by omega. auto.
+ simpl. apply Zone_divide.
+ exploit mi_access; eauto. intros [A B].
+ apply A. simpl; omega.
+Qed.
+
+(** Preservation of loads. *)
+
+Lemma getN_inj:
+ forall f m1 m2 b1 b2 delta,
+ mem_inj f m1 m2 ->
+ f b1 = Some(b2, delta) ->
+ forall n ofs,
+ range_perm m1 b1 ofs (ofs + Z_of_nat n) Readable ->
+ list_forall2 (memval_inject f)
+ (getN n ofs (m1.(contents) b1))
+ (getN n (ofs + delta) (m2.(contents) b2)).
+Proof.
+ induction n; intros; simpl.
+ constructor.
+ rewrite inj_S in H1.
+ constructor.
+ eapply mi_memval; eauto. apply H1. omega.
+ replace (ofs + delta + 1) with ((ofs + 1) + delta) by omega.
+ apply IHn. red; intros; apply H1; omega.
+Qed.
+
+Lemma load_inj:
+ forall f m1 m2 chunk b1 ofs b2 delta v1,
+ mem_inj f m1 m2 ->
+ load chunk m1 b1 ofs = Some v1 ->
+ f b1 = Some (b2, delta) ->
+ exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2.
+Proof.
+ intros.
+ exists (decode_val chunk (getN (size_chunk_nat chunk) (ofs + delta) (m2.(contents) b2))).
+ split. unfold load. apply pred_dec_true.
+ eapply mi_access; eauto with mem.
+ exploit load_result; eauto. intro. rewrite H2.
+ apply decode_val_inject. apply getN_inj; auto.
+ rewrite <- size_chunk_conv. exploit load_valid_access; eauto. intros [A B]. auto.
+Qed.
+
+(** Preservation of stores. *)
+
+Lemma setN_inj:
+ forall (access: Z -> Prop) delta f vl1 vl2,
+ list_forall2 (memval_inject f) vl1 vl2 ->
+ forall p c1 c2,
+ (forall q, access q -> memval_inject f (c1 q) (c2 (q + delta))) ->
+ (forall q, access q -> memval_inject f ((setN vl1 p c1) q)
+ ((setN vl2 (p + delta) c2) (q + delta))).
+Proof.
+ induction 1; intros; simpl.
+ auto.
+ replace (p + delta + 1) with ((p + 1) + delta) by omega.
+ apply IHlist_forall2; auto.
+ intros. unfold update at 1. destruct (zeq q0 p). subst q0.
+ rewrite update_s. auto.
+ rewrite update_o. auto. omega.
+Qed.
+
+Definition meminj_no_overlap (f: meminj) (m: mem) : Prop :=
+ forall b1 b1' delta1 b2 b2' delta2,
+ b1 <> b2 ->
+ f b1 = Some (b1', delta1) ->
+ f b2 = Some (b2', delta2) ->
+ b1' <> b2'
+(*
+ \/ low_bound m b1 >= high_bound m b1
+ \/ low_bound m b2 >= high_bound m b2 *)
+ \/ high_bound m b1 + delta1 <= low_bound m b2 + delta2
+ \/ high_bound m b2 + delta2 <= low_bound m b1 + delta1.
+
+Lemma meminj_no_overlap_perm:
+ forall f m b1 b1' delta1 b2 b2' delta2 ofs1 ofs2,
+ meminj_no_overlap f m ->
+ b1 <> b2 ->
+ f b1 = Some (b1', delta1) ->
+ f b2 = Some (b2', delta2) ->
+ perm m b1 ofs1 Nonempty ->
+ perm m b2 ofs2 Nonempty ->
+ b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2.
+Proof.
+ intros. exploit H; eauto. intro.
+ exploit perm_in_bounds. eexact H3. intro.
+ exploit perm_in_bounds. eexact H4. intro.
+ destruct H5. auto. right. omega.
+Qed.
+
+Lemma store_mapped_inj:
+ forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2,
+ mem_inj f m1 m2 ->
+ store chunk m1 b1 ofs v1 = Some n1 ->
+ meminj_no_overlap f m1 ->
+ f b1 = Some (b2, delta) ->
+ val_inject f v1 v2 ->
+ exists n2,
+ store chunk m2 b2 (ofs + delta) v2 = Some n2
+ /\ mem_inj f n1 n2.
+Proof.
+ intros. inversion H.
+ assert (valid_access m2 chunk b2 (ofs + delta) Writable).
+ eapply mi_access0; eauto with mem.
+ destruct (valid_access_store _ _ _ _ v2 H4) as [n2 STORE].
+ exists n2; split. eauto.
+ constructor.
+(* access *)
+ eauto with mem.
+(* contents *)
+ intros.
+ assert (perm m1 b0 ofs0 Readable). eapply perm_store_2; eauto.
+ rewrite (store_result _ _ _ _ _ _ H0).
+ rewrite (store_result _ _ _ _ _ _ STORE).
+ unfold unchecked_store; simpl. unfold update.
+ destruct (zeq b0 b1). subst b0.
+ (* block = b1, block = b2 *)
+ assert (b3 = b2) by congruence. subst b3.
+ assert (delta0 = delta) by congruence. subst delta0.
+ rewrite zeq_true.
+ apply setN_inj with (access := fun ofs => perm m1 b1 ofs Nonempty).
+ apply encode_val_inject; auto. auto. auto.
+ destruct (zeq b3 b2). subst b3.
+ (* block <> b1, block = b2 *)
+ rewrite setN_other. auto.
+ rewrite encode_val_length. rewrite <- size_chunk_conv. intros.
+ assert (b2 <> b2 \/ ofs0 + delta0 <> (r - delta) + delta).
+ eapply meminj_no_overlap_perm; eauto.
+ exploit store_valid_access_3. eexact H0. intros [A B].
+ eapply perm_implies. apply A. omega. auto with mem.
+ destruct H9. congruence. omega.
+ (* block <> b1, block <> b2 *)
+ eauto.
+Qed.
+
+Lemma store_unmapped_inj:
+ forall f chunk m1 b1 ofs v1 n1 m2,
+ mem_inj f m1 m2 ->
+ store chunk m1 b1 ofs v1 = Some n1 ->
+ f b1 = None ->
+ mem_inj f n1 m2.
+Proof.
+ intros. inversion H.
+ constructor.
+(* access *)
+ eauto with mem.
+(* contents *)
+ intros.
+ rewrite (store_result _ _ _ _ _ _ H0).
+ unfold unchecked_store; simpl. rewrite update_o. eauto with mem.
+ congruence.
+Qed.
+
+Lemma store_outside_inj:
+ forall f m1 m2 chunk b ofs v m2',
+ mem_inj f m1 m2 ->
+ (forall b' delta ofs',
+ f b' = Some(b, delta) ->
+ perm m1 b' ofs' Nonempty ->
+ ofs' + delta < ofs \/ ofs' + delta >= ofs + size_chunk chunk) ->
+ store chunk m2 b ofs v = Some m2' ->
+ mem_inj f m1 m2'.
+Proof.
+ intros. inversion H. constructor.
+(* access *)
+ eauto with mem.
+(* contents *)
+ intros.
+ rewrite (store_result _ _ _ _ _ _ H1).
+ unfold unchecked_store; simpl. unfold update. destruct (zeq b2 b). subst b2.
+ rewrite setN_outside. auto.
+ rewrite encode_val_length. rewrite <- size_chunk_conv.
+ eapply H0; eauto.
+ eauto with mem.
+Qed.
+
+(** Preservation of allocations *)
+
+Lemma alloc_right_inj:
+ forall f m1 m2 lo hi b2 m2',
+ mem_inj f m1 m2 ->
+ alloc m2 lo hi = (m2', b2) ->
+ mem_inj f m1 m2'.
+Proof.
+ intros. injection H0. intros NEXT MEM.
+ inversion H. constructor.
+(* access *)
+ intros. eauto with mem.
+(* contents *)
+ intros.
+ assert (valid_access m2 Mint8unsigned b0 (ofs + delta) Nonempty).
+ eapply mi_access0; eauto.
+ split. simpl. red; intros. assert (ofs0 = ofs) by omega. congruence.
+ simpl. apply Zone_divide.
+ assert (valid_block m2 b0) by eauto with mem.
+ rewrite <- MEM; simpl. rewrite update_o. eauto with mem.
+ rewrite NEXT. apply sym_not_equal. eauto with mem.
+Qed.
+
+Lemma alloc_left_unmapped_inj:
+ forall f m1 m2 lo hi m1' b1,
+ mem_inj f m1 m2 ->
+ alloc m1 lo hi = (m1', b1) ->
+ f b1 = None ->
+ mem_inj f m1' m2.
+Proof.
+ intros. inversion H. constructor.
+(* access *)
+ unfold update; intros.
+ exploit valid_access_alloc_inv; eauto. unfold eq_block. intros.
+ destruct (zeq b0 b1). congruence. eauto.
+(* contents *)
+ injection H0; intros NEXT MEM. intros.
+ rewrite <- MEM; simpl. rewrite NEXT. unfold update.
+ exploit perm_alloc_inv; eauto. intros.
+ destruct (zeq b0 b1). constructor. eauto.
+Qed.
+
+Definition inj_offset_aligned (delta: Z) (size: Z) : Prop :=
+ forall chunk, size_chunk chunk <= size -> (align_chunk chunk | delta).
+
+Lemma alloc_left_mapped_inj:
+ forall f m1 m2 lo hi m1' b1 b2 delta,
+ mem_inj f m1 m2 ->
+ alloc m1 lo hi = (m1', b1) ->
+ valid_block m2 b2 ->
+ inj_offset_aligned delta (hi-lo) ->
+ (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) ->
+ f b1 = Some(b2, delta) ->
+ mem_inj f m1' m2.
+Proof.
+ intros. inversion H. constructor.
+(* access *)
+ intros.
+ exploit valid_access_alloc_inv; eauto. unfold eq_block. intros.
+ destruct (zeq b0 b1). subst b0. rewrite H4 in H5. inversion H5; clear H5; subst b3 delta0.
+ split. red; intros.
+ replace ofs0 with ((ofs0 - delta) + delta) by omega.
+ apply H3. omega.
+ destruct H6. apply Zdivide_plus_r. auto. apply H2. omega.
+ eauto.
+(* contents *)
+ injection H0; intros NEXT MEM.
+ intros. rewrite <- MEM; simpl. rewrite NEXT. unfold update.
+ exploit perm_alloc_inv; eauto. intros.
+ destruct (zeq b0 b1). constructor. eauto.
+Qed.
+
+Lemma free_left_inj:
+ forall f m1 m2 b lo hi m1',
+ mem_inj f m1 m2 ->
+ free m1 b lo hi = Some m1' ->
+ mem_inj f m1' m2.
+Proof.
+ intros. exploit free_result; eauto. intro FREE. inversion H. constructor.
+(* access *)
+ intros. eauto with mem.
+(* contents *)
+ intros. rewrite FREE; simpl. eauto with mem.
+Qed.
+
+Lemma free_right_inj:
+ forall f m1 m2 b lo hi m2',
+ mem_inj f m1 m2 ->
+ free m2 b lo hi = Some m2' ->
+ (forall b1 delta ofs p,
+ f b1 = Some(b, delta) -> perm m1 b1 ofs p ->
+ lo <= ofs + delta < hi -> False) ->
+ mem_inj f m1 m2'.
+Proof.
+ intros. exploit free_result; eauto. intro FREE. inversion H. constructor.
+(* access *)
+ intros. exploit mi_access0; eauto. intros [RG AL]. split; auto.
+ red; intros. eapply perm_free_1; eauto.
+ destruct (zeq b2 b); auto. subst b. right.
+ destruct (zlt ofs0 lo); auto. destruct (zle hi ofs0); auto.
+ elimtype False. eapply H1 with (ofs := ofs0 - delta). eauto.
+ apply H3. omega. omega.
+(* contents *)
+ intros. rewrite FREE; simpl. eauto.
+Qed.
+
+(** * Memory extensions *)
+
+(** A store [m2] extends a store [m1] if [m2] can be obtained from [m1]
+ by increasing the sizes of the memory blocks of [m1] (decreasing
+ the low bounds, increasing the high bounds), and replacing some of
+ the [Vundef] values stored in [m1] by more defined values stored
+ in [m2] at the same locations. *)
+
+Record extends_ (m1 m2: mem) : Prop :=
+ mk_extends {
+ mext_next: nextblock m1 = nextblock m2;
+ mext_inj: mem_inj inject_id m1 m2
+(*
+ mext_bounds: forall b, low_bound m2 b <= low_bound m1 b /\ high_bound m1 b <= high_bound m2 b
+*)
+ }.
+
+Definition extends := extends_.
+
+Theorem extends_refl:
+ forall m, extends m m.
+Proof.
+ intros. constructor. auto. constructor.
+ intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by omega. auto.
+ intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by omega.
+ apply memval_inject_id.
+(* intros. omega. *)
+Qed.
+
+Theorem load_extends:
+ forall chunk m1 m2 b ofs v1,
+ extends m1 m2 ->
+ load chunk m1 b ofs = Some v1 ->
+ exists v2, load chunk m2 b ofs = Some v2 /\ Val.lessdef v1 v2.
+Proof.
+ intros. inv H. exploit load_inj; eauto. unfold inject_id; reflexivity.
+ intros [v2 [A B]]. exists v2; split.
+ replace (ofs + 0) with ofs in A by omega. auto.
+ rewrite val_inject_id in B. auto.
+Qed.
+
+Theorem loadv_extends:
+ forall chunk m1 m2 addr1 addr2 v1,
+ extends m1 m2 ->
+ loadv chunk m1 addr1 = Some v1 ->
+ Val.lessdef addr1 addr2 ->
+ exists v2, loadv chunk m2 addr2 = Some v2 /\ Val.lessdef v1 v2.
+Proof.
+ unfold loadv; intros. inv H1.
+ destruct addr2; try congruence. eapply load_extends; eauto.
+ congruence.
+Qed.
+
+Theorem store_within_extends:
+ forall chunk m1 m2 b ofs v1 m1' v2,
+ extends m1 m2 ->
+ store chunk m1 b ofs v1 = Some m1' ->
+ Val.lessdef v1 v2 ->
+ exists m2',
+ store chunk m2 b ofs v2 = Some m2'
+ /\ extends m1' m2'.
+Proof.
+ intros. inversion H.
+ exploit store_mapped_inj; eauto.
+ unfold inject_id; red; intros. inv H3; inv H4. auto.
+ unfold inject_id; reflexivity.
+ rewrite val_inject_id. eauto.
+ intros [m2' [A B]].
+ exists m2'; split.
+ replace (ofs + 0) with ofs in A by omega. auto.
+ split; auto.
+ rewrite (nextblock_store _ _ _ _ _ _ H0).
+ rewrite (nextblock_store _ _ _ _ _ _ A).
+ auto.
+(*
+ intros.
+ rewrite (bounds_store _ _ _ _ _ _ H0).
+ rewrite (bounds_store _ _ _ _ _ _ A).
+ auto.
+*)
+Qed.
+
+Theorem store_outside_extends:
+ forall chunk m1 m2 b ofs v m2',
+ extends m1 m2 ->
+ store chunk m2 b ofs v = Some m2' ->
+ ofs + size_chunk chunk <= low_bound m1 b \/ high_bound m1 b <= ofs ->
+ extends m1 m2'.
+Proof.
+ intros. inversion H. constructor.
+ rewrite (nextblock_store _ _ _ _ _ _ H0). auto.
+ eapply store_outside_inj; eauto.
+ unfold inject_id; intros. inv H2.
+ exploit perm_in_bounds; eauto. omega.
+(*
+ intros.
+ rewrite (bounds_store _ _ _ _ _ _ H0). auto.
+*)
+Qed.
+
+Theorem storev_extends:
+ forall chunk m1 m2 addr1 v1 m1' addr2 v2,
+ extends m1 m2 ->
+ storev chunk m1 addr1 v1 = Some m1' ->
+ Val.lessdef addr1 addr2 ->
+ Val.lessdef v1 v2 ->
+ exists m2',
+ storev chunk m2 addr2 v2 = Some m2'
+ /\ extends m1' m2'.
+Proof.
+ unfold storev; intros. inv H1.
+ destruct addr2; try congruence. eapply store_within_extends; eauto.
+ congruence.
+Qed.
+
+Theorem alloc_extends:
+ forall m1 m2 lo1 hi1 b m1' lo2 hi2,
+ extends m1 m2 ->
+ alloc m1 lo1 hi1 = (m1', b) ->
+ lo2 <= lo1 -> hi1 <= hi2 ->
+ exists m2',
+ alloc m2 lo2 hi2 = (m2', b)
+ /\ extends m1' m2'.
+Proof.
+ intros. inv H.
+ case_eq (alloc m2 lo2 hi2); intros m2' b' ALLOC.
+ assert (b' = b).
+ rewrite (alloc_result _ _ _ _ _ H0).
+ rewrite (alloc_result _ _ _ _ _ ALLOC).
+ auto.
+ subst b'.
+ exists m2'; split; auto.
+ constructor.
+ rewrite (nextblock_alloc _ _ _ _ _ H0).
+ rewrite (nextblock_alloc _ _ _ _ _ ALLOC).
+ congruence.
+ eapply alloc_left_mapped_inj with (m1 := m1) (m2 := m2') (b2 := b) (delta := 0); eauto.
+ eapply alloc_right_inj; eauto.
+ eauto with mem.
+ red. intros. apply Zdivide_0.
+ intros. eapply perm_alloc_2; eauto. omega.
+(*
+ intros. destruct (zeq b0 b). subst b0.
+ rewrite (bounds_alloc_same _ _ _ _ _ H0).
+ rewrite (bounds_alloc_same _ _ _ _ _ ALLOC).
+ simpl. auto.
+ rewrite (bounds_alloc_other _ _ _ _ _ H0); auto.
+ rewrite (bounds_alloc_other _ _ _ _ _ ALLOC); auto.
+*)
+Qed.
+
+Theorem free_left_extends:
+ forall m1 m2 b lo hi m1',
+ extends m1 m2 ->
+ free m1 b lo hi = Some m1' ->
+ extends m1' m2.
+Proof.
+ intros. inv H. constructor.
+ rewrite (nextblock_free _ _ _ _ _ H0). auto.
+ eapply free_left_inj; eauto.
+(*
+ intros. rewrite (bounds_free _ _ _ _ _ H0). auto.
+*)
+Qed.
+
+Theorem free_right_extends:
+ forall m1 m2 b lo hi m2',
+ extends m1 m2 ->
+ free m2 b lo hi = Some m2' ->
+ (forall ofs p, lo <= ofs < hi -> ~perm m1 b ofs p) ->
+ extends m1 m2'.
+Proof.
+ intros. inv H. constructor.
+ rewrite (nextblock_free _ _ _ _ _ H0). auto.
+ eapply free_right_inj; eauto.
+ unfold inject_id; intros. inv H.
+ elim (H1 ofs p); auto. omega.
+(*
+ intros. rewrite (bounds_free _ _ _ _ _ H0). auto.
+*)
+Qed.
+
+Theorem free_parallel_extends:
+ forall m1 m2 b lo hi m1',
+ extends m1 m2 ->
+ free m1 b lo hi = Some m1' ->
+ exists m2',
+ free m2 b lo hi = Some m2'
+ /\ extends m1' m2'.
+Proof.
+ intros. inversion H.
+ assert ({ m2': mem | free m2 b lo hi = Some m2' }).
+ apply range_perm_free. red; intros.
+ replace ofs with (ofs + 0) by omega.
+ eapply perm_inj with (b1 := b); eauto.
+ eapply free_range_perm; eauto.
+ destruct X as [m2' FREE]. exists m2'; split; auto.
+ inv H. constructor.
+ rewrite (nextblock_free _ _ _ _ _ H0).
+ rewrite (nextblock_free _ _ _ _ _ FREE). auto.
+ eapply free_right_inj with (m1 := m1'); eauto.
+ eapply free_left_inj; eauto.
+ unfold inject_id; intros. inv H.
+ assert (~perm m1' b ofs p). eapply perm_free_2; eauto. omega.
+ contradiction.
+(*
+ intros.
+ rewrite (bounds_free _ _ _ _ _ H0).
+ rewrite (bounds_free _ _ _ _ _ FREE).
+ auto.
+*)
+Qed.
+
+Theorem valid_block_extends:
+ forall m1 m2 b,
+ extends m1 m2 ->
+ (valid_block m1 b <-> valid_block m2 b).
+Proof.
+ intros. inv H. unfold valid_block. rewrite mext_next0. omega.
+Qed.
+
+Theorem perm_extends:
+ forall m1 m2 b ofs p,
+ extends m1 m2 -> perm m1 b ofs p -> perm m2 b ofs p.
+Proof.
+ intros. inv H. replace ofs with (ofs + 0) by omega.
+ eapply perm_inj; eauto.
+Qed.
+
+Theorem valid_access_extends:
+ forall m1 m2 chunk b ofs p,
+ extends m1 m2 -> valid_access m1 chunk b ofs p -> valid_access m2 chunk b ofs p.
+Proof.
+ intros. inv H. replace ofs with (ofs + 0) by omega.
+ eapply mi_access; eauto. auto.
+Qed.
+
+(*
+Theorem bounds_extends:
+ forall m1 m2 b,
+ extends m1 m2 -> low_bound m2 b <= low_bound m1 b /\ high_bound m1 b <= high_bound m2 b.
+Proof.
+ intros. inv H. auto.
+Qed.
+*)
+
+(** * Memory injections *)
+
+(** A memory state [m1] injects into another memory state [m2] via the
+ memory injection [f] if the following conditions hold:
+- each access in [m2] that corresponds to a valid access in [m1]
+ is itself valid;
+- the memory value associated in [m1] to an accessible address
+ must inject into [m2]'s memory value at the corersponding address;
+- unallocated blocks in [m1] must be mapped to [None] by [f];
+- if [f b = Some(b', delta)], [b'] must be valid in [m2];
+- distinct blocks in [m1] are mapped to non-overlapping sub-blocks in [m2];
+- the sizes of [m2]'s blocks are representable with signed machine integers;
+- the offsets [delta] are representable with signed machine integers.
+*)
+
+Record inject_ (f: meminj) (m1 m2: mem) : Prop :=
+ mk_inject {
+ mi_inj:
+ mem_inj f m1 m2;
+ mi_freeblocks:
+ forall b, ~(valid_block m1 b) -> f b = None;
+ mi_mappedblocks:
+ forall b b' delta, f b = Some(b', delta) -> valid_block m2 b';
+ mi_no_overlap:
+ meminj_no_overlap f m1;
+ mi_range_offset:
+ forall b b' delta,
+ f b = Some(b', delta) ->
+ Int.min_signed <= delta <= Int.max_signed;
+ mi_range_block:
+ forall b b' delta,
+ f b = Some(b', delta) ->
+ delta = 0 \/
+ (Int.min_signed <= low_bound m2 b' /\ high_bound m2 b' <= Int.max_signed)
+ }.
+
+Definition inject := inject_.
+
+Hint Local Resolve mi_mappedblocks mi_range_offset: mem.
+
+(** Preservation of access validity and pointer validity *)
+
+Theorem valid_block_inject_1:
+ forall f m1 m2 b1 b2 delta,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ valid_block m1 b1.
+Proof.
+ intros. inv H. destruct (zlt b1 (nextblock m1)). auto.
+ assert (f b1 = None). eapply mi_freeblocks; eauto. congruence.
+Qed.
+
+Theorem valid_block_inject_2:
+ forall f m1 m2 b1 b2 delta,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ valid_block m2 b2.
+Proof.
+ intros. eapply mi_mappedblocks; eauto.
+Qed.
+
+Hint Local Resolve valid_block_inject_1 valid_block_inject_2: mem.
+
+Theorem perm_inject:
+ forall f m1 m2 b1 b2 delta ofs p,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ perm m1 b1 ofs p -> perm m2 b2 (ofs + delta) p.
+Proof.
+ intros. inv H0. eapply perm_inj; eauto.
+Qed.
+
+Theorem valid_access_inject:
+ forall f m1 m2 chunk b1 ofs b2 delta p,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ valid_access m1 chunk b1 ofs p ->
+ valid_access m2 chunk b2 (ofs + delta) p.
+Proof.
+ intros. eapply mi_access; eauto. apply mi_inj; auto.
+Qed.
+
+Theorem valid_pointer_inject:
+ forall f m1 m2 b1 ofs b2 delta,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ valid_pointer m1 b1 ofs = true ->
+ valid_pointer m2 b2 (ofs + delta) = true.
+Proof.
+ intros.
+ rewrite valid_pointer_valid_access in H1.
+ rewrite valid_pointer_valid_access.
+ eapply valid_access_inject; eauto.
+Qed.
+
+(** The following lemmas establish the absence of machine integer overflow
+ during address computations. *)
+
+Lemma address_inject:
+ forall f m1 m2 b1 ofs1 b2 delta,
+ inject f m1 m2 ->
+ perm m1 b1 (Int.signed ofs1) Nonempty ->
+ f b1 = Some (b2, delta) ->
+ Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta.
+Proof.
+ intros.
+ exploit perm_inject; eauto. intro A.
+ exploit perm_in_bounds. eexact A. intros [B C].
+ exploit mi_range_block; eauto. intros [D | [E F]].
+ subst delta. rewrite Int.add_zero. omega.
+ rewrite Int.add_signed.
+ repeat rewrite Int.signed_repr. auto.
+ eapply mi_range_offset; eauto.
+ omega.
+ eapply mi_range_offset; eauto.
+Qed.
+
+Lemma address_inject':
+ forall f m1 m2 chunk b1 ofs1 b2 delta,
+ inject f m1 m2 ->
+ valid_access m1 chunk b1 (Int.signed ofs1) Nonempty ->
+ f b1 = Some (b2, delta) ->
+ Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta.
+Proof.
+ intros. destruct H0. eapply address_inject; eauto.
+ apply H0. generalize (size_chunk_pos chunk). omega.
+Qed.
+
+Theorem valid_pointer_inject_no_overflow:
+ forall f m1 m2 b ofs b' x,
+ inject f m1 m2 ->
+ valid_pointer m1 b (Int.signed ofs) = true ->
+ f b = Some(b', x) ->
+ Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed.
+Proof.
+ intros. rewrite valid_pointer_valid_access in H0.
+ exploit address_inject'; eauto. intros.
+ rewrite Int.signed_repr; eauto.
+ rewrite <- H2. apply Int.signed_range.
+ eapply mi_range_offset; eauto.
+Qed.
+
+Theorem valid_pointer_inject_val:
+ forall f m1 m2 b ofs b' ofs',
+ inject f m1 m2 ->
+ valid_pointer m1 b (Int.signed ofs) = true ->
+ val_inject f (Vptr b ofs) (Vptr b' ofs') ->
+ valid_pointer m2 b' (Int.signed ofs') = true.
+Proof.
+ intros. inv H1.
+ exploit valid_pointer_inject_no_overflow; eauto. intro NOOV.
+ rewrite Int.add_signed. rewrite Int.signed_repr; auto.
+ rewrite Int.signed_repr.
+ eapply valid_pointer_inject; eauto.
+ eapply mi_range_offset; eauto.
+Qed.
+
+Theorem inject_no_overlap:
+ forall f m1 m2 b1 b2 b1' b2' delta1 delta2 ofs1 ofs2,
+ inject f m1 m2 ->
+ b1 <> b2 ->
+ f b1 = Some (b1', delta1) ->
+ f b2 = Some (b2', delta2) ->
+ perm m1 b1 ofs1 Nonempty ->
+ perm m1 b2 ofs2 Nonempty ->
+ b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2.
+Proof.
+ intros. inv H. eapply meminj_no_overlap_perm; eauto.
+Qed.
+
+Theorem different_pointers_inject:
+ forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
+ inject f m m' ->
+ b1 <> b2 ->
+ valid_pointer m b1 (Int.signed ofs1) = true ->
+ valid_pointer m b2 (Int.signed ofs2) = true ->
+ f b1 = Some (b1', delta1) ->
+ f b2 = Some (b2', delta2) ->
+ b1' <> b2' \/
+ Int.signed (Int.add ofs1 (Int.repr delta1)) <>
+ Int.signed (Int.add ofs2 (Int.repr delta2)).
+Proof.
+ intros.
+ rewrite valid_pointer_valid_access in H1.
+ rewrite valid_pointer_valid_access in H2.
+ rewrite (address_inject' _ _ _ _ _ _ _ _ H H1 H3).
+ rewrite (address_inject' _ _ _ _ _ _ _ _ H H2 H4).
+ inv H1. simpl in H5. inv H2. simpl in H1.
+ eapply meminj_no_overlap_perm.
+ eapply mi_no_overlap; eauto. eauto. eauto. eauto.
+ apply (H5 (Int.signed ofs1)). omega.
+ apply (H1 (Int.signed ofs2)). omega.
+Qed.
+
+(** Preservation of loads *)
+
+Theorem load_inject:
+ forall f m1 m2 chunk b1 ofs b2 delta v1,
+ inject f m1 m2 ->
+ load chunk m1 b1 ofs = Some v1 ->
+ f b1 = Some (b2, delta) ->
+ exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2.
+Proof.
+ intros. inv H. eapply load_inj; eauto.
+Qed.
+
+Theorem loadv_inject:
+ forall f m1 m2 chunk a1 a2 v1,
+ inject f m1 m2 ->
+ loadv chunk m1 a1 = Some v1 ->
+ val_inject f a1 a2 ->
+ exists v2, loadv chunk m2 a2 = Some v2 /\ val_inject f v1 v2.
+Proof.
+ intros. inv H1; simpl in H0; try discriminate.
+ exploit load_inject; eauto. intros [v2 [LOAD INJ]].
+ exists v2; split; auto. simpl.
+ replace (Int.signed (Int.add ofs1 (Int.repr delta)))
+ with (Int.signed ofs1 + delta).
+ auto. symmetry. eapply address_inject'; eauto with mem.
+Qed.
+
+(** Preservation of stores *)
+
+Theorem store_mapped_inject:
+ forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2,
+ inject f m1 m2 ->
+ store chunk m1 b1 ofs v1 = Some n1 ->
+ f b1 = Some (b2, delta) ->
+ val_inject f v1 v2 ->
+ exists n2,
+ store chunk m2 b2 (ofs + delta) v2 = Some n2
+ /\ inject f n1 n2.
+Proof.
+ intros. inversion H.
+ exploit store_mapped_inj; eauto. intros [n2 [STORE MI]].
+ exists n2; split. eauto. constructor.
+(* inj *)
+ auto.
+(* freeblocks *)
+ eauto with mem.
+(* mappedblocks *)
+ eauto with mem.
+(* no overlap *)
+ red; intros.
+ repeat rewrite (bounds_store _ _ _ _ _ _ H0).
+ eauto.
+(* range offset *)
+ eauto.
+(* range blocks *)
+ intros. rewrite (bounds_store _ _ _ _ _ _ STORE). eauto.
+Qed.
+
+Theorem store_unmapped_inject:
+ forall f chunk m1 b1 ofs v1 n1 m2,
+ inject f m1 m2 ->
+ store chunk m1 b1 ofs v1 = Some n1 ->
+ f b1 = None ->
+ inject f n1 m2.
+Proof.
+ intros. inversion H.
+ constructor.
+(* inj *)
+ eapply store_unmapped_inj; eauto.
+(* freeblocks *)
+ eauto with mem.
+(* mappedblocks *)
+ eauto with mem.
+(* no overlap *)
+ red; intros.
+ repeat rewrite (bounds_store _ _ _ _ _ _ H0).
+ eauto.
+(* range offset *)
+ eauto.
+(* range blocks *)
+ auto.
+Qed.
+
+Theorem store_outside_inject:
+ forall f m1 m2 chunk b ofs v m2',
+ inject f m1 m2 ->
+ (forall b' delta,
+ f b' = Some(b, delta) ->
+ high_bound m1 b' + delta <= ofs
+ \/ ofs + size_chunk chunk <= low_bound m1 b' + delta) ->
+ store chunk m2 b ofs v = Some m2' ->
+ inject f m1 m2'.
+Proof.
+ intros. inversion H. constructor.
+(* inj *)
+ eapply store_outside_inj; eauto.
+ intros. exploit perm_in_bounds; eauto. intro.
+ exploit H0; eauto. intro. omega.
+(* freeblocks *)
+ auto.
+(* mappedblocks *)
+ eauto with mem.
+(* no overlap *)
+ auto.
+(* range offset *)
+ auto.
+(* rang blocks *)
+ intros. rewrite (bounds_store _ _ _ _ _ _ H1). eauto.
+Qed.
+
+Theorem storev_mapped_inject:
+ forall f chunk m1 a1 v1 n1 m2 a2 v2,
+ inject f m1 m2 ->
+ storev chunk m1 a1 v1 = Some n1 ->
+ val_inject f a1 a2 ->
+ val_inject f v1 v2 ->
+ exists n2,
+ storev chunk m2 a2 v2 = Some n2 /\ inject f n1 n2.
+Proof.
+ intros. inv H1; simpl in H0; try discriminate.
+ simpl. replace (Int.signed (Int.add ofs1 (Int.repr delta)))
+ with (Int.signed ofs1 + delta).
+ eapply store_mapped_inject; eauto.
+ symmetry. eapply address_inject'; eauto with mem.
+Qed.
+
+(* Preservation of allocations *)
+
+Theorem alloc_right_inject:
+ forall f m1 m2 lo hi b2 m2',
+ inject f m1 m2 ->
+ alloc m2 lo hi = (m2', b2) ->
+ inject f m1 m2'.
+Proof.
+ intros. injection H0. intros NEXT MEM.
+ inversion H. constructor.
+(* inj *)
+ eapply alloc_right_inj; eauto.
+(* freeblocks *)
+ auto.
+(* mappedblocks *)
+ eauto with mem.
+(* no overlap *)
+ auto.
+(* range offset *)
+ auto.
+(* range block *)
+ intros. rewrite (bounds_alloc_other _ _ _ _ _ H0). eauto.
+ eapply valid_not_valid_diff; eauto with mem.
+Qed.
+
+Theorem alloc_left_unmapped_inject:
+ forall f m1 m2 lo hi m1' b1,
+ inject f m1 m2 ->
+ alloc m1 lo hi = (m1', b1) ->
+ exists f',
+ inject f' m1' m2
+ /\ inject_incr f f'
+ /\ f' b1 = None
+ /\ (forall b, b <> b1 -> f' b = f b).
+Proof.
+ intros. inversion H.
+ assert (inject_incr f (update b1 None f)).
+ red; unfold update; intros. destruct (zeq b b1). subst b.
+ assert (f b1 = None). eauto with mem. congruence.
+ auto.
+ assert (mem_inj (update b1 None f) m1 m2).
+ inversion mi_inj0; constructor; eauto with mem.
+ unfold update; intros. destruct (zeq b0 b1). congruence. eauto.
+ unfold update; intros. destruct (zeq b0 b1). congruence.
+ apply memval_inject_incr with f; auto.
+ exists (update b1 None f); split. constructor.
+(* inj *)
+ eapply alloc_left_unmapped_inj; eauto. apply update_s.
+(* freeblocks *)
+ intros. unfold update. destruct (zeq b b1). auto.
+ apply mi_freeblocks0. red; intro; elim H3. eauto with mem.
+(* mappedblocks *)
+ unfold update; intros. destruct (zeq b b1). congruence. eauto.
+(* no overlap *)
+ unfold update; red; intros.
+ destruct (zeq b0 b1); destruct (zeq b2 b1); try congruence.
+ repeat rewrite (bounds_alloc_other _ _ _ _ _ H0); eauto.
+(* range offset *)
+ unfold update; intros.
+ destruct (zeq b b1). congruence. eauto.
+(* range block *)
+ unfold update; intros.
+ destruct (zeq b b1). congruence. eauto.
+(* incr *)
+ split. auto.
+(* image *)
+ split. apply update_s.
+(* incr *)
+ intros; apply update_o; auto.
+Qed.
+
+Theorem alloc_left_mapped_inject:
+ forall f m1 m2 lo hi m1' b1 b2 delta,
+ inject f m1 m2 ->
+ alloc m1 lo hi = (m1', b1) ->
+ valid_block m2 b2 ->
+ Int.min_signed <= delta <= Int.max_signed ->
+ delta = 0 \/ Int.min_signed <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_signed ->
+ (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) ->
+ inj_offset_aligned delta (hi-lo) ->
+ (forall b ofs,
+ f b = Some (b2, ofs) ->
+ high_bound m1 b + ofs <= lo + delta \/
+ hi + delta <= low_bound m1 b + ofs) ->
+ exists f',
+ inject f' m1' m2
+ /\ inject_incr f f'
+ /\ f' b1 = Some(b2, delta)
+ /\ (forall b, b <> b1 -> f' b = f b).
+Proof.
+ intros. inversion H.
+ assert (inject_incr f (update b1 (Some(b2, delta)) f)).
+ red; unfold update; intros. destruct (zeq b b1). subst b.
+ assert (f b1 = None). eauto with mem. congruence.
+ auto.
+ assert (mem_inj (update b1 (Some(b2, delta)) f) m1 m2).
+ inversion mi_inj0; constructor; eauto with mem.
+ unfold update; intros. destruct (zeq b0 b1).
+ inv H8. elim (fresh_block_alloc _ _ _ _ _ H0). eauto with mem.
+ eauto.
+ unfold update; intros. destruct (zeq b0 b1).
+ inv H8. elim (fresh_block_alloc _ _ _ _ _ H0). eauto with mem.
+ apply memval_inject_incr with f; auto.
+ exists (update b1 (Some(b2, delta)) f). split. constructor.
+(* inj *)
+ eapply alloc_left_mapped_inj; eauto. apply update_s.
+(* freeblocks *)
+ unfold update; intros. destruct (zeq b b1). subst b.
+ elim H9. eauto with mem.
+ eauto with mem.
+(* mappedblocks *)
+ unfold update; intros. destruct (zeq b b1). inv H9. auto.
+ eauto.
+(* overlap *)
+ unfold update; red; intros.
+ repeat rewrite (bounds_alloc _ _ _ _ _ H0). unfold eq_block.
+ destruct (zeq b0 b1); destruct (zeq b3 b1); simpl.
+ inv H10; inv H11. congruence.
+ inv H10. destruct (zeq b1' b2'); auto. subst b2'.
+ right. generalize (H6 _ _ H11). tauto.
+ inv H11. destruct (zeq b1' b2'); auto. subst b2'.
+ right. eapply H6; eauto.
+ eauto.
+(* range offset *)
+ unfold update; intros. destruct (zeq b b1). inv H9. auto. eauto.
+(* range block *)
+ unfold update; intros. destruct (zeq b b1). inv H9. auto. eauto.
+(* incr *)
+ split. auto.
+(* image of b1 *)
+ split. apply update_s.
+(* image of others *)
+ intros. apply update_o; auto.
+Qed.
+
+Theorem alloc_parallel_inject:
+ forall f m1 m2 lo1 hi1 m1' b1 lo2 hi2,
+ inject f m1 m2 ->
+ alloc m1 lo1 hi1 = (m1', b1) ->
+ lo2 <= lo1 -> hi1 <= hi2 ->
+ exists f', exists m2', exists b2,
+ alloc m2 lo2 hi2 = (m2', b2)
+ /\ inject f' m1' m2'
+ /\ inject_incr f f'
+ /\ f' b1 = Some(b2, 0)
+ /\ (forall b, b <> b1 -> f' b = f b).
+Proof.
+ intros.
+ case_eq (alloc m2 lo2 hi2). intros m2' b2 ALLOC.
+ exploit alloc_left_mapped_inject.
+ eapply alloc_right_inject; eauto.
+ eauto.
+ instantiate (1 := b2). eauto with mem.
+ instantiate (1 := 0). generalize Int.min_signed_neg Int.max_signed_pos; omega.
+ auto.
+ intros. eapply perm_alloc_2; eauto. omega.
+ red; intros. apply Zdivide_0.
+ intros. elimtype False. apply (valid_not_valid_diff m2 b2 b2); eauto with mem.
+ intros [f' [A [B [C D]]]].
+ exists f'; exists m2'; exists b2; auto.
+Qed.
+
+(** Preservation of [free] operations *)
+
+Lemma free_left_inject:
+ forall f m1 m2 b lo hi m1',
+ inject f m1 m2 ->
+ free m1 b lo hi = Some m1' ->
+ inject f m1' m2.
+Proof.
+ intros. inversion H. constructor.
+(* inj *)
+ eapply free_left_inj; eauto.
+(* freeblocks *)
+ eauto with mem.
+(* mappedblocks *)
+ auto.
+(* no overlap *)
+ red; intros. repeat rewrite (bounds_free _ _ _ _ _ H0). eauto.
+(* range offset *)
+ auto.
+(* range block *)
+ auto.
+Qed.
+
+Lemma free_list_left_inject:
+ forall f m2 l m1 m1',
+ inject f m1 m2 ->
+ free_list m1 l = Some m1' ->
+ inject f m1' m2.
+Proof.
+ induction l; simpl; intros.
+ inv H0. auto.
+ destruct a as [[b lo] hi]. generalize H0. case_eq (free m1 b lo hi); intros.
+ apply IHl with m; auto. eapply free_left_inject; eauto.
+ congruence.
+Qed.
+
+Lemma free_right_inject:
+ forall f m1 m2 b lo hi m2',
+ inject f m1 m2 ->
+ free m2 b lo hi = Some m2' ->
+ (forall b1 delta ofs p,
+ f b1 = Some(b, delta) -> perm m1 b1 ofs p ->
+ lo <= ofs + delta < hi -> False) ->
+ inject f m1 m2'.
+Proof.
+ intros. inversion H. constructor.
+(* inj *)
+ eapply free_right_inj; eauto.
+(* freeblocks *)
+ auto.
+(* mappedblocks *)
+ eauto with mem.
+(* no overlap *)
+ auto.
+(* range offset *)
+ auto.
+(* range blocks *)
+ intros. rewrite (bounds_free _ _ _ _ _ H0). eauto.
+Qed.
+
+Lemma perm_free_list:
+ forall l m m' b ofs p,
+ free_list m l = Some m' ->
+ perm m' b ofs p ->
+ perm m b ofs p /\
+ (forall lo hi, In (b, lo, hi) l -> lo <= ofs < hi -> False).
+Proof.
+ induction l; intros until p; simpl.
+ intros. inv H. split; auto.
+ destruct a as [[b1 lo1] hi1].
+ case_eq (free m b1 lo1 hi1); intros; try congruence.
+ exploit IHl; eauto. intros [A B].
+ split. eauto with mem.
+ intros. destruct H2. inv H2.
+ elim (perm_free_2 _ _ _ _ _ H ofs p). auto. auto.
+ eauto.
+Qed.
+
+Theorem free_inject:
+ forall f m1 l m1' m2 b lo hi m2',
+ inject f m1 m2 ->
+ free_list m1 l = Some m1' ->
+ free m2 b lo hi = Some m2' ->
+ (forall b1 delta ofs p,
+ f b1 = Some(b, delta) ->
+ perm m1 b1 ofs p -> lo <= ofs + delta < hi ->
+ exists lo1, exists hi1, In (b1, lo1, hi1) l /\ lo1 <= ofs < hi1) ->
+ inject f m1' m2'.
+Proof.
+ intros.
+ eapply free_right_inject; eauto.
+ eapply free_list_left_inject; eauto.
+ intros. exploit perm_free_list; eauto. intros [A B].
+ exploit H2; eauto. intros [lo1 [hi1 [C D]]]. eauto.
+Qed.
+
+(*
+Theorem free_inject':
+ forall f m1 l m1' m2 b lo hi m2',
+ inject f m1 m2 ->
+ free_list m1 l = Some m1' ->
+ free m2 b lo hi = Some m2' ->
+ (forall b1 delta,
+ f b1 = Some(b, delta) -> In (b1, low_bound m1 b1, high_bound m1 b1) l) ->
+ inject f m1' m2'.
+Proof.
+ intros. eapply free_inject; eauto.
+ intros. exists (low_bound m1 b1); exists (high_bound m1 b1).
+ split. eauto. apply perm_in_bounds with p. auto.
+Qed.
+*)
+
+(** Injecting a memory into itself. *)
+
+Definition flat_inj (thr: block) : meminj :=
+ fun (b: block) => if zlt b thr then Some(b, 0) else None.
+
+Definition inject_neutral (thr: block) (m: mem) :=
+ mem_inj (flat_inj thr) m m.
+
+Remark flat_inj_no_overlap:
+ forall thr m, meminj_no_overlap (flat_inj thr) m.
+Proof.
+ unfold flat_inj; intros; red; intros.
+ destruct (zlt b1 thr); inversion H0; subst.
+ destruct (zlt b2 thr); inversion H1; subst.
+ auto.
+Qed.
+
+Theorem neutral_inject:
+ forall m, inject_neutral (nextblock m) m -> inject (flat_inj (nextblock m)) m m.
+Proof.
+ intros. constructor.
+(* meminj *)
+ auto.
+(* freeblocks *)
+ unfold flat_inj, valid_block; intros.
+ apply zlt_false. omega.
+(* mappedblocks *)
+ unfold flat_inj, valid_block; intros.
+ destruct (zlt b (nextblock m)); inversion H0; subst. auto.
+(* no overlap *)
+ apply flat_inj_no_overlap.
+(* range *)
+ unfold flat_inj; intros.
+ destruct (zlt b (nextblock m)); inv H0.
+ generalize Int.min_signed_neg Int.max_signed_pos; omega.
+(* range *)
+ unfold flat_inj; intros.
+ destruct (zlt b (nextblock m)); inv H0. auto.
+Qed.
+
+Theorem empty_inject_neutral:
+ forall thr, inject_neutral thr empty.
+Proof.
+ intros; red; constructor.
+(* access *)
+ unfold flat_inj; intros. destruct (zlt b1 thr); inv H.
+ replace (ofs + 0) with ofs by omega; auto.
+(* contents *)
+ intros; simpl; constructor.
+Qed.
+
+Theorem alloc_inject_neutral:
+ forall thr m lo hi b m',
+ alloc m lo hi = (m', b) ->
+ inject_neutral thr m ->
+ nextblock m < thr ->
+ inject_neutral thr m'.
+Proof.
+ intros; red.
+ eapply alloc_left_mapped_inj with (m1 := m) (b2 := b) (delta := 0).
+ eapply alloc_right_inj; eauto. eauto. eauto with mem.
+ red. intros. apply Zdivide_0.
+ intros. eapply perm_alloc_2; eauto. omega.
+ unfold flat_inj. apply zlt_true.
+ rewrite (alloc_result _ _ _ _ _ H). auto.
+Qed.
+
+Theorem store_inject_neutral:
+ forall chunk m b ofs v m' thr,
+ store chunk m b ofs v = Some m' ->
+ inject_neutral thr m ->
+ b < thr ->
+ val_inject (flat_inj thr) v v ->
+ inject_neutral thr m'.
+Proof.
+ intros; red.
+ exploit store_mapped_inj. eauto. eauto. apply flat_inj_no_overlap.
+ unfold flat_inj. apply zlt_true; auto. eauto.
+ replace (ofs + 0) with ofs by omega.
+ intros [m'' [A B]]. congruence.
+Qed.
+
+End Mem.
+
+Notation mem := Mem.mem.
+
+Hint Resolve
+ Mem.valid_not_valid_diff
+ Mem.perm_implies
+ Mem.perm_valid_block
+ Mem.range_perm_implies
+ Mem.valid_access_implies
+ Mem.valid_access_valid_block
+ Mem.valid_access_perm
+ Mem.valid_access_load
+ Mem.load_valid_access
+ Mem.valid_access_store
+ Mem.perm_store_1
+ Mem.perm_store_2
+ Mem.nextblock_store
+ Mem.store_valid_block_1
+ Mem.store_valid_block_2
+ Mem.store_valid_access_1
+ Mem.store_valid_access_2
+ Mem.store_valid_access_3
+ Mem.nextblock_alloc
+ Mem.alloc_result
+ Mem.valid_block_alloc
+ Mem.fresh_block_alloc
+ Mem.valid_new_block
+ Mem.perm_alloc_1
+ Mem.perm_alloc_2
+ Mem.perm_alloc_3
+ Mem.perm_alloc_inv
+ Mem.valid_access_alloc_other
+ Mem.valid_access_alloc_same
+ Mem.valid_access_alloc_inv
+ Mem.range_perm_free
+ Mem.free_range_perm
+ Mem.nextblock_free
+ Mem.valid_block_free_1
+ Mem.valid_block_free_2
+ Mem.perm_free_1
+ Mem.perm_free_2
+ Mem.perm_free_3
+ Mem.valid_access_free_1
+ Mem.valid_access_free_2
+ Mem.valid_access_free_inv_1
+ Mem.valid_access_free_inv_2
+: mem.
diff --git a/common/Memtype.v b/common/Memtype.v
new file mode 100644
index 0000000..cfbe511
--- /dev/null
+++ b/common/Memtype.v
@@ -0,0 +1,989 @@
+(* *********************************************************************)
+(* *)
+(* 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 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. *)
+(* *)
+(* *********************************************************************)
+
+(** This file defines the interface for the memory model that
+ is used in the dynamic semantics of all the languages used in the compiler.
+ It defines a type [mem] of memory states, the following 4 basic
+ operations over memory states, and their properties:
+- [load]: read a memory chunk at a given address;
+- [store]: store a memory chunk at a given address;
+- [alloc]: allocate a fresh memory block;
+- [free]: invalidate a memory block.
+*)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memdata.
+
+(** Memory states are accessed by addresses [b, ofs]: pairs of a block
+ identifier [b] and a byte offset [ofs] within that block.
+ Each address is in one of the following five states:
+- Freeable (exclusive access): all operations permitted
+- Writable: load, store and pointer comparison operations are permitted,
+ but freeing is not.
+- Readable: only load and pointer comparison operations are permitted.
+- Nonempty: valid, but only pointer comparisons are permitted.
+- Empty: not yet allocated or previously freed; no operation permitted.
+
+The first four cases are represented by the following type of permissions.
+Being empty is represented by the absence of any permission.
+*)
+
+Inductive permission: Type :=
+ | Freeable: permission
+ | Writable: permission
+ | Readable: permission
+ | Nonempty: permission.
+
+(** In the list, each permission implies the other permissions further down the
+ list. We reflect this fact by the following order over permissions. *)
+
+Inductive perm_order: permission -> permission -> Prop :=
+ | perm_F_any: forall p, perm_order Freeable p
+ | perm_W_R: perm_order Writable Readable
+ | perm_any_N: forall p, perm_order p Nonempty.
+
+Hint Constructors perm_order: mem.
+
+Module Type MEM.
+
+(** The abstract type of memory states. *)
+Parameter mem: Type.
+
+Definition nullptr: block := 0.
+
+(** * Operations on memory states *)
+
+(** [empty] is the initial memory state. *)
+Parameter empty: mem.
+
+(** [alloc m lo hi] allocates a fresh block of size [hi - lo] bytes.
+ Valid offsets in this block are between [lo] included and [hi] excluded.
+ These offsets are writable in the returned memory state.
+ This block is not initialized: its contents are initially undefined.
+ Returns a pair [(m', b)] of the updated memory state [m'] and
+ the identifier [b] of the newly-allocated block.
+ Note that [alloc] never fails: we are modeling an infinite memory. *)
+Parameter alloc: forall (m: mem) (lo hi: Z), mem * block.
+
+(** [free m b lo hi] frees (deallocates) the range of offsets from [lo]
+ included to [hi] excluded in block [b]. Returns the updated memory
+ state, or [None] if the freed addresses are not writable. *)
+Parameter free: forall (m: mem) (b: block) (lo hi: Z), option mem.
+
+(** [load chunk m b ofs] reads a memory quantity [chunk] from
+ addresses [b, ofs] to [b, ofs + size_chunk chunk - 1] in memory state
+ [m]. Returns the value read, or [None] if the accessed addresses
+ are not readable. *)
+Parameter load: forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z), option val.
+
+(** [store chunk m b ofs v] writes value [v] as memory quantity [chunk]
+ from addresses [b, ofs] to [b, ofs + size_chunk chunk - 1] in memory state
+ [m]. Returns the updated memory state, or [None] if the accessed addresses
+ are not writable. *)
+Parameter store: forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val), option mem.
+
+(** [loadv] and [storev] are variants of [load] and [store] where
+ the address being accessed is passed as a value (of the [Vptr] kind). *)
+
+Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val :=
+ match addr with
+ | Vptr b ofs => load chunk m b (Int.signed ofs)
+ | _ => None
+ end.
+
+Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem :=
+ match addr with
+ | Vptr b ofs => store chunk m b (Int.signed ofs) v
+ | _ => None
+ end.
+
+(** [loadbytes m b ofs n] reads and returns the byte-level representation of
+ the values contained at offsets [ofs] to [ofs + n - 1] within block [b]
+ in memory state [m]. These values must be integers or floats.
+ [None] is returned if the accessed addresses are not readable
+ or contain undefined or pointer values. *)
+Parameter loadbytes: forall (m: mem) (b: block) (ofs n: Z), option (list byte).
+
+(** [free_list] frees all the given (block, lo, hi) triples. *)
+Fixpoint free_list (m: mem) (l: list (block * Z * Z)) {struct l}: option mem :=
+ match l with
+ | nil => Some m
+ | (b, lo, hi) :: l' =>
+ match free m b lo hi with
+ | None => None
+ | Some m' => free_list m' l'
+ end
+ end.
+
+(** * Permissions, block validity, access validity, and bounds *)
+
+(** The next block of a memory state is the block identifier for the
+ next allocation. It increases by one at each allocation.
+ Block identifiers below [nextblock] are said to be valid, meaning
+ that they have been allocated previously. Block identifiers above
+ [nextblock] are fresh or invalid, i.e. not yet allocated. Note that
+ a block identifier remains valid after a [free] operation over this
+ block. *)
+
+Parameter nextblock: mem -> block.
+Axiom nextblock_pos:
+ forall m, nextblock m > 0.
+
+Definition valid_block (m: mem) (b: block) :=
+ b < nextblock m.
+Axiom valid_not_valid_diff:
+ forall m b b', valid_block m b -> ~(valid_block m b') -> b <> b'.
+
+(** [perm m b ofs p] holds if the address [b, ofs] in memory state [m]
+ has permission [p]: one of writable, readable, and nonempty.
+ If the address is empty, [perm m b ofs p] is false for all values of [p]. *)
+Parameter perm: forall (m: mem) (b: block) (ofs: Z) (p: permission), Prop.
+
+(** Logical implications between permissions *)
+
+Axiom perm_implies:
+ forall m b ofs p1 p2, perm m b ofs p1 -> perm_order p1 p2 -> perm m b ofs p2.
+
+(** Having a (nonempty) permission implies that the block is valid.
+ In other words, invalid blocks, not yet allocated, are all empty. *)
+Axiom perm_valid_block:
+ forall m b ofs p, perm m b ofs p -> valid_block m b.
+
+(* Unused?
+(** The [Mem.perm] predicate is decidable. *)
+Axiom perm_dec:
+ forall m b ofs p, {perm m b ofs p} + {~ perm m b ofs p}.
+*)
+
+(** [range_perm m b lo hi p] holds iff the addresses [b, lo] to [b, hi-1]
+ all have permission [p]. *)
+Definition range_perm (m: mem) (b: block) (lo hi: Z) (p: permission) : Prop :=
+ forall ofs, lo <= ofs < hi -> perm m b ofs p.
+
+Axiom range_perm_implies:
+ forall m b lo hi p1 p2,
+ range_perm m b lo hi p1 -> perm_order p1 p2 -> range_perm m b lo hi p2.
+
+(** An access to a memory quantity [chunk] at address [b, ofs] with
+ permission [p] is valid in [m] if the accessed addresses all have
+ permission [p] and moreover the offset is properly aligned. *)
+Definition valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) (p: permission): Prop :=
+ range_perm m b ofs (ofs + size_chunk chunk) p
+ /\ (align_chunk chunk | ofs).
+
+Axiom valid_access_implies:
+ forall m chunk b ofs p1 p2,
+ valid_access m chunk b ofs p1 -> perm_order p1 p2 ->
+ valid_access m chunk b ofs p2.
+
+Axiom valid_access_valid_block:
+ forall m chunk b ofs,
+ valid_access m chunk b ofs Nonempty ->
+ valid_block m b.
+
+Axiom valid_access_perm:
+ forall m chunk b ofs p,
+ valid_access m chunk b ofs p ->
+ perm m b ofs p.
+
+(** [valid_pointer m b ofs] returns [true] if the address [b, ofs]
+ is nonempty in [m] and [false] if it is empty. *)
+
+Parameter valid_pointer: forall (m: mem) (b: block) (ofs: Z), bool.
+
+Axiom valid_pointer_nonempty_perm:
+ forall m b ofs,
+ valid_pointer m b ofs = true <-> perm m b ofs Nonempty.
+Axiom valid_pointer_valid_access:
+ forall m b ofs,
+ valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty.
+
+(** Each block has associated low and high bounds. These are the bounds
+ that were given when the block was allocated. *)
+
+Parameter bounds: forall (m: mem) (b: block), Z*Z.
+
+Notation low_bound m b := (fst(bounds m b)).
+Notation high_bound m b := (snd(bounds m b)).
+
+(** The crucial properties of bounds is that any offset below the low
+ bound or above the high bound is empty. *)
+
+Axiom perm_in_bounds:
+ forall m b ofs p, perm m b ofs p -> low_bound m b <= ofs < high_bound m b.
+
+Axiom range_perm_in_bounds:
+ forall m b lo hi p,
+ range_perm m b lo hi p -> lo < hi ->
+ low_bound m b <= lo /\ hi <= high_bound m b.
+
+Axiom valid_access_in_bounds:
+ forall m chunk b ofs p,
+ valid_access m chunk b ofs p ->
+ low_bound m b <= ofs /\ ofs + size_chunk chunk <= high_bound m b.
+
+(** * Properties of the memory operations *)
+
+(** ** Properties of the initial memory state. *)
+
+Axiom nextblock_empty: nextblock empty = 1.
+Axiom perm_empty: forall b ofs p, ~perm empty b ofs p.
+Axiom valid_access_empty:
+ forall chunk b ofs p, ~valid_access empty chunk b ofs p.
+
+(** ** Properties of [load]. *)
+
+(** A load succeeds if and only if the access is valid for reading *)
+Axiom valid_access_load:
+ forall m chunk b ofs,
+ valid_access m chunk b ofs Readable ->
+ exists v, load chunk m b ofs = Some v.
+Axiom load_valid_access:
+ forall m chunk b ofs v,
+ load chunk m b ofs = Some v ->
+ valid_access m chunk b ofs Readable.
+
+(** The value returned by [load] belongs to the type of the memory quantity
+ accessed: [Vundef], [Vint] or [Vptr] for an integer quantity,
+ [Vundef] or [Vfloat] for a float quantity. *)
+Axiom load_type:
+ forall m chunk b ofs v,
+ load chunk m b ofs = Some v ->
+ Val.has_type v (type_of_chunk chunk).
+
+(** For a small integer or float type, the value returned by [load]
+ is invariant under the corresponding cast. *)
+Axiom load_cast:
+ forall m chunk b ofs v,
+ load chunk m b ofs = Some v ->
+ match chunk with
+ | Mint8signed => v = Val.sign_ext 8 v
+ | Mint8unsigned => v = Val.zero_ext 8 v
+ | Mint16signed => v = Val.sign_ext 16 v
+ | Mint16unsigned => v = Val.zero_ext 16 v
+ | Mfloat32 => v = Val.singleoffloat v
+ | _ => True
+ end.
+
+Axiom load_int8_signed_unsigned:
+ forall m b ofs,
+ load Mint8signed m b ofs = option_map (Val.sign_ext 8) (load Mint8unsigned m b ofs).
+
+Axiom load_int16_signed_unsigned:
+ forall m b ofs,
+ load Mint16signed m b ofs = option_map (Val.sign_ext 16) (load Mint16unsigned m b ofs).
+
+
+(** ** Properties of [loadbytes]. *)
+
+(** If [loadbytes] succeeds, the corresponding [load] succeeds and
+ returns a [Vint] or [Vfloat] value that is determined by the
+ bytes read by [loadbytes]. *)
+Axiom loadbytes_load:
+ forall chunk m b ofs bytes,
+ loadbytes m b ofs (size_chunk chunk) = Some bytes ->
+ (align_chunk chunk | ofs) ->
+ load chunk m b ofs =
+ Some(match type_of_chunk chunk with
+ | Tint => Vint(decode_int chunk bytes)
+ | Tfloat => Vfloat(decode_float chunk bytes)
+ end).
+
+(** Conversely, if [load] returns an int or a float, the corresponding
+ [loadbytes] succeeds and returns a list of bytes which decodes into the
+ result of [load]. *)
+Axiom load_int_loadbytes:
+ forall chunk m b ofs n,
+ load chunk m b ofs = Some(Vint n) ->
+ type_of_chunk chunk = Tint /\
+ exists bytes, loadbytes m b ofs (size_chunk chunk) = Some bytes
+ /\ n = decode_int chunk bytes.
+
+Axiom load_float_loadbytes:
+ forall chunk m b ofs f,
+ load chunk m b ofs = Some(Vfloat f) ->
+ type_of_chunk chunk = Tfloat /\
+ exists bytes, loadbytes m b ofs (size_chunk chunk) = Some bytes
+ /\ f = decode_float chunk bytes.
+
+
+(** [loadbytes] returns a list of length [n] (the number of bytes read). *)
+Axiom loadbytes_length:
+ forall m b ofs n bytes,
+ loadbytes m b ofs n = Some bytes ->
+ length bytes = nat_of_Z n.
+
+(** Composing or decomposing [loadbytes] operations at adjacent addresses. *)
+Axiom loadbytes_concat:
+ forall m b ofs n1 n2 bytes1 bytes2,
+ loadbytes m b ofs n1 = Some bytes1 ->
+ loadbytes m b (ofs + n1) n2 = Some bytes2 ->
+ n1 >= 0 -> n2 >= 0 ->
+ loadbytes m b ofs (n1 + n2) = Some(bytes1 ++ bytes2).
+Axiom loadbytes_split:
+ forall m b ofs n1 n2 bytes,
+ loadbytes m b ofs (n1 + n2) = Some bytes ->
+ n1 >= 0 -> n2 >= 0 ->
+ exists bytes1, exists bytes2,
+ loadbytes m b ofs n1 = Some bytes1
+ /\ loadbytes m b (ofs + n1) n2 = Some bytes2
+ /\ bytes = bytes1 ++ bytes2.
+
+(** ** Properties of [store]. *)
+
+(** [store] preserves block validity, permissions, access validity, and bounds.
+ Moreover, a [store] succeeds if and only if the corresponding access
+ is valid for writing. *)
+
+Axiom nextblock_store:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ nextblock m2 = nextblock m1.
+Axiom store_valid_block_1:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall b', valid_block m1 b' -> valid_block m2 b'.
+Axiom store_valid_block_2:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall b', valid_block m2 b' -> valid_block m1 b'.
+
+Axiom perm_store_1:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall b' ofs' p, perm m1 b' ofs' p -> perm m2 b' ofs' p.
+Axiom perm_store_2:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall b' ofs' p, perm m2 b' ofs' p -> perm m1 b' ofs' p.
+
+Axiom valid_access_store:
+ forall m1 chunk b ofs v,
+ valid_access m1 chunk b ofs Writable ->
+ { m2: mem | store chunk m1 b ofs v = Some m2 }.
+Axiom store_valid_access_1:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall chunk' b' ofs' p,
+ valid_access m1 chunk' b' ofs' p -> valid_access m2 chunk' b' ofs' p.
+Axiom store_valid_access_2:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall chunk' b' ofs' p,
+ valid_access m2 chunk' b' ofs' p -> valid_access m1 chunk' b' ofs' p.
+Axiom store_valid_access_3:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ valid_access m1 chunk b ofs Writable.
+
+Axiom bounds_store:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall b', bounds m2 b' = bounds m1 b'.
+
+(** Load-store properties. *)
+
+Axiom load_store_similar:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall chunk',
+ size_chunk chunk' = size_chunk chunk ->
+ exists v', load chunk' m2 b ofs = Some v' /\ decode_encode_val v chunk chunk' v'.
+
+Axiom load_store_same:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ Val.has_type v (type_of_chunk chunk) ->
+ load chunk m2 b ofs = Some (Val.load_result chunk v).
+
+Axiom load_store_other:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall chunk' b' ofs',
+ b' <> b
+ \/ ofs' + size_chunk chunk' <= ofs
+ \/ ofs + size_chunk chunk <= ofs' ->
+ load chunk' m2 b' ofs' = load chunk' m1 b' ofs'.
+
+(** Integrity of pointer values. *)
+
+Axiom load_store_pointer_overlap:
+ forall chunk m1 b ofs v_b v_o m2 chunk' ofs' v,
+ store chunk m1 b ofs (Vptr v_b v_o) = Some m2 ->
+ load chunk' m2 b ofs' = Some v ->
+ ofs' <> ofs ->
+ ofs' + size_chunk chunk' > ofs ->
+ ofs + size_chunk chunk > ofs' ->
+ v = Vundef.
+Axiom load_store_pointer_mismatch:
+ forall chunk m1 b ofs v_b v_o m2 chunk' v,
+ store chunk m1 b ofs (Vptr v_b v_o) = Some m2 ->
+ load chunk' m2 b ofs = Some v ->
+ chunk <> Mint32 \/ chunk' <> Mint32 ->
+ v = Vundef.
+Axiom load_pointer_store:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall chunk' b' ofs' v_b v_o,
+ load chunk' m2 b' ofs' = Some(Vptr v_b v_o) ->
+ (chunk = Mint32 /\ v = Vptr v_b v_o /\ chunk' = Mint32 /\ b' = b /\ ofs' = ofs)
+ \/ (b' <> b \/ ofs' + size_chunk chunk' <= ofs \/ ofs + size_chunk chunk <= ofs').
+
+(** Load-store properties for [loadbytes]. *)
+
+Axiom loadbytes_store_same:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ loadbytes m2 b ofs (size_chunk chunk) =
+ match v with
+ | Vundef => None
+ | Vint n => Some(encode_int chunk n)
+ | Vfloat n => Some(encode_float chunk n)
+ | Vptr _ _ => None
+ end.
+Axiom loadbytes_store_other:
+ forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 ->
+ forall b' ofs' n,
+ b' <> b \/ n <= 0 \/ ofs' + n <= ofs \/ ofs + size_chunk chunk <= ofs' ->
+ loadbytes m2 b' ofs' n = loadbytes m1 b' ofs' n.
+
+(** [store] is insensitive to the signedness or the high bits of
+ small integer quantities. *)
+
+Axiom store_signed_unsigned_8:
+ forall m b ofs v,
+ store Mint8signed m b ofs v = store Mint8unsigned m b ofs v.
+Axiom store_signed_unsigned_16:
+ forall m b ofs v,
+ store Mint16signed m b ofs v = store Mint16unsigned m b ofs v.
+Axiom store_int8_zero_ext:
+ forall m b ofs n,
+ store Mint8unsigned m b ofs (Vint (Int.zero_ext 8 n)) =
+ store Mint8unsigned m b ofs (Vint n).
+Axiom store_int8_sign_ext:
+ forall m b ofs n,
+ store Mint8signed m b ofs (Vint (Int.sign_ext 8 n)) =
+ store Mint8signed m b ofs (Vint n).
+Axiom store_int16_zero_ext:
+ forall m b ofs n,
+ store Mint16unsigned m b ofs (Vint (Int.zero_ext 16 n)) =
+ store Mint16unsigned m b ofs (Vint n).
+Axiom store_int16_sign_ext:
+ forall m b ofs n,
+ store Mint16signed m b ofs (Vint (Int.sign_ext 16 n)) =
+ store Mint16signed m b ofs (Vint n).
+Axiom store_float32_truncate:
+ forall m b ofs n,
+ store Mfloat32 m b ofs (Vfloat (Float.singleoffloat n)) =
+ store Mfloat32 m b ofs (Vfloat n).
+
+(** ** Properties of [alloc]. *)
+
+(** The identifier of the freshly allocated block is the next block
+ of the initial memory state. *)
+
+Axiom alloc_result:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ b = nextblock m1.
+
+(** Effect of [alloc] on block validity. *)
+
+Axiom nextblock_alloc:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ nextblock m2 = Zsucc (nextblock m1).
+
+Axiom valid_block_alloc:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall b', valid_block m1 b' -> valid_block m2 b'.
+Axiom fresh_block_alloc:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ ~(valid_block m1 b).
+Axiom valid_new_block:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ valid_block m2 b.
+Axiom valid_block_alloc_inv:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall b', valid_block m2 b' -> b' = b \/ valid_block m1 b'.
+
+(** Effect of [alloc] on permissions. *)
+
+Axiom perm_alloc_1:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall b' ofs p, perm m1 b' ofs p -> perm m2 b' ofs p.
+Axiom perm_alloc_2:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall ofs, lo <= ofs < hi -> perm m2 b ofs Freeable.
+Axiom perm_alloc_3:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall ofs p, ofs < lo \/ hi <= ofs -> ~perm m2 b ofs p.
+Axiom perm_alloc_inv:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall b' ofs p,
+ perm m2 b' ofs p ->
+ if zeq b' b then lo <= ofs < hi else perm m1 b' ofs p.
+
+(** Effect of [alloc] on access validity. *)
+
+Axiom valid_access_alloc_other:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall chunk b' ofs p,
+ valid_access m1 chunk b' ofs p ->
+ valid_access m2 chunk b' ofs p.
+Axiom valid_access_alloc_same:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall chunk ofs,
+ lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) ->
+ valid_access m2 chunk b ofs Freeable.
+Axiom valid_access_alloc_inv:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall chunk b' ofs p,
+ valid_access m2 chunk b' ofs p ->
+ if eq_block b' b
+ then lo <= ofs /\ ofs + size_chunk chunk <= hi /\ (align_chunk chunk | ofs)
+ else valid_access m1 chunk b' ofs p.
+
+(** Effect of [alloc] on bounds. *)
+
+Axiom bounds_alloc:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall b', bounds m2 b' = if eq_block b' b then (lo, hi) else bounds m1 b'.
+
+Axiom bounds_alloc_same:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ bounds m2 b = (lo, hi).
+
+Axiom bounds_alloc_other:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall b', b' <> b -> bounds m2 b' = bounds m1 b'.
+
+(** Load-alloc properties. *)
+
+Axiom load_alloc_unchanged:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall chunk b' ofs,
+ valid_block m1 b' ->
+ load chunk m2 b' ofs = load chunk m1 b' ofs.
+Axiom load_alloc_other:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall chunk b' ofs v,
+ load chunk m1 b' ofs = Some v ->
+ load chunk m2 b' ofs = Some v.
+Axiom load_alloc_same:
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall chunk ofs v,
+ load chunk m2 b ofs = Some v ->
+ v = Vundef.
+Axiom load_alloc_same':
+ forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) ->
+ forall chunk ofs,
+ lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) ->
+ load chunk m2 b ofs = Some Vundef.
+
+(** ** Properties of [free]. *)
+
+(** [free] succeeds if and only if the correspond range of addresses
+ has [Freeable] permission. *)
+
+Axiom range_perm_free:
+ forall m1 b lo hi,
+ range_perm m1 b lo hi Freeable ->
+ { m2: mem | free m1 b lo hi = Some m2 }.
+Axiom free_range_perm:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ range_perm m1 bf lo hi Freeable.
+
+(** Block validity is preserved by [free]. *)
+
+Axiom nextblock_free:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ nextblock m2 = nextblock m1.
+Axiom valid_block_free_1:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall b, valid_block m1 b -> valid_block m2 b.
+Axiom valid_block_free_2:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall b, valid_block m2 b -> valid_block m1 b.
+
+(** Effect of [free] on permissions. *)
+
+Axiom perm_free_1:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall b ofs p,
+ b <> bf \/ ofs < lo \/ hi <= ofs ->
+ perm m1 b ofs p ->
+ perm m2 b ofs p.
+Axiom perm_free_2:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall ofs p, lo <= ofs < hi -> ~ perm m2 bf ofs p.
+Axiom perm_free_3:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall b ofs p,
+ perm m2 b ofs p -> perm m1 b ofs p.
+
+(** Effect of [free] on access validity. *)
+
+Axiom valid_access_free_1:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall chunk b ofs p,
+ valid_access m1 chunk b ofs p ->
+ b <> bf \/ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs ->
+ valid_access m2 chunk b ofs p.
+Axiom valid_access_free_2:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall chunk ofs p,
+ lo < hi -> ofs + size_chunk chunk > lo -> ofs < hi ->
+ ~(valid_access m2 chunk bf ofs p).
+Axiom valid_access_free_inv_1:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall chunk b ofs p,
+ valid_access m2 chunk b ofs p ->
+ valid_access m1 chunk b ofs p.
+Axiom valid_access_free_inv_2:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall chunk ofs p,
+ valid_access m2 chunk bf ofs p ->
+ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs.
+
+(** [free] preserves bounds. *)
+
+Axiom bounds_free:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall b, bounds m2 b = bounds m1 b.
+
+(** Load-free properties *)
+
+Axiom load_free:
+ forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 ->
+ forall chunk b ofs,
+ b <> bf \/ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs ->
+ load chunk m2 b ofs = load chunk m1 b ofs.
+
+(** * Relating two memory states. *)
+
+(** ** Memory extensions *)
+
+(** A store [m2] extends a store [m1] if [m2] can be obtained from [m1]
+ by relaxing the permissions of [m1] (for instance, allocating larger
+ blocks) and replacing some of the [Vundef] values stored in [m1] by
+ more defined values stored in [m2] at the same addresses. *)
+
+Parameter extends: mem -> mem -> Prop.
+
+Axiom extends_refl:
+ forall m, extends m m.
+
+Axiom load_extends:
+ forall chunk m1 m2 b ofs v1,
+ extends m1 m2 ->
+ load chunk m1 b ofs = Some v1 ->
+ exists v2, load chunk m2 b ofs = Some v2 /\ Val.lessdef v1 v2.
+
+Axiom loadv_extends:
+ forall chunk m1 m2 addr1 addr2 v1,
+ extends m1 m2 ->
+ loadv chunk m1 addr1 = Some v1 ->
+ Val.lessdef addr1 addr2 ->
+ exists v2, loadv chunk m2 addr2 = Some v2 /\ Val.lessdef v1 v2.
+
+Axiom store_within_extends:
+ forall chunk m1 m2 b ofs v1 m1' v2,
+ extends m1 m2 ->
+ store chunk m1 b ofs v1 = Some m1' ->
+ Val.lessdef v1 v2 ->
+ exists m2',
+ store chunk m2 b ofs v2 = Some m2'
+ /\ extends m1' m2'.
+
+Axiom store_outside_extends:
+ forall chunk m1 m2 b ofs v m2',
+ extends m1 m2 ->
+ store chunk m2 b ofs v = Some m2' ->
+ ofs + size_chunk chunk <= low_bound m1 b \/ high_bound m1 b <= ofs ->
+ extends m1 m2'.
+
+Axiom storev_extends:
+ forall chunk m1 m2 addr1 v1 m1' addr2 v2,
+ extends m1 m2 ->
+ storev chunk m1 addr1 v1 = Some m1' ->
+ Val.lessdef addr1 addr2 ->
+ Val.lessdef v1 v2 ->
+ exists m2',
+ storev chunk m2 addr2 v2 = Some m2'
+ /\ extends m1' m2'.
+
+Axiom alloc_extends:
+ forall m1 m2 lo1 hi1 b m1' lo2 hi2,
+ extends m1 m2 ->
+ alloc m1 lo1 hi1 = (m1', b) ->
+ lo2 <= lo1 -> hi1 <= hi2 ->
+ exists m2',
+ alloc m2 lo2 hi2 = (m2', b)
+ /\ extends m1' m2'.
+
+Axiom free_left_extends:
+ forall m1 m2 b lo hi m1',
+ extends m1 m2 ->
+ free m1 b lo hi = Some m1' ->
+ extends m1' m2.
+
+Axiom free_right_extends:
+ forall m1 m2 b lo hi m2',
+ extends m1 m2 ->
+ free m2 b lo hi = Some m2' ->
+ (forall ofs p, lo <= ofs < hi -> ~perm m1 b ofs p) ->
+ extends m1 m2'.
+
+Axiom free_parallel_extends:
+ forall m1 m2 b lo hi m1',
+ extends m1 m2 ->
+ free m1 b lo hi = Some m1' ->
+ exists m2',
+ free m2 b lo hi = Some m2'
+ /\ extends m1' m2'.
+
+Axiom valid_block_extends:
+ forall m1 m2 b,
+ extends m1 m2 ->
+ (valid_block m1 b <-> valid_block m2 b).
+Axiom perm_extends:
+ forall m1 m2 b ofs p,
+ extends m1 m2 -> perm m1 b ofs p -> perm m2 b ofs p.
+Axiom valid_access_extends:
+ forall m1 m2 chunk b ofs p,
+ extends m1 m2 -> valid_access m1 chunk b ofs p -> valid_access m2 chunk b ofs p.
+
+(** * Memory injections *)
+
+(** A memory injection [f] is a function from addresses to either [None]
+ or [Some] of an address and an offset. It defines a correspondence
+ between the blocks of two memory states [m1] and [m2]:
+- if [f b = None], the block [b] of [m1] has no equivalent in [m2];
+- if [f b = Some(b', ofs)], the block [b] of [m2] corresponds to
+ a sub-block at offset [ofs] of the block [b'] in [m2].
+
+A memory injection [f] defines a relation [val_inject] between values
+that is the identity for integer and float values, and relocates pointer
+values as prescribed by [f]. (See module [Values].)
+
+Likewise, a memory injection [f] defines a relation between memory states
+that we now axiomatize. *)
+
+Parameter inject: meminj -> mem -> mem -> Prop.
+
+Axiom valid_block_inject_1:
+ forall f m1 m2 b1 b2 delta,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ valid_block m1 b1.
+
+Axiom valid_block_inject_2:
+ forall f m1 m2 b1 b2 delta,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ valid_block m2 b2.
+
+Axiom perm_inject:
+ forall f m1 m2 b1 b2 delta ofs p,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ perm m1 b1 ofs p -> perm m2 b2 (ofs + delta) p.
+
+Axiom valid_access_inject:
+ forall f m1 m2 chunk b1 ofs b2 delta p,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ valid_access m1 chunk b1 ofs p ->
+ valid_access m2 chunk b2 (ofs + delta) p.
+
+Axiom valid_pointer_inject:
+ forall f m1 m2 b1 ofs b2 delta,
+ f b1 = Some(b2, delta) ->
+ inject f m1 m2 ->
+ valid_pointer m1 b1 ofs = true ->
+ valid_pointer m2 b2 (ofs + delta) = true.
+
+Axiom address_inject:
+ forall f m1 m2 b1 ofs1 b2 delta,
+ inject f m1 m2 ->
+ perm m1 b1 (Int.signed ofs1) Nonempty ->
+ f b1 = Some (b2, delta) ->
+ Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta.
+
+Axiom valid_pointer_inject_no_overflow:
+ forall f m1 m2 b ofs b' x,
+ inject f m1 m2 ->
+ valid_pointer m1 b (Int.signed ofs) = true ->
+ f b = Some(b', x) ->
+ Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed.
+
+Axiom valid_pointer_inject_val:
+ forall f m1 m2 b ofs b' ofs',
+ inject f m1 m2 ->
+ valid_pointer m1 b (Int.signed ofs) = true ->
+ val_inject f (Vptr b ofs) (Vptr b' ofs') ->
+ valid_pointer m2 b' (Int.signed ofs') = true.
+
+Axiom inject_no_overlap:
+ forall f m1 m2 b1 b2 b1' b2' delta1 delta2 ofs1 ofs2,
+ inject f m1 m2 ->
+ b1 <> b2 ->
+ f b1 = Some (b1', delta1) ->
+ f b2 = Some (b2', delta2) ->
+ perm m1 b1 ofs1 Nonempty ->
+ perm m1 b2 ofs2 Nonempty ->
+ b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2.
+
+Axiom different_pointers_inject:
+ forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
+ inject f m m' ->
+ b1 <> b2 ->
+ valid_pointer m b1 (Int.signed ofs1) = true ->
+ valid_pointer m b2 (Int.signed ofs2) = true ->
+ f b1 = Some (b1', delta1) ->
+ f b2 = Some (b2', delta2) ->
+ b1' <> b2' \/
+ Int.signed (Int.add ofs1 (Int.repr delta1)) <>
+ Int.signed (Int.add ofs2 (Int.repr delta2)).
+
+Axiom load_inject:
+ forall f m1 m2 chunk b1 ofs b2 delta v1,
+ inject f m1 m2 ->
+ load chunk m1 b1 ofs = Some v1 ->
+ f b1 = Some (b2, delta) ->
+ exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2.
+
+Axiom loadv_inject:
+ forall f m1 m2 chunk a1 a2 v1,
+ inject f m1 m2 ->
+ loadv chunk m1 a1 = Some v1 ->
+ val_inject f a1 a2 ->
+ exists v2, loadv chunk m2 a2 = Some v2 /\ val_inject f v1 v2.
+
+Axiom store_mapped_inject:
+ forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2,
+ inject f m1 m2 ->
+ store chunk m1 b1 ofs v1 = Some n1 ->
+ f b1 = Some (b2, delta) ->
+ val_inject f v1 v2 ->
+ exists n2,
+ store chunk m2 b2 (ofs + delta) v2 = Some n2
+ /\ inject f n1 n2.
+
+Axiom store_unmapped_inject:
+ forall f chunk m1 b1 ofs v1 n1 m2,
+ inject f m1 m2 ->
+ store chunk m1 b1 ofs v1 = Some n1 ->
+ f b1 = None ->
+ inject f n1 m2.
+
+Axiom store_outside_inject:
+ forall f m1 m2 chunk b ofs v m2',
+ inject f m1 m2 ->
+ (forall b' delta,
+ f b' = Some(b, delta) ->
+ high_bound m1 b' + delta <= ofs
+ \/ ofs + size_chunk chunk <= low_bound m1 b' + delta) ->
+ store chunk m2 b ofs v = Some m2' ->
+ inject f m1 m2'.
+
+Axiom storev_mapped_inject:
+ forall f chunk m1 a1 v1 n1 m2 a2 v2,
+ inject f m1 m2 ->
+ storev chunk m1 a1 v1 = Some n1 ->
+ val_inject f a1 a2 ->
+ val_inject f v1 v2 ->
+ exists n2,
+ storev chunk m2 a2 v2 = Some n2 /\ inject f n1 n2.
+
+Axiom alloc_right_inject:
+ forall f m1 m2 lo hi b2 m2',
+ inject f m1 m2 ->
+ alloc m2 lo hi = (m2', b2) ->
+ inject f m1 m2'.
+
+Axiom alloc_left_unmapped_inject:
+ forall f m1 m2 lo hi m1' b1,
+ inject f m1 m2 ->
+ alloc m1 lo hi = (m1', b1) ->
+ exists f',
+ inject f' m1' m2
+ /\ inject_incr f f'
+ /\ f' b1 = None
+ /\ (forall b, b <> b1 -> f' b = f b).
+
+Definition inj_offset_aligned (delta: Z) (size: Z) : Prop :=
+ forall chunk, size_chunk chunk <= size -> (align_chunk chunk | delta).
+
+Axiom alloc_left_mapped_inject:
+ forall f m1 m2 lo hi m1' b1 b2 delta,
+ inject f m1 m2 ->
+ alloc m1 lo hi = (m1', b1) ->
+ valid_block m2 b2 ->
+ Int.min_signed <= delta <= Int.max_signed ->
+ delta = 0 \/ Int.min_signed <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_signed ->
+ (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) ->
+ inj_offset_aligned delta (hi-lo) ->
+ (forall b ofs,
+ f b = Some (b2, ofs) ->
+ high_bound m1 b + ofs <= lo + delta \/
+ hi + delta <= low_bound m1 b + ofs) ->
+ exists f',
+ inject f' m1' m2
+ /\ inject_incr f f'
+ /\ f' b1 = Some(b2, delta)
+ /\ (forall b, b <> b1 -> f' b = f b).
+
+Axiom alloc_parallel_inject:
+ forall f m1 m2 lo1 hi1 m1' b1 lo2 hi2,
+ inject f m1 m2 ->
+ alloc m1 lo1 hi1 = (m1', b1) ->
+ lo2 <= lo1 -> hi1 <= hi2 ->
+ exists f', exists m2', exists b2,
+ alloc m2 lo2 hi2 = (m2', b2)
+ /\ inject f' m1' m2'
+ /\ inject_incr f f'
+ /\ f' b1 = Some(b2, 0)
+ /\ (forall b, b <> b1 -> f' b = f b).
+
+Axiom free_inject:
+ forall f m1 l m1' m2 b lo hi m2',
+ inject f m1 m2 ->
+ free_list m1 l = Some m1' ->
+ free m2 b lo hi = Some m2' ->
+ (forall b1 delta ofs p,
+ f b1 = Some(b, delta) -> perm m1 b1 ofs p -> lo <= ofs + delta < hi ->
+ exists lo1, exists hi1, In (b1, lo1, hi1) l /\ lo1 <= ofs < hi1) ->
+ inject f m1' m2'.
+
+(** Memory states that inject into themselves. *)
+
+Definition flat_inj (thr: block) : meminj :=
+ fun (b: block) => if zlt b thr then Some(b, 0) else None.
+
+Parameter inject_neutral: forall (thr: block) (m: mem), Prop.
+
+Axiom neutral_inject:
+ forall m, inject_neutral (nextblock m) m ->
+ inject (flat_inj (nextblock m)) m m.
+
+Axiom empty_inject_neutral:
+ forall thr, inject_neutral thr empty.
+
+Axiom alloc_inject_neutral:
+ forall thr m lo hi b m',
+ alloc m lo hi = (m', b) ->
+ inject_neutral thr m ->
+ nextblock m < thr ->
+ inject_neutral thr m'.
+
+Axiom store_inject_neutral:
+ forall chunk m b ofs v m' thr,
+ store chunk m b ofs v = Some m' ->
+ inject_neutral thr m ->
+ b < thr ->
+ val_inject (flat_inj thr) v v ->
+ inject_neutral thr m'.
+
+End MEM.
diff --git a/common/Values.v b/common/Values.v
index 19a8077..056cffb 100644
--- a/common/Values.v
+++ b/common/Values.v
@@ -46,6 +46,8 @@ Definition Vmone: val := Vint Int.mone.
Definition Vtrue: val := Vint Int.one.
Definition Vfalse: val := Vint Int.zero.
+(** * Operations over values *)
+
(** The module [Val] defines a number of arithmetic and logical operations
over type [val]. Most of these operations are straightforward extensions
of the corresponding integer or floating-point operations. *)
@@ -984,3 +986,82 @@ Proof.
Qed.
End Val.
+
+(** * Values and memory injections *)
+
+(** A memory injection [f] is a function from addresses to either [None]
+ or [Some] of an address and an offset. It defines a correspondence
+ between the blocks of two memory states [m1] and [m2]:
+- if [f b = None], the block [b] of [m1] has no equivalent in [m2];
+- if [f b = Some(b', ofs)], the block [b] of [m2] corresponds to
+ a sub-block at offset [ofs] of the block [b'] in [m2].
+*)
+
+Definition meminj : Type := block -> option (block * Z).
+
+(** A memory injection defines a relation between values that is the
+ identity relation, except for pointer values which are shifted
+ as prescribed by the memory injection. Moreover, [Vundef] values
+ inject into any other value. *)
+
+Inductive val_inject (mi: meminj): val -> val -> Prop :=
+ | val_inject_int:
+ forall i, val_inject mi (Vint i) (Vint i)
+ | val_inject_float:
+ forall f, val_inject mi (Vfloat f) (Vfloat f)
+ | val_inject_ptr:
+ forall b1 ofs1 b2 ofs2 delta,
+ mi b1 = Some (b2, delta) ->
+ ofs2 = Int.add ofs1 (Int.repr delta) ->
+ val_inject mi (Vptr b1 ofs1) (Vptr b2 ofs2)
+ | val_inject_undef: forall v,
+ val_inject mi Vundef v.
+
+Hint Resolve val_inject_int val_inject_float val_inject_ptr
+ val_inject_undef.
+
+Inductive val_list_inject (mi: meminj): list val -> list val-> Prop:=
+ | val_nil_inject :
+ val_list_inject mi nil nil
+ | val_cons_inject : forall v v' vl vl' ,
+ val_inject mi v v' -> val_list_inject mi vl vl'->
+ val_list_inject mi (v :: vl) (v' :: vl').
+
+Hint Resolve val_nil_inject val_cons_inject.
+
+(** Monotone evolution of a memory injection. *)
+
+Definition inject_incr (f1 f2: meminj) : Prop :=
+ forall b b' delta, f1 b = Some(b', delta) -> f2 b = Some(b', delta).
+
+Lemma inject_incr_refl :
+ forall f , inject_incr f f .
+Proof. unfold inject_incr. auto. Qed.
+
+Lemma inject_incr_trans :
+ forall f1 f2 f3,
+ inject_incr f1 f2 -> inject_incr f2 f3 -> inject_incr f1 f3 .
+Proof .
+ unfold inject_incr; intros. eauto.
+Qed.
+
+Lemma val_inject_incr:
+ forall f1 f2 v v',
+ inject_incr f1 f2 ->
+ val_inject f1 v v' ->
+ val_inject f2 v v'.
+Proof.
+ intros. inv H0; eauto.
+Qed.
+
+Lemma val_list_inject_incr:
+ forall f1 f2 vl vl' ,
+ inject_incr f1 f2 -> val_list_inject f1 vl vl' ->
+ val_list_inject f2 vl vl'.
+Proof.
+ induction vl; intros; inv H0. auto.
+ constructor. eapply val_inject_incr; eauto. auto.
+Qed.
+
+Hint Resolve inject_incr_refl val_inject_incr val_list_inject_incr.
+