Library Globalenvs


Global environments are a component of the dynamic semantics of all languages involved in the compiler. A global environment maps symbol names (names of functions and of global variables) to the corresponding memory addresses. It also maps memory addresses of functions to the corresponding function descriptions.
Global environments, along with the initial memory state at the beginning of program execution, are built from the program of interest, as follows:
  • A distinct memory address is assigned to each function of the program. These function addresses use negative numbers to distinguish them from addresses of memory blocks. The associations of function name to function address and function address to function description are recorded in the global environment.
  • For each global variable, a memory block is allocated and associated to the name of the variable.
    These operations reflect (at a high level of abstraction) what takes place during program linking and program loading in a real operating system.

Require Recdef.
Require Import Zwf.
Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.

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.

Local Open Scope pair_scope.
Local Open Scope error_monad_scope.

Set Implicit Arguments.

Module Genv.

Global environments


Section GENV.

Variable FN: Type. Variable F: Type. Variable V: Type.
The type of global environments.

Record t: Type := mkgenv {
  genv_symb: PTree.t block;
  genv_funs: ZMap.t (option FN);
  genv_vars: ZMap.t (option (globvar V));
  genv_next: block;
  genv_next_pos: genv_next > 0;
  genv_symb_range: forall id b, PTree.get id genv_symb = Some b -> 0 < b < genv_next;
  genv_funs_range: forall b f, ZMap.get b genv_funs = Some f -> 0 < b < genv_next;
  genv_vars_range: forall b v, ZMap.get b genv_vars = Some v -> 0 < b < genv_next;
  genv_funs_vars: forall b1 b2 f v,
    ZMap.get b1 genv_funs = Some f -> ZMap.get b2 genv_vars = Some v -> b1 <> b2;
  genv_vars_inj: forall id1 id2 b,
    PTree.get id1 genv_symb = Some b -> PTree.get id2 genv_symb = Some b -> id1 = id2;
  genv_funs_defs: FN -> F
}.

Lookup functions

find_symbol ge id returns the block associated with the given name, if any

Definition find_symbol (ge: t) (id: ident) : option block :=
  PTree.get id ge.(genv_symb).

find_funct_ptr ge b returns the function description associated with the given address.

Definition find_funct_ptr (ge: t) (b: block) : option FN :=
  (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 FN :=
  match v with
  | Vptr b ofs => if Int.eq_dec ofs Int.zero then find_funct_ptr ge b else None
  | _ => None
  end.

invert_symbol ge b returns the name associated with the given block, if any

Definition invert_symbol (ge: t) (b: block) : option ident :=
  PTree.fold
    (fun res id b' => if eq_block b b' then Some id else res)
    ge.(genv_symb) None.

find_var_info ge b returns the information attached to the variable at address b.

Definition find_var_info (ge: t) (b: block) : option (globvar V) :=
  ZMap.get b ge.(genv_vars).

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 congruence.
  destruct (Int.eq_dec i Int.zero); try congruence.
  intros. exists b; congruence.
Qed.

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 global_addresses_distinct:
  forall ge id1 id2 b1 b2,
  id1 <> id2 ->
  find_symbol ge id1 = Some b1 ->
  find_symbol ge id2 = Some b2 ->
  b1 <> b2.
Proof.
  intros. red; intros; subst. elim H. destruct ge. eauto.
Qed.

Theorem invert_find_symbol:
  forall ge id b,
  invert_symbol ge b = Some id -> find_symbol ge id = Some b.
Proof.
  intros until b; unfold find_symbol, invert_symbol.
  apply PTree_Properties.fold_rec.
  intros. rewrite H in H0; auto.
  congruence.
  intros. destruct (eq_block b v). inv H2. apply PTree.gss.
  rewrite PTree.gsspec. destruct (peq id k).
  subst. assert (m!k = Some b) by auto. congruence.
  auto.
Qed.

Theorem find_invert_symbol:
  forall ge id b,
  find_symbol ge id = Some b -> invert_symbol ge b = Some id.
Proof.
  intros until b.
  assert (find_symbol ge id = Some b -> exists id', invert_symbol ge b = Some id').
  unfold find_symbol, invert_symbol.
  apply PTree_Properties.fold_rec.
  intros. rewrite H in H0; auto.
  rewrite PTree.gempty; congruence.
  intros. destruct (eq_block b v). exists k; auto.
  rewrite PTree.gsspec in H2. destruct (peq id k).
  inv H2. congruence. auto.

  intros; exploit H; eauto. intros [id' A].
  assert (id = id'). eapply genv_vars_inj; eauto. apply invert_find_symbol; auto.
  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_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.

Function store_zeros (m: mem) (b: block) (p: Z) (n: Z) {wf (Zwf 0) n}: option mem :=
  if zle n 0 then Some m else
    let n' := n - 1 in
    match Mem.store Mint8unsigned m b p Vzero with
    | Some m' => store_zeros m' b (p + 1) n'
    | None => None
    end.
Proof.
  intros. red. omega.
  apply Zwf_well_founded.
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_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 perm_globvar (gv: globvar V) : permission :=
  if gv.(gvar_volatile) then Nonempty
  else if gv.(gvar_readonly) then Readable
  else Writable.

Definition alloc_global (m: mem) (idg: ident * globdef F V): option mem :=
  match idg with
  | (id, Gfun f) =>
      let (m1, b) := Mem.alloc m 0 1 in
      Mem.drop_perm m1 b 0 1 Nonempty
  | (id, Gvar v) =>
      let init := v.(gvar_init) in
      let sz := init_data_list_size init in
      let (m1, b) := Mem.alloc m 0 sz in
      match store_zeros m1 b 0 sz with
      | None => None
      | Some m2 =>
          match store_init_data_list m2 b 0 init with
          | None => None
          | Some m3 => Mem.drop_perm m3 b 0 sz (perm_globvar v)
          end
      end
  end.

Fixpoint alloc_globals (m: mem) (gl: list (ident * globdef F V))
                       {struct gl} : option mem :=
  match gl with
  | nil => Some m
  | g :: gl' =>
      match alloc_global m g with
      | None => None
      | Some m' => alloc_globals m' gl'
      end
  end.

Lemma alloc_globals_app : forall gl1 gl2 m m1,
  alloc_globals m gl1 = Some m1 ->
  alloc_globals m1 gl2 = alloc_globals m (gl1 ++ gl2).
Proof.
  induction gl1.
  simpl. intros. inversion H; subst. auto.
  simpl. intros. destruct (alloc_global m a); eauto. inversion H.
Qed.

Next-block properties

Remark store_zeros_nextblock:
  forall m b p n m', store_zeros m b p n = Some m' -> Mem.nextblock m' = Mem.nextblock m.
Proof.
  intros until n. functional induction (store_zeros m b p n); intros.
  inv H; auto.
  rewrite IHo; eauto with mem.
  congruence.
Qed.

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_global_nextblock:
  forall g m m',
  alloc_global m g = Some m' ->
  Mem.nextblock m' = Zsucc(Mem.nextblock m).
Proof.
  unfold alloc_global. intros.
  destruct g as [id [f|v]].
  destruct (Mem.alloc m 0 1) as [m1 b]_eqn.
  erewrite Mem.nextblock_drop; eauto. erewrite Mem.nextblock_alloc; eauto.
  set (init := gvar_init v) in *.
  set (sz := init_data_list_size init) in *.
  destruct (Mem.alloc m 0 sz) as [m1 b]_eqn.
  destruct (store_zeros m1 b 0 sz) as [m2|]_eqn; try discriminate.
  destruct (store_init_data_list m2 b 0 init) as [m3|]_eqn; try discriminate.
  erewrite Mem.nextblock_drop; eauto.
  erewrite store_init_data_list_nextblock; eauto.
  erewrite store_zeros_nextblock; eauto.
  erewrite Mem.nextblock_alloc; eauto.
Qed.

Remark alloc_globals_nextblock:
  forall gl m m',
  alloc_globals m gl = Some m' ->
  Mem.nextblock m' = Mem.nextblock m + Z_of_nat(List.length gl).
Proof.
  induction gl.
  simpl; intros. inv H; unfold block; omega.
  simpl length; rewrite inj_S; simpl; intros.
  destruct (alloc_global m a) as [m1|]_eqn; try discriminate.
  erewrite IHgl; eauto. erewrite alloc_global_nextblock; eauto. unfold block; omega.
Qed.

Permissions

Remark store_zeros_perm:
  forall k prm b' q m b p n m',
  store_zeros m b p n = Some m' ->
  (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm).
Proof.
  intros until n. functional induction (store_zeros m b p n); intros.
  inv H; tauto.
  destruct (IHo _ H); intros. split; eauto with mem.
  congruence.
Qed.

Remark store_init_data_list_perm:
  forall k prm b' q idl b m p m',
  store_init_data_list m b p idl = Some m' ->
  (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm).
Proof.
  induction idl; simpl; intros until m'.
  intros. inv H. tauto.
  caseEq (store_init_data m b p a); try congruence. intros.
  rewrite <- (IHidl _ _ _ _ H0).
  assert (forall chunk v,
          Mem.store chunk m b p v = Some m0 ->
          (Mem.perm m b' q k prm <-> Mem.perm m0 b' q k prm)).
    intros; split; eauto with mem.
  destruct a; simpl in H; eauto.
  inv H; tauto.
  destruct (find_symbol ge i). eauto. discriminate.
Qed.

Remark alloc_global_perm:
  forall k prm b' q idg m m',
  alloc_global m idg = Some m' ->
  Mem.valid_block m b' ->
  (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm).
Proof.
  intros. destruct idg as [id [f|v]]; simpl in H.
  destruct (Mem.alloc m 0 1) as [m1 b]_eqn.
  assert (b' <> b). apply Mem.valid_not_valid_diff with m; eauto with mem.
  split; intros.
  eapply Mem.perm_drop_3; eauto. eapply Mem.perm_alloc_1; eauto.
  eapply Mem.perm_alloc_4; eauto. eapply Mem.perm_drop_4; eauto.
  set (init := gvar_init v) in *.
  set (sz := init_data_list_size init) in *.
  destruct (Mem.alloc m 0 sz) as [m1 b]_eqn.
  destruct (store_zeros m1 b 0 sz) as [m2|]_eqn; try discriminate.
  destruct (store_init_data_list m2 b 0 init) as [m3|]_eqn; try discriminate.
  assert (b' <> b). apply Mem.valid_not_valid_diff with m; eauto with mem.
  split; intros.
  eapply Mem.perm_drop_3; eauto.
  erewrite <- store_init_data_list_perm; [idtac|eauto].
  erewrite <- store_zeros_perm; [idtac|eauto].
  eapply Mem.perm_alloc_1; eauto.
  eapply Mem.perm_alloc_4; eauto.
  erewrite store_zeros_perm; [idtac|eauto].
  erewrite store_init_data_list_perm; [idtac|eauto].
  eapply Mem.perm_drop_4; eauto.
Qed.

Remark alloc_globals_perm:
  forall k prm b' q gl m m',
  alloc_globals m gl = Some m' ->
  Mem.valid_block m b' ->
  (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm).
Proof.
  induction gl.
  simpl; intros. inv H. tauto.
  simpl; intros. destruct (alloc_global m a) as [m1|]_eqn; try discriminate.
  erewrite alloc_global_perm; eauto. eapply IHgl; eauto.
  unfold Mem.valid_block in *. erewrite alloc_global_nextblock; eauto. omega.
Qed.

Data preservation properties

Remark store_zeros_outside:
  forall m b p n m',
  store_zeros m b p n = Some m' ->
  forall chunk b' p',
  b' <> b \/ p' + size_chunk chunk <= p \/ p + n <= p' ->
  Mem.load chunk m' b' p' = Mem.load chunk m b' p'.
Proof.
  intros until n. functional induction (store_zeros m b p n); intros.
  inv H; auto.
  transitivity (Mem.load chunk m' b' p').
  apply IHo. auto. unfold block in *; omega.
  eapply Mem.load_store_other; eauto. simpl. unfold block in *; omega.
  discriminate.
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. destruct (store_init_data m b p a) as [m1|]_eqn; try congruence.
  transitivity (Mem.load chunk m1 b' q).
  eapply IHil; eauto. generalize (init_data_size_pos a). intuition omega.
  destruct a; simpl in Heqo;
  try (eapply Mem.load_store_other; eauto; intuition; fail).
  inv Heqo. auto.
  destruct (find_symbol ge i); try congruence.
  eapply Mem.load_store_other; eauto; intuition.
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_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' ->
    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. destruct (store_init_data m b p a) as [m1|]_eqn; try congruence.
  exploit IHil; eauto. intro D.
  destruct a; simpl in Heqo; intuition.
  eapply (A Mint8unsigned (Vint i)); eauto.
  eapply (A Mint16unsigned (Vint i)); eauto.
  eapply (A Mint32 (Vint i)); eauto.
  destruct (find_symbol ge i); try congruence. exists b0; split; auto.
  eapply (A Mint32 (Vptr b0 i0)); eauto.
Qed.

Remark load_alloc_global:
  forall chunk b p id g m m',
  alloc_global m (id, g) = Some m' ->
  Mem.valid_block m b ->
  Mem.load chunk m' b p = Mem.load chunk m b p.
Proof.
  intros. destruct g as [f|v]; simpl in H.
  destruct (Mem.alloc m 0 1) as [m1 b']_eqn.
  assert (b <> b'). apply Mem.valid_not_valid_diff with m; eauto with mem.
  transitivity (Mem.load chunk m1 b p).
  eapply Mem.load_drop; eauto.
  eapply Mem.load_alloc_unchanged; eauto.
  set (init := gvar_init v) in *.
  set (sz := init_data_list_size init) in *.
  destruct (Mem.alloc m 0 sz) as [m1 b']_eqn.
  destruct (store_zeros m1 b' 0 sz) as [m2|]_eqn; try discriminate.
  destruct (store_init_data_list m2 b' 0 init) as [m3|]_eqn; try discriminate.
  assert (b <> b'). apply Mem.valid_not_valid_diff with m; eauto with mem.
  transitivity (Mem.load chunk m3 b p).
  eapply Mem.load_drop; eauto.
  transitivity (Mem.load chunk m2 b p).
  eapply store_init_data_list_outside; eauto.
  transitivity (Mem.load chunk m1 b p).
  eapply store_zeros_outside; eauto.
  eapply Mem.load_alloc_unchanged; eauto.
Qed.

Remark load_alloc_globals:
  forall chunk b p gl m m',
  alloc_globals m gl = Some m' ->
  Mem.valid_block m b ->
  Mem.load chunk m' b p = Mem.load chunk m b p.
Proof.
  induction gl; simpl; intros.
  congruence.
  destruct (alloc_global m a) as [m''|]_eqn; try discriminate.
  transitivity (Mem.load chunk m'' b p).
  apply IHgl; auto. unfold Mem.valid_block in *.
  erewrite alloc_global_nextblock; eauto. omega.
  destruct a as [id g]. eapply load_alloc_global; 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.

Definition variables_initialized (g: t) (m: mem) :=
  forall b gv,
  find_var_info g b = Some gv ->
  Mem.range_perm m b 0 (init_data_list_size gv.(gvar_init)) Cur (perm_globvar gv)
  /\ (forall ofs k p, Mem.perm m b ofs k p ->
        0 <= ofs < init_data_list_size gv.(gvar_init) /\ perm_order (perm_globvar gv) p)
  /\ (gv.(gvar_volatile) = false -> load_store_init_data m b 0 gv.(gvar_init)).

Definition functions_initialized (g: t) (m: mem) :=
  forall b fd,
  find_funct_ptr g b = Some fd ->
  Mem.perm m b 0 Cur Nonempty
  /\ (forall ofs k p, Mem.perm m b ofs k p -> ofs = 0 /\ perm_order Nonempty p).

End INITMEM.

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_zeros_neutral:
  forall m b p n m',
  Mem.inject_neutral thr m ->
  b < thr ->
  store_zeros m b p n = Some m' ->
  Mem.inject_neutral thr m'.
Proof.
  intros until n. functional induction (store_zeros m b p n); intros.
  inv H1; auto.
  apply IHo; auto. eapply Mem.store_inject_neutral; eauto. constructor.
  inv H1.
Qed.

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.
  destruct id; simpl in H1; try (eapply Mem.store_inject_neutral; eauto; fail).
  congruence.
  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_global_neutral:
  forall idg m m',
  alloc_global ge m idg = Some m' ->
  Mem.inject_neutral thr m ->
  Mem.nextblock m < thr ->
  Mem.inject_neutral thr m'.
Proof.
  intros. destruct idg as [id [f|v]]; simpl in H.
  destruct (Mem.alloc m 0 1) as [m1 b]_eqn.
  assert (b < thr). rewrite (Mem.alloc_result _ _ _ _ _ Heqp). auto.
  eapply Mem.drop_inject_neutral; eauto.
  eapply Mem.alloc_inject_neutral; eauto.
  set (init := gvar_init v) in *.
  set (sz := init_data_list_size init) in *.
  destruct (Mem.alloc m 0 sz) as [m1 b]_eqn.
  destruct (store_zeros m1 b 0 sz) as [m2|]_eqn; try discriminate.
  destruct (store_init_data_list ge m2 b 0 init) as [m3|]_eqn; try discriminate.
  assert (b < thr). rewrite (Mem.alloc_result _ _ _ _ _ Heqp). auto.
  eapply Mem.drop_inject_neutral; eauto.
  eapply store_init_data_list_neutral with (m := m2) (b := b); eauto.
  eapply store_zeros_neutral with (m := m1); eauto.
  eapply Mem.alloc_inject_neutral; eauto.
Qed.

Lemma alloc_globals_neutral:
  forall gl m m',
  alloc_globals ge m gl = Some m' ->
  Mem.inject_neutral thr m ->
  Mem.nextblock m' <= thr ->
  Mem.inject_neutral thr m'.
Proof.
  induction gl; simpl.
  intros. congruence.
  intros until m'. caseEq (alloc_global ge m a); try congruence. intros.
  assert (Mem.nextblock m' = Mem.nextblock m + Z_of_nat(length (a :: gl))).
  eapply alloc_globals_nextblock with ge. simpl. rewrite H. auto.
  simpl length in H3. rewrite inj_S in H3.
  exploit alloc_global_neutral; eauto. unfold block in *; omega.
Qed.

End INITMEM_INJ.

Section INITMEM_AUGMENT_INJ.

Variable ge: t.
Variable thr: block.

Lemma store_zeros_augment:
  forall m1 m2 b p n m2',
  Mem.inject (Mem.flat_inj thr) m1 m2 ->
  b >= thr ->
  store_zeros m2 b p n = Some m2' ->
  Mem.inject (Mem.flat_inj thr) m1 m2'.
Proof.
  intros until n. functional induction (store_zeros m2 b p n); intros.
  inv H1; auto.
  apply IHo; auto. exploit Mem.store_outside_inject; eauto. simpl.
  intros. exfalso. unfold Mem.flat_inj in H2. destruct (zlt b' thr).
    inversion H2; subst; omega.
    discriminate.
  inv H1.
Qed.

Lemma store_init_data_augment:
  forall m1 m2 b p id m2',
  Mem.inject (Mem.flat_inj thr) m1 m2 ->
  b >= thr ->
  store_init_data ge m2 b p id = Some m2' ->
  Mem.inject (Mem.flat_inj thr) m1 m2'.
Proof.
  intros until m2'. intros INJ BND ST.
  assert (P: forall chunk ofs v m2',
             Mem.store chunk m2 b ofs v = Some m2' ->
             Mem.inject (Mem.flat_inj thr) m1 m2').
    intros. eapply Mem.store_outside_inject; eauto.
    intros. unfold Mem.flat_inj in H0.
    destruct (zlt b' thr); inversion H0; subst. omega.
  destruct id; simpl in ST; try (eapply P; eauto; fail).
  congruence.
  revert ST. caseEq (find_symbol ge i); try congruence. intros; eapply P; eauto.
Qed.

Lemma store_init_data_list_augment:
  forall b idl m1 m2 p m2',
  Mem.inject (Mem.flat_inj thr) m1 m2 ->
  b >= thr ->
  store_init_data_list ge m2 b p idl = Some m2' ->
  Mem.inject (Mem.flat_inj thr) m1 m2'.
Proof.
  induction idl; simpl.
  intros; congruence.
  intros until m2'; intros INJ FB.
  caseEq (store_init_data ge m2 b p a); try congruence. intros.
  eapply IHidl. eapply store_init_data_augment; eauto. auto. eauto.
Qed.

Lemma alloc_global_augment:
  forall idg m1 m2 m2',
  alloc_global ge m2 idg = Some m2' ->
  Mem.inject (Mem.flat_inj thr) m1 m2 ->
  Mem.nextblock m2 >= thr ->
  Mem.inject (Mem.flat_inj thr) m1 m2'.
Proof.
  intros. destruct idg as [id [f|v]]; simpl in H.
  destruct (Mem.alloc m2 0 1) as [m3 b]_eqn.
  assert (b >= thr). rewrite (Mem.alloc_result _ _ _ _ _ Heqp). auto.
  eapply Mem.drop_outside_inject. 2: eauto.
  eapply Mem.alloc_right_inject; eauto.
  intros. unfold Mem.flat_inj in H3. destruct (zlt b' thr); inversion H3.
     subst; exfalso; omega.
  set (init := gvar_init v) in *.
  set (sz := init_data_list_size init) in *.
  destruct (Mem.alloc m2 0 sz) as [m3 b]_eqn.
  destruct (store_zeros m3 b 0 sz) as [m4|]_eqn; try discriminate.
  destruct (store_init_data_list ge m4 b 0 init) as [m5|]_eqn; try discriminate.
  assert (b >= thr). rewrite (Mem.alloc_result _ _ _ _ _ Heqp). auto.
  eapply Mem.drop_outside_inject. 2: eauto.
  eapply store_init_data_list_augment. 3: eauto. 2: eauto.
  eapply store_zeros_augment. 3: eauto. 2: eauto.
  eapply Mem.alloc_right_inject; eauto.
  intros. unfold Mem.flat_inj in H3. destruct (zlt b' thr); inversion H3.
     subst; exfalso; omega.
Qed.

Lemma alloc_globals_augment:
  forall gl m1 m2 m2',
  alloc_globals ge m2 gl = Some m2' ->
  Mem.inject (Mem.flat_inj thr) m1 m2 ->
  Mem.nextblock m2 >= thr ->
  Mem.inject (Mem.flat_inj thr) m1 m2'.
Proof.
  induction gl; simpl.
  intros. congruence.
  intros until m2'. caseEq (alloc_global ge m2 a); try congruence. intros.
  eapply IHgl with (m2 := m); eauto.
    eapply alloc_global_augment; eauto.
    rewrite (alloc_global_nextblock _ _ _ H).
    unfold block in *; omega.
Qed.

End INITMEM_AUGMENT_INJ.

End GENV.

Commutation with program transformations

Commutation with matching between programs.


Section MATCH_PROGRAMS.

Variables FN A B V W: Type.
Variable match_fun: A -> B -> Prop.
Variable match_varinfo: V -> W -> Prop.

Inductive match_globvar: globvar V -> globvar W -> Prop :=
  | match_globvar_intro: forall info1 info2 init ro vo,
      match_varinfo info1 info2 ->
      match_globvar (mkglobvar info1 init ro vo) (mkglobvar info2 init ro vo).

Record match_genvs (new_globs : list (ident * globdef FN W))
                   (ge1: t FN A V) (ge2: t FN B W): Prop := {
  mge_next:
    genv_next ge2 = genv_next ge1 + Z_of_nat(length new_globs);
  mge_symb:
    forall id, ~ In id (map (@fst _ _) new_globs) ->
                   PTree.get id (genv_symb ge2) = PTree.get id (genv_symb ge1);
  mge_funs:
    forall b f, ZMap.get b (genv_funs ge1) = Some f ->
      ZMap.get b (genv_funs ge2) = Some f;
                     mge_funs_true:
                       forall f, match_fun (genv_funs_defs ge1 f) (genv_funs_defs ge2 f);
  mge_rev_funs:
    forall b tf, ZMap.get b (genv_funs ge2) = Some tf ->
    if zlt b (genv_next ge1) then
      ZMap.get b (genv_funs ge1) = Some tf
    else
      In (Gfun tf) (map (@snd _ _) new_globs);
  mge_vars:
    forall b v, ZMap.get b (genv_vars ge1) = Some v ->
    exists tv, ZMap.get b (genv_vars ge2) = Some tv /\ match_globvar v tv;
  mge_rev_vars:
    forall b tv, ZMap.get b (genv_vars ge2) = Some tv ->
    if zlt b (genv_next ge1) then
      exists v, ZMap.get b (genv_vars ge1) = Some v /\ match_globvar v tv
    else
      In (Gvar tv) (map (@snd _ _) new_globs)
}.

End MATCH_PROGRAMS.

Section Replace_fundefs.

Variable FN: Type. Variable V: Type.
Section RF.

Variables F1 F2: Type.
Variable new_fundefs: FN -> F2.

Program Definition replace_fundefs (g: t FN F1 V) : t FN F2 V :=
  mkgenv (genv_symb g) (genv_funs g) (genv_vars g) (genv_next_pos g)
 _ _ _ _ _ new_fundefs.
Next Obligation.
  eauto using genv_symb_range.
Qed.
Next Obligation.
  eauto using genv_funs_range.
Qed.
Next Obligation.
  eauto using genv_vars_range.
Qed.
Next Obligation.
  eauto using genv_funs_vars.
Qed.
Next Obligation.
  eauto using genv_vars_inj.
Qed.

End RF.

Lemma replace_fundefs_id : forall (F: Type) (g : _ _ F _),
  replace_fundefs (genv_funs_defs g) g = g.
Proof.
  unfold replace_fundefs.
  destruct g.
  simpl.
  f_equal; eauto using Axioms.proof_irr.
Qed.

Lemma replace_fundefs_idem : forall (F1 F2 F3: Type) (g: _ _ F1 _) (f2: _ -> F2) (f3: _ -> F3),
  replace_fundefs f3 (replace_fundefs f2 g) = replace_fundefs f3 g.
Proof.
  unfold replace_fundefs; destruct g; simpl; intros; f_equal; eauto using Axioms.proof_irr.
Qed.

Lemma replace_fundefs_exists_forall : forall (F1 F2 F: Type) (g1: _ _ F1 _) (g2: _ _ F2 _) (f: _ -> F),
  replace_fundefs f g1 = replace_fundefs f g2 ->
  forall (F': Type) (f': _ -> F'),
    replace_fundefs f' g1 = replace_fundefs f' g2.
Proof.
  intros.
  rewrite <- (replace_fundefs_idem g1 f _).
  rewrite <- (replace_fundefs_idem g2 f _).
  rewrite H.
  reflexivity.
Qed.

End Replace_fundefs.

End Genv.