(******************************************************************************)
(* PipeCheck: Specifying and Verifying Microarchitectural                     *)
(* Enforcement of Memory Consistency Models                                   *)
(*                                                                            *)
(* Copyright (c) 2014 Daniel Lustig, Princeton University                     *)
(* All rights reserved.                                                       *)
(*                                                                            *)
(* This library is free software; you can redistribute it and/or              *)
(* modify it under the terms of the GNU Lesser General Public                 *)
(* License as published by the Free Software Foundation; either               *)
(* version 2.1 of the License, or (at your option) any later version.         *)
(*                                                                            *)
(* This library is distributed in the hope that it will be useful,            *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU          *)
(* Lesser General Public License for more details.                            *)
(*                                                                            *)
(* You should have received a copy of the GNU Lesser General Public           *)
(* License along with this library; if not, write to the Free Software        *)
(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  *)
(* USA                                                                        *)
(******************************************************************************)

Require Import List.
Import ListNotations.
Require Import Arith.
Require Import Ascii.
Require Import String.
Require Import wmm.
Require Import util2.
Require Import tree.
Require Import stages.

Open Scope string_scope.

(** [geid] is a helper function that assigns to each [GlobalEvent] a unique
  identifier in the global ordering graph. *)
Definition geid
  (p : Pipeline)
  (ge : GlobalEvent)
  : nat :=
  let (n, e) := ge in
  e * (List.length (stages p)) + n.

(** [gepid] applies [geid] to each value in a pair of [GlobalEvent]s. *)
Definition gepid
  (p : Pipeline)
  (gep : GlobalEvent * GlobalEvent * string)
  : (nat * nat * string) :=
  let (ge1, ge2) := fst gep in
  (geid p ge1, geid p ge2, snd gep).

(** [getid] applies [gepid] to each value in a [GraphTree] of [GlobalEvent]s. *)
Fixpoint getid
  (p : Pipeline)
  (t : GraphTree GlobalEvent)
  : GraphTree nat :=
  match t with
  | GraphTreeOr     l => GraphTreeOr   _   (map (getid p) l)
  | GraphTreeAnd    l => GraphTreeAnd  _   (map (getid p) l)
  | GraphTreeLeaf n l => GraphTreeLeaf _ n (map (gepid p) l)
  end.

(** [ungeid'] is a helper function for [ungeid] that performs division
  slowly. *)
Fixpoint ungeid'
 (p : Pipeline)
 (n s e : nat)
 : (location * program_order_index) :=
  match (n, nat_compare s (List.length (stages p))) with
  | (0   , Lt) => (s, e)
  | (0   , Eq) => (0, S e)
  | (S n', Lt) => ungeid' p n' (S s) e
  | (S n', Eq) => ungeid' p n' 1 (S e)
  | (_   , Gt) => (0, 0) (* ERROR *)
  end.

(** [ungeid] is the opposite of [geid]: it converts a global ordering vertex
  identifier and returns the corresponding [location] and [Event].  It is used
  to print human-readable information about the vertex. *)
Definition ungeid
  (p : Pipeline)
  (n : nat)
  : location * program_order_index :=
  ungeid' p n 0 0.

Definition GlobalEventString
  (p : Pipeline)
  (ge : GlobalEvent)
  : string :=
  let (n, e) := ge in
  match (nth_error (stages p) n, n - List.length (stages p)) with
  | (Some s, _) =>
    append "Event"
    (append (String (ascii_of_nat (nat_of_ascii "0" + e)) "")
     (append "at"
      (name s)))
  | (None, 0) =>
    fold_left append ["CacheLine"; stringOfNat e; "Create"] ""
  | (None, 1) =>
    fold_left append ["CacheLine"; stringOfNat e; "Invalidate"] ""
  | _ => "Unknown"
  end.

Fixpoint GraphString
  (g : list (nat * nat * string))
  : string :=
  match g with
  | h::t =>
    let (s, d) := fst h in
    fold_left append [stringOfNat s; " --"; (snd h); "-> "; stringOfNat d;
      newline]
      (GraphString t)
  | [] => ""
  end.

Fixpoint GlobalGraphString
  (g : list (GlobalEvent * GlobalEvent * string))
  : string :=
  match g with
  | h::t =>
    let (s, d) := fst h in
    fold_left append ["("; stringOfNat (fst s); ", "; stringOfNat (snd s);
      ") --"; (snd h); "-> ("; stringOfNat (fst d); ", "; stringOfNat (snd d);
      ")"; newline]
      (GlobalGraphString t)
  | [] => ""
  end.

Module GraphStringExample.

Definition ExampleGraph := [(0, 1, "a"); (0, 2, "b")].

Example e1 : GraphString ExampleGraph = "0 --b-> 2
0 --a-> 1
".
Proof.
auto.
Qed.

Definition ExampleGlobalGraph := [((0, 0), (0, 1), "a"); ((0, 0), (1, 0), "b")].

Example e2 : GlobalGraphString ExampleGlobalGraph = "(0, 0) --b-> (1, 0)
(0, 0) --a-> (0, 1)
".
Proof.
auto.
Qed.

End GraphStringExample.


From RecordUpdate Require Import RecordSet.
From aneris.aneris_lang Require Import network resources.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.examples.reliable_communication.prelude Require Import ser_inj.

Definition Key := string.

(** Arguments that user supplies to the interface *)

Class DB_params := {
  DB_addr :  socket_address;
  DB_addrF :  socket_address;
  DB_followers : gset socket_address;
  DB_keys : gset Key;
  DB_InvName : namespace;
  DB_serialization : serialization;
  DB_ser_inj : ser_is_injective DB_serialization;
  DB_ser_inj_alt : ser_is_injective_alt DB_serialization;
}.

Notation DB_Serializable v := (Serializable DB_serialization v).

Record SerializableVal `{!DB_params} :=
  SerVal {SV_val : val;
          SV_ser : DB_Serializable SV_val }.

Coercion SV_val : SerializableVal >-> val.

Existing Instance SV_ser.

Arguments SerVal {_} _ {_}.

Definition socket_address_to_str (sa : socket_address) : string :=
    match sa with SocketAddressInet ip p => ip +:+ (string_of_pos p) end.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*           Layers of PM: Refinement Proof for PShareIntro           *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MPTNew layer and PShareIntro layer*)
Require Export ShareIntroGenDef.
Require Export ShareIntroGenFresh.
Require Export ShareIntroGenPassthrough.


(*========================================================================*)
(*                                                                        *)
(*                    CompcertTSO                                         *)
(*                                                                        *)
(*          Jaroslav Sevcik, University of Cambridge                      *)
(*          Viktor Vafeiadis, University of Cambridge                     *)
(*          Francesco Zappa Nardelli, INRIA Rocquencourt                  *)
(*          Suresh Jagannathan, Purdue University                         *)
(*          Peter Sewell, University of Cambridge                         *)
(*                                                                        *)
(*          (building on CompCert 1.5 and a 1.8 pre-release)              *)
(*                                                                        *)
(*  This document and the CompCertTSO sources are copyright 2005, 2006,   *)
(*  2007, 2008, 2009, 2010, 2011 Institut National de Recherche en        *)
(*  Informatique et en Automatique (INRIA), and Suresh Jagannathan,       *)
(*  Jaroslav Sevcik, Peter Sewell and Viktor Vafeiadis.                   *)
(*                                                                        *)
(*  All rights reserved.  This file is distributed under the terms of     *)
(*  the INRIA Non-Commercial License Agreement.                           *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*========================================================================*)

(** Equivalence relations on memories. *)

Require Import Coqlib.
Require Import Specif.
Require Import Maps.
Require Import Ast.
Require Import Pointers.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Mem.
Require Import Libtactics.
Require Import Permutation.
(* Require Import TSOmachine. *)

(*============================================================================*)
(** * Quotienting on range lists *)

Lemma range_lists_disjoint_ext:
  forall {l1 l1' l2 l2'}
    (EQ1: list_equiv l1 l1')
    (EQ2: list_equiv l2 l2')
    (DISJ: range_lists_disjoint l1 l2),
    range_lists_disjoint l1' l2'.
Proof.
  unfold range_lists_disjoint, range_not_in; intros.
  by apply DISJ; [apply (proj2 (EQ1 _)) | apply (proj2 (EQ2 _))].
Qed.

(*============================================================================*)
(** * Load equality on memories *)

Lemma load_eq_preserved_by_store:
  forall {c m mx p c' p' v' m' mx'}
    (Leq: load_ptr c m p = load_ptr c mx p)
    (ST: store_ptr c' m  p' v' = Some m')
    (STx: store_ptr c' mx p' v' = Some mx'),
  load_ptr c m' p = load_ptr c mx' p.
Proof.
  intros.
  pose proof (load_chunk_allocated_spec c m p) as LDAL.
  pose proof (load_chunk_allocated_spec c mx p) as LDALX.
  pose proof (load_chunk_allocated_spec c m' p) as LDAL'.
  pose proof (load_chunk_allocated_spec c mx' p) as LDALX'.
  destruct (load_ptr c m p) as [v|] _eqn : SMLD.
    (* Load SUCCESS *)
    destruct (range_eq_dec (range_of_chunk p' c') (range_of_chunk p c))
      as [RCeq | RCneq].
      (* Reading exactly the memory written by the unbuffered store *)
      injection RCeq.
      intro SCeqm.
      assert (SCeq: size_chunk c' = size_chunk c).
      destruct c; destruct c'; simpl in *; compute in SCeqm; done.
      intro Peq; subst.
      by rewrite (load_store_similar ST SCeq), (load_store_similar STx SCeq).
    (* Reading from different memory; two cases: *)
    destruct (ranges_disjoint_dec (range_of_chunk p' c')
                                         (range_of_chunk p c))
        as [RDISJ | ROVER].
      (* Ranges completely disjoint *)
      rewrite <- (load_store_other ST RDISJ), SMLD.
      by rewrite <- (load_store_other STx RDISJ).
      (* Ranges overlap *)
      apply (store_preserves_chunk_allocation ST _ _) in LDAL.
      rewrite (load_store_overlap ST ROVER RCneq LDAL).
      destruct (load_ptr c mx p) as [v''|] _eqn : SMLD'.
      apply (store_preserves_chunk_allocation STx p c) in LDALX.
      rewrite (load_store_overlap STx ROVER RCneq LDALX).
      done.
      by destruct (load_ptr c mx' p);
        [apply (store_preserves_chunk_allocation STx _ _) in LDALX'|].
    (* Load FAIL *)
    apply sym_eq in Leq. rewrite Leq in LDALX.
    destruct (load_ptr c m' p) as [cmv|] _eqn : E2;
      destruct (load_ptr c mx' p) as [cmv'|] _eqn : E3;
        try apply (store_preserves_chunk_allocation STx _ _) in LDALX';
          try apply (store_preserves_chunk_allocation ST _ _) in LDAL';
            try done.
Qed.

Lemma load_eq_preserved_by_alloc:
  forall {c m mx p r' k' m' mx'}
    (Leq: load_ptr c m p = load_ptr c mx p)
    (AP: alloc_ptr r' k' m = Some m')
    (APx: alloc_ptr r' k' mx = Some mx'),
  load_ptr c m' p = load_ptr c mx' p.
Proof.
  intros; destruct r' as [p' n'].
  pose proof (load_chunk_allocated_spec c m p) as LDAL.
  pose proof (load_chunk_allocated_spec c mx p) as LDALX.
  pose proof (load_chunk_allocated_spec c m' p) as LDAL'.
  pose proof (load_chunk_allocated_spec c mx' p) as LDALX'.
  destruct (pointer_chunk_aligned_dec p c) as [CA | CNA].
    2: destruct (load_ptr c m' p); destruct (load_ptr c mx' p);
      try done; destruct LDAL'; destruct LDALX'; done.
  destruct (range_inside_dec (range_of_chunk p c) (p', n')) as [RI | RNI].
    (* loads inside the newly allocated region *)
    rewrite (load_alloc_inside AP); try done;
      rewrite (load_alloc_inside APx); done.
  destruct (ranges_disjoint_dec (range_of_chunk p c)
                                       (p', n')) as [DISJ | OVER].
    (* loads outside *)
    rewrite (load_alloc_other AP); try done;
      rewrite (load_alloc_other APx); done.
  (* loads overlap *)
  destruct (alloc_someD AP) as [APA _].
  destruct (alloc_someD APx) as [APA' _].
  destruct (load_ptr c m' p).
    destruct LDAL' as [[r [k [RI RA]]] _].
    destruct (ranges_are_disjoint RA APA) as [[-> ->] | DISJ]; try done.
    eby elim OVER; eapply disjoint_inside_disjoint.
  destruct (load_ptr c mx' p); try done.
  destruct LDALX' as [[r [k [RI RA]]] _].
  destruct (ranges_are_disjoint RA APA') as [[-> ->] | DISJ]; try done.
  eby elim OVER; eapply disjoint_inside_disjoint.
Qed.

Lemma load_eq_preserved_by_free_same_size:
  forall {c m mx p p' n' k' m' mx'}
    (Leq: load_ptr c m p = load_ptr c mx p)
    (RA: range_allocated (p', n') k' m)
    (FP: free_ptr p' k' m = Some m')
    (RAx: range_allocated (p', n') k' mx)
    (FPx: free_ptr p' k' mx = Some mx'),
  load_ptr c m' p = load_ptr c mx' p.
Proof.
  intros.
  destruct (ranges_disjoint_dec (range_of_chunk p c)
                                       (p', n')) as [DISJ | OVER].
    by rewrite (load_free_other FP RA DISJ),
               (load_free_other FPx RAx DISJ).
  by rewrite (load_free_overlap FP RA OVER),
             (load_free_overlap FPx RAx OVER).
Qed.

Lemma load_eq_preserved_by_free_diff_block:
  forall {c m mx p p' k' m' mx'}
    (Leq: load_ptr c m p = load_ptr c mx p)
    (DB: MPtr.block p <> MPtr.block p')
    (FP: free_ptr p' k' m = Some m')
    (FPx: free_ptr p' k' mx = Some mx'),
  load_ptr c m' p = load_ptr c mx' p.
Proof.
  intros.
  destruct (free_someD FP) as [n RA].
  destruct (free_someD FPx) as [nx RAx].
  rewrite (load_free_other FP RA);
    [|by destruct p; destruct p'; simpl in *; left].
  by rewrite (load_free_other FPx RAx);
    [|by destruct p; destruct p'; simpl in *; left].
Qed.

(*============================================================================*)
(** * Equality on allocated ranges *)

(** The allocation ranges are equal *)
Definition arange_eq (Cond: _ -> bool) m1 m2 :=
    (forall r k (COND: Cond k), range_allocated r k m1 <-> range_allocated r k m2)
 /\ (mrestr m1 = mrestr m2).

Lemma arange_eq_sub:
  forall {m1 m2} C D,
    arange_eq C m1 m2 ->
    (forall k, D k = true -> C k) ->
    arange_eq D m1 m2.
Proof. by destruct 1; split; auto. Qed.

Lemma arange_eq_refl:
 forall C m, arange_eq C m m.
Proof. done. Qed.

Lemma arange_eq_sym:
  forall {C m1 m2}, arange_eq C m1 m2 -> arange_eq C m2 m1.
Proof. by destruct 1 as [A R]; repeat split; try done; by eapply A. Qed.

Lemma arange_eq_trans:
  forall C x y z,
    arange_eq C x y ->
    arange_eq C y z ->
    arange_eq C x z.
Proof.
  intros C x y z (X & ?) (Y & ?); split; [intros r k|congruence].
  specialize (X r k); specialize (Y r k); tauto.
Qed.

Lemma arange_eq_store:
  forall {m m' chunk p v} C,
    store_ptr chunk m p v = Some m' ->
    arange_eq C m' m.
Proof.
  intros m m' chunk p v STO.
  split; [split|].
      eby apply <- @store_preserves_allocated_ranges.
    eby apply -> @store_preserves_allocated_ranges.
  eby eapply restr_of_store.
Qed.

Lemma range_in_allocated_arange:
  forall {m1 m2 r}
    (EQ: arange_eq (fun _ => true) m1 m2)
    (RA: range_in_allocated r m1),
    range_in_allocated r m2.
Proof.
  intros; destruct RA as (? & ? & ? & ?).
  eby do 2 eexists; split; [|eapply (proj1 EQ)].
Qed.

Lemma chunk_allocated_and_aligned_arange:
  forall {m1 m2 chunk p}
    (EQ: arange_eq (fun _ => true) m1 m2)
    (CA: chunk_allocated_and_aligned p chunk m1),
    chunk_allocated_and_aligned p chunk m2.
Proof.
  intros; destruct CA as [? ?]; split; try done.
  eby eapply range_in_allocated_arange.
Qed.

Lemma range_list_of_mem_arange:
  forall {m1 m2}
    (EQ: arange_eq (fun _ => true) m1 m2),
  list_equiv (range_list_of_mem m1) (range_list_of_mem m2).
Proof.
  intros; intro x.
  eapply iff_trans; [apply range_list_of_mem_alloc|].
  eapply iff_trans; [|apply iff_sym; apply range_list_of_mem_alloc].
  split; intros [k RA]; exists k; pose proof (proj1 EQ x k (refl_equal _)); tauto.
Qed.

Lemma load_ptr_none_arange:
  forall {m1 m2 chunk p}
    (LD: load_ptr chunk m1 p = None)
    (EQ: arange_eq (fun _ => true) m1 m2),
    load_ptr chunk m2 p = None.
Proof.
  intros.
  assert (X1 := load_chunk_allocated_spec chunk m1 p).
  assert (X2 := load_chunk_allocated_spec chunk m2 p).
  do 2 destruct load_ptr; try done.
  eby elim X1; eapply chunk_allocated_and_aligned_arange; try apply @arange_eq_sym.
Qed.

Lemma load_ptr_some_arange:
  forall m1 m2 chunk p v1
    (H1: load_ptr chunk m1 p = Some v1)
    (EQ: arange_eq (fun _ => true) m1 m2),
  exists v2, load_ptr chunk m2 p = Some v2.
Proof.
  intros.
  assert (X1 := load_chunk_allocated_spec chunk m1 p).
  assert (X2 := load_chunk_allocated_spec chunk m2 p).
  do 2 destruct load_ptr; vauto.
  eby elim X2; eapply chunk_allocated_and_aligned_arange.
Qed.

Lemma store_ptr_none_arange:
  forall {m1 m2 chunk p v} v'
    (STO: store_ptr chunk m1 p v = None)
    (EQ: arange_eq (fun _ => true) m1 m2),
    store_ptr chunk m2 p v' = None.
Proof.
  intros.
  assert (X1 := store_chunk_allocated_spec chunk m1 p v).
  assert (X2 := store_chunk_allocated_spec chunk m2 p v').
  do 2 destruct store_ptr; try done.
  eby elim X1; eapply chunk_allocated_and_aligned_arange; try apply @arange_eq_sym.
Qed.

Lemma store_ptr_some_arange1:
  forall C m1 m2 chunk p v v' m1' m2'
    (STO1: store_ptr chunk m1 p v = Some m1')
    (STO2: store_ptr chunk m2 p v' = Some m2')
    (REQ: arange_eq C m1 m2),
    arange_eq C m1' m2'.
Proof.
  intros; destruct REQ as [RA ?].
  split.
    intros.
    pose proof (store_preserves_allocated_ranges STO1 r k).
    pose proof (store_preserves_allocated_ranges STO2 r k).
    specialize (RA r k).
    tauto.
  by rewrite (restr_of_store STO1), (restr_of_store STO2).
Qed.

Lemma store_ptr_some_arange:
  forall m1 m2 chunk p v v' m1'
    (H1: store_ptr chunk m1 p v = Some m1')
    (EQ: arange_eq (fun _ => true) m1 m2),
  exists m2', store_ptr chunk m2 p v' = Some m2' /\ arange_eq (fun _ => true) m1' m2'.
Proof.
  intros; destruct (store_ptr chunk m2 p v') as [m2'|] _eqn: H2;
    [|by rewrite (store_ptr_none_arange _ H2 (arange_eq_sym EQ)) in H1].
  exists m2'; split; try done.
  eby eapply store_ptr_some_arange1.
Qed.

Lemma alloc_ptr_none_arange:
  forall m1 m2 r k,
    alloc_ptr r k m1 = None ->
    arange_eq (fun _ => true) m1 m2 ->
    alloc_ptr r k m2 = None.
Proof.
  intros m1 m2 r k H EQ.
  pose proof (alloc_cond_spec r k m1) as A1; destruct (alloc_ptr r k m1); try done.
  pose proof (alloc_cond_spec r k m2) as A2; destruct (alloc_ptr r k m2); try done.
  destruct A2 as [RA [? [? AL]]].
  destruct A1 as [|[|[[? ?] [? [? RA']]]]]; try done.
    destruct (fst r) as [b ofs]; simpl in *.
    by rewrite (proj2 EQ) in *.
  exploit AL; try edone.
  eby eapply (proj1 ((proj1 EQ) _ _ (refl_equal _))).
Qed.

Lemma alloc_ptr_some_arange1:
  forall C m1 m2 r k m1' m2',
    alloc_ptr r k m1 = Some m1' ->
    alloc_ptr r k m2 = Some m2' ->
    arange_eq C m1 m2 ->
    arange_eq C m1' m2'.
Proof.
  intros C m1 m2 r k m1' m2' H1 H2 [RA ?]; split.
    intros r0 k0.
    pose proof (RA r0 k0) as EQ'.
    pose proof (alloc_preserves_allocated_iff H1 r0 k0) as A1.
    pose proof (alloc_preserves_allocated_iff H2 r0 k0) as A2.
    tauto.
  by rewrite (restr_of_alloc H1), (restr_of_alloc H2).
Qed.

Lemma alloc_ptr_some_arange:
  forall m1 m2 r k m1',
    alloc_ptr r k m1 = Some m1' ->
    arange_eq (fun _ => true) m1 m2 ->
    (exists m2', alloc_ptr r k m2 = Some m2' /\ arange_eq (fun _ => true) m1' m2').
Proof.
  intros m1 m2 r k m1' H1 EQ.
  destruct (alloc_ptr r k m2) as [m2'|] _eqn: H2;
    [|by rewrite (alloc_ptr_none_arange _ _ _ _ H2 (arange_eq_sym EQ)) in H1].
  exists m2'; split; try done.
  eby eapply alloc_ptr_some_arange1.
Qed.

Lemma free_ptr_none_arange:
  forall C m1 m2 p k,
    free_ptr p k m1 = None ->
    arange_eq C m1 m2 ->
    C k ->
    free_ptr p k m2 = None.
Proof.
  intros C m1 m2 p k H [EQ ?] CC.
  pose proof (free_noneD H) as A1.
  pose proof (free_cond_spec p k m2) as A2; destruct (free_ptr p k m2); try done.
  destruct A2 as [n ?].
  by elim (A1 n); apply (proj2 (EQ _ _ CC)).
Qed.

Lemma free_ptr_some_arange1:
  forall C m1 m2 p k m1' m2',
    free_ptr p k m1 = Some m1' ->
    free_ptr p k m2 = Some m2' ->
    arange_eq C m1 m2 ->
    arange_eq C m1' m2'.
Proof.
  intros C m1 m2 p k m1' m2' H1 H2 [RA ?].
  split.
    split; intro H3.
      pose proof (free_preserves_allocated_back H1 _ _ H3) as X.
      apply (proj1 (RA r k0 COND)) in X.
      destruct (free_preserves_allocated H2 _ _ X) as [|[]]; clarify.
      eby destruct r; eapply free_not_allocated in H1; elim H1.
    pose proof (free_preserves_allocated_back H2 _ _ H3) as X.
    apply (proj2 (RA r k0 COND)) in X.
    destruct (free_preserves_allocated H1 _ _ X) as [|[]]; clarify.
    eby destruct r; eapply free_not_allocated in H2; elim H2.
  by rewrite (restr_of_free H1), (restr_of_free H2).
Qed.

Lemma free_ptr_some_arange:
  forall C m1 m2 p k m1',
    free_ptr p k m1 = Some m1' ->
    arange_eq C m1 m2 ->
    C k ->
    (exists m2', free_ptr p k m2 = Some m2' /\ arange_eq C m1' m2').
Proof.
  intros C m1 m2 p k m1' H1 EQ CC.
  destruct (free_ptr p k m2) as [m2'|] _eqn: H2;
    [|by rewrite (free_ptr_none_arange _ _ _ _ _ H2 (arange_eq_sym EQ)) in H1].
  exists m2'; split; try done.
  eby eapply free_ptr_some_arange1.
Qed.

Lemma load_eq_preserved_by_free_arange:
  forall {c m mx p p' k' m' mx'}
    (Leq: load_ptr c m p = load_ptr c mx p)
    (FP: free_ptr p' k' m = Some m')
    (FPx: free_ptr p' k' mx = Some mx')
    (Req: arange_eq (fun _ => true) m mx),
  load_ptr c m' p = load_ptr c mx' p.
Proof.
  intros.
  pose proof (free_someD FP) as [n RA].
  pose proof (proj1 (proj1 Req _ _ (refl_equal _)) RA).
  eby eapply load_eq_preserved_by_free_same_size.
Qed.

(*============================================================================*)
(** * Less definedness on memories *)

Definition opt_lessdef vo vo' :=
  match vo, vo' with
    | Some v, Some v' => Val.lessdef v v'
    | None, _ => True
    | _, _ => False
  end.

Definition mem_lessdef (m m': mem) :=
  forall p c, opt_lessdef (load_ptr c m p) (load_ptr c m' p).

Definition mem_lessdef_in_range (m m': mem) (r: arange) :=
  forall p c,
    range_inside (range_of_chunk p c) r ->
    opt_lessdef (load_ptr c m p) (load_ptr c m' p).

Lemma opt_lessdef_refl:
  forall v, opt_lessdef v v.
Proof. by intros [[]|]; vauto. Qed.

Hint Resolve opt_lessdef_refl.

Lemma mem_lessdef_refl:
  forall m, mem_lessdef m m.
Proof. by intros m p c; destruct load_ptr. Qed.

Hint Resolve mem_lessdef_refl.

Lemma opt_lessdef_sim_write:
  forall tm sm tm' sm' p c v v' p' c'
    (LDrel: opt_lessdef (load_ptr c' sm p') (load_ptr c' tm p'))
    (tSTO: store_ptr c tm p v = Some tm')
    (sSTO: store_ptr c sm p v' = Some sm')
    (vLDEF: Val.lessdef v' v),
    opt_lessdef (load_ptr c' sm' p') (load_ptr c' tm' p').
Proof.
  intros.
  pose proof (load_chunk_allocated_spec c' tm p') as Ct.
  pose proof (load_chunk_allocated_spec c' tm' p') as Ct'.
  pose proof (load_chunk_allocated_spec c' sm p') as Cs.
  pose proof (load_chunk_allocated_spec c' sm' p') as Cs'.

     destruct (load_ptr c' tm p') as [v1|] _eqn: tLD;
     destruct (load_ptr c' sm p') as [v2|] _eqn: sLD; clarify;
     destruct (load_ptr c' tm' p') as [] _eqn: tLD';
     destruct (load_ptr c' sm' p') as [] _eqn: sLD'; clarify;
     try apply (store_preserves_chunk_allocation tSTO _ _) in Ct;
     try apply (store_preserves_chunk_allocation tSTO _ _) in Ct';
     try apply (store_preserves_chunk_allocation sSTO _ _) in Cs;
     try apply (store_preserves_chunk_allocation sSTO _ _) in Cs'; simpl in *; clarify.

    destruct (range_eq_dec (range_of_chunk p c) (range_of_chunk p' c'))
      as [RCeq | RCneq].
      (* Reading exactly the memory written by the unbuffered store *)
      injection RCeq.
      intro SCeqm.
      assert (SCeq: size_chunk c = size_chunk c').
      destruct c; destruct c'; simpl in *; compute in SCeqm; done.
      intro Peq; subst.
      rewrite (load_store_similar tSTO SCeq), (load_store_similar sSTO SCeq) in *; vauto.
      by destruct compatible_chunks; auto using Val.load_result_lessdef.

    (* Reading from different memory; two cases: *)
    destruct (ranges_disjoint_dec (range_of_chunk p c)
                                         (range_of_chunk p' c'))
        as [RDISJ | ROVER].
      (* Ranges completely disjoint *)
     by rewrite <- (load_store_other tSTO RDISJ), <- (load_store_other sSTO RDISJ) in *; clarify'.

      (* Ranges overlap *)
     by  rewrite (load_store_overlap tSTO ROVER RCneq Ct),
              (load_store_overlap sSTO ROVER RCneq Cs) in *; vauto.
Qed.

Lemma opt_lessdef_sim_alloc:
  forall tm sm tm' sm' p n k p' c'
    (LREL: opt_lessdef (load_ptr c' sm p') (load_ptr c' tm p'))
    (ACT: alloc_ptr (p, n) k tm = Some tm')
    (ACS: alloc_ptr (p, n) k sm = Some sm'),
    opt_lessdef (load_ptr c' sm' p') (load_ptr c' tm' p').
Proof.
  intros.
  destruct (ranges_disjoint_dec (range_of_chunk p' c') (p, n))
    as [DISJ | OVER].
    by rewrite (load_alloc_other ACT), (load_alloc_other ACS).
  destruct (range_inside_dec (range_of_chunk p' c') (p, n))
    as [RI | NRI].
    destruct (pointer_chunk_aligned_dec p' c') as [ALG | NALG].
      by rewrite (load_alloc_inside ACT), (load_alloc_inside ACS); vauto.
    assert (LDT := load_chunk_allocated_spec c' tm' p').
    assert (LDS := load_chunk_allocated_spec c' sm' p').
    destruct (load_ptr c' tm' p'); [by case NALG; destruct LDT|].
    by destruct (load_ptr c' sm' p'); [by case NALG; destruct LDS|].
  by rewrite (load_alloc_overlap ACT), (load_alloc_overlap ACS).
Qed.

Lemma opt_lessdef_sim_free_same_size:
  forall tm sm tm' sm' p k n p' c'
    (LREL: opt_lessdef (load_ptr c' sm p') (load_ptr c' tm p'))
    (Ft: free_ptr p k tm = Some tm')
    (Fs: free_ptr p k sm = Some sm')
    (RAt: range_allocated (p, n) k tm)
    (RAs: range_allocated (p, n) k sm),
    opt_lessdef (load_ptr c' sm' p') (load_ptr c' tm' p').
Proof.
  intros.
  destruct (ranges_disjoint_dec (range_of_chunk p' c') (p, n))
    as [DISJ | OVER].
    by rewrite (load_free_other Ft RAt DISJ);
       rewrite (load_free_other Fs RAs DISJ).
  by rewrite (load_free_overlap Ft RAt OVER);
     rewrite (load_free_overlap Fs RAs OVER).
Qed.

Lemma mem_lessdef_sim_write:
  forall tm sm tm' sm' c p v v'
    (LREL: mem_lessdef sm tm)
    (tSTO: store_ptr c tm p v = Some tm')
    (sSTO: store_ptr c sm p v' = Some sm')
    (vLDEF: Val.lessdef v' v),
    mem_lessdef sm' tm'.
Proof.
  intros; intros p' c'; specialize (LREL p' c').
  eby eapply opt_lessdef_sim_write.
Qed.

Lemma mem_lessdef_sim_alloc:
  forall tm sm tm' sm' p n k
    (LREL: mem_lessdef sm tm)
    (ACT: alloc_ptr (p, n) k tm = Some tm')
    (ACS: alloc_ptr (p, n) k sm = Some sm'),
    mem_lessdef sm' tm'.
Proof.
  intros; intros p' c'; specialize (LREL p' c').
  eby eapply opt_lessdef_sim_alloc.
Qed.

Lemma mem_lessdef_sim_free_same_size:
  forall tm sm tm' sm' p n k
    (LREL: mem_lessdef sm tm)
    (Ft: free_ptr p k tm = Some tm')
    (Fs: free_ptr p k sm = Some sm')
    (RAt: range_allocated (p, n) k tm)
    (RAs: range_allocated (p, n) k sm),
    mem_lessdef sm' tm'.
Proof.
  intros; intros p' c'; specialize (LREL p' c').
  eby eapply opt_lessdef_sim_free_same_size.
Qed.

Lemma mem_lessdef_alloc_src:
  forall tm sm sm' p n k
    (LREL: mem_lessdef sm tm)
    (RA: range_in_allocated (p, n) tm)
    (ACS: alloc_ptr (p, n) k sm = Some sm'),
    mem_lessdef sm' tm.
Proof.
  intros; intros p' c'; specialize (LREL p' c').
  destruct RA as (r' & k' & IN & RA).
  destruct (ranges_disjoint_dec (range_of_chunk p' c') (p, n))
    as [DISJ | OVER].
    by rewrite (load_alloc_other ACS).
  destruct (range_inside_dec (range_of_chunk p' c') (p, n))
    as [RI | NRI].
    destruct (pointer_chunk_aligned_dec p' c') as [ALG | NALG].
      rewrite (load_alloc_inside ACS); try done.
      assert (CA:= load_chunk_allocated_spec c' tm p').
      destruct (load_ptr c' tm p'); vauto.
      case CA; split; try done; exists r'; exists k'; split; try done.
      eby eapply range_inside_trans.
    assert (LDS := load_chunk_allocated_spec c' sm' p').
    by destruct (load_ptr c' sm' p'); [by case NALG; destruct LDS|destruct load_ptr].
  by rewrite (load_alloc_overlap ACS); destruct load_ptr.
Qed.

Lemma mem_lessdef_free_src:
  forall tm sm sm' p k
    (LREL: mem_lessdef sm tm)
    (F: free_ptr p k sm = Some sm'),
    mem_lessdef sm' tm.
Proof.
  intros; intros p' c'; specialize (LREL p' c').
  pose proof (free_someD F) as [n RA].
  destruct (ranges_disjoint_dec (range_of_chunk p' c') (p, n))
    as [DISJ | OVER].
    eby erewrite (load_free_other F).
  erewrite (load_free_overlap F); try eassumption.
  by destruct (load_ptr c' sm p').
Qed.

Lemma mem_lessdef_clear_src:
  forall tm sm r
    (LREL: mem_lessdef sm tm),
    mem_lessdef (clear_range r sm) tm.
Proof.
  intros; intros p' c'; specialize (LREL p' c').
  destruct (load_ptr c' (clear_range r sm) p') as [] _eqn: LD.
  destruct (load_clear_back LD) as (? & LD' & LDEF); rewrite LD' in *.
    destruct (load_ptr c' tm p'); simpl in *; clarify.
    by inv LREL; clarify; inv LDEF; clarify.
  by eapply load_clear_none in LD; rewrite LD in *.
Qed.

(*============================================================================*)
(** * Partial load equality *)

Definition mem_agrees_on (m m' : mem) (rs : list arange) : Prop :=
  forall r p c,
    In r rs ->
    range_inside (range_of_chunk p c) r ->
    load_ptr c m p = load_ptr c m' p.

Lemma mem_agrees_on_sym:
  forall {m m' rs} (H: mem_agrees_on m m' rs),
  mem_agrees_on m' m rs.
Proof.
  eby unfold mem_agrees_on; intros; symmetry; eapply H.
Qed.

Lemma mem_agrees_on_trans:
  forall {x y z rs}
    (X: mem_agrees_on x y rs)
    (Y: mem_agrees_on y z rs),
  mem_agrees_on x z rs.
Proof.
  intros; intros r p c IN RI;
  specialize (X _ _ _ IN RI);
  specialize (Y _ _ _ IN RI); congruence.
Qed.

Lemma mem_agrees_on_app:
  forall {m m' s1 s2},
    mem_agrees_on m m' (s1 ++ s2) <->
    mem_agrees_on m m' s1 /\ mem_agrees_on m m' s2.
Proof.
  split; [by intros MA; split; intros r p c IN; apply MA; auto using in_or_app|].
  intros [MA1 MA2]; intros r p c IN. apply -> in_app in IN; destruct IN;
    [by apply MA1 | by apply MA2].
Qed.

Lemma mem_agrees_on_perm:
  forall {m m' l l'}
    (P: Permutation l l')
    (MA: mem_agrees_on m m' l),
    mem_agrees_on m m' l'.
Proof.
  intros; intros r p c IN; apply MA.
  eby eapply Permutation_in; try apply Permutation_sym.
Qed.

Lemma mem_agrees_on_list_equiv:
  forall {m m' l l'}
    (EQ: list_equiv l l')
    (MA: mem_agrees_on m m' l),
    mem_agrees_on m m' l'.
Proof.
  by intros; intros r p c IN; eapply MA, EQ.
Qed.

Lemma mem_agrees_on_preserved_by_store:
  forall {m mx l c p v m' mx'}
    (EQ: mem_agrees_on m mx l)
    (ST: store_ptr c m p v = Some m')
    (STx: store_ptr c mx p v = Some mx'),
  mem_agrees_on m' mx' l.
Proof.
  intros; intros r p' c' IN P; specialize (EQ r p' c' IN P).
  eby eapply load_eq_preserved_by_store.
Qed.

Lemma mem_agrees_on_preserved_by_alloc:
  forall {m mx l r k m' mx'}
    (EQ: mem_agrees_on m mx l)
    (A: alloc_ptr r k m = Some m')
    (Ax: alloc_ptr r k mx = Some mx'),
  mem_agrees_on m' mx' l.
Proof.
  intros; intros r' p' c' IN P; specialize (EQ r' p' c' IN P).
  eby eapply load_eq_preserved_by_alloc.
Qed.

Lemma mem_agrees_on_preserved_by_free_same_size:
  forall {m mx l p n k m' mx'}
    (EQ: mem_agrees_on m mx l)
    (RA: range_allocated (p, n) k m)
    (F: free_ptr p k m = Some m')
    (RAx: range_allocated (p, n) k mx)
    (Fx: free_ptr p k mx = Some mx'),
  mem_agrees_on m' mx' l.
Proof.
  intros; intros r' p' c' IN P; specialize (EQ r' p' c' IN P).
  eby eapply load_eq_preserved_by_free_same_size.
Qed.

Lemma mem_agrees_on_preserved_by_free_arange:
  forall {m mx l p k m' mx'}
    (EQ: mem_agrees_on m mx l)
    (REQ: arange_eq (fun _ => true) m mx)
    (F: free_ptr p k m = Some m')
    (Fx: free_ptr p k mx = Some mx'),
  mem_agrees_on m' mx' l.
Proof.
  intros; intros r' p' c' IN P; specialize (EQ r' p' c' IN P).
  eby eapply load_eq_preserved_by_free_arange.
Qed.

(*============================================================================*)
(** * Extensional equality on memories *)

Definition mem_eq m1 m2:=
   (forall chunk p, load_ptr chunk m1 p = load_ptr chunk m2 p)
/\ (forall r k, range_allocated r k m1 <-> range_allocated r k m2)
/\ (mrestr m1 = mrestr m2).

Lemma in_block1:
  forall lbnd hbnd l h k ba,
  alloclist_hbound lbnd (mkmobj l h k :: ba) = Some hbnd -> 0 < lbnd -> hbnd <= Int.modulus ->
  valid_access Mint8unsigned (l mod Int.modulus) (mkmobj l h k :: ba).
Proof.
  intros.
  constructor 1 with (k:=k); [|by apply Zone_divide].
  exists l; exists h.
  split; [by left|].
  exploit (@alloclist_hbound_impl_l_lt_h); [eassumption|by left|intro].
  rewrite Zmod_small; simpl; omega.
Qed.

Lemma alloclist1:
  forall lbnd hbnd l h k a,
  alloclist_hbound lbnd (mkmobj l h k :: a) = Some hbnd ->
  lbnd <= l /\ l < h /\ h <= hbnd /\ (align_size (h - l) | l).
Proof.
  intros lbnd hbnd l h k a H.
  by destruct (alloclist_hbound_impl_l_lt_h H (in_eq _ _)) as (? & ? & ? & ?).
Qed.

Lemma range_allocated_al_cons:
  forall l h k l' h' k' ba',
  range_allocated_al l h k (mkmobj l' h' k' :: ba') ->
  l = l' /\ h = h' /\ k = k' \/ range_allocated_al l h k ba'.
Proof.
  unfold range_allocated_al.
  by inversion 1; clarify; [left|right].
Qed.

Lemma valid_access_bounded:
  forall c ofs al lbnd hbnd,
   alloclist_hbound lbnd al = Some hbnd ->
   valid_access c ofs al ->
   lbnd <= ofs < hbnd.
Proof.
  intros until 0; intros H [k [l [h [RA ?]]] AL].
  eapply @alloclist_hbound_impl_l_lt_h in H; try edone.
  destruct c; simpl in *; omega.
Qed.

Lemma Zabs_nat_of_nat: forall n, Zabs_nat (Z_of_nat n) = n.
Proof.
  by destruct n; simpl; auto using nat_of_P_o_P_of_succ_nat_eq_succ.
Qed.

Lemma contents_eq_ext:
  forall bc bc' ba,
    block_valid (mkblock bc ba) ->
    block_valid (mkblock bc' ba) ->
    (forall c ofs,
      valid_access c ofs ba ->
      Val.load_result c (getN (pred_size_chunk c) (ofs mod Int.modulus) bc)
      = Val.load_result c (getN (pred_size_chunk c) (ofs mod Int.modulus) bc')) ->
  bc = bc'.
Proof.
  intros bc bc' ba (UU & OK & hbnd & B & M) (UU' & OK' & hbnd' & B' & M') LD.
  apply ZTree.ext; intros ofs.
  destruct (ZTree.get ofs bc) as [[]|] _eqn: G.

  Case "Datum".
    pose proof (proj1 (proj2 OK _ _ _ G)) as [c [SZ [VOK ACCOK]]].
    generalize (LD c ofs ACCOK).
    assert (ofsRNG: 0 <= ofs < Int.modulus)
      by (pose proof (valid_access_bounded _ _ _ _ _ B ACCOK); omega).
    rewrite Zmod_small; try done.
    destruct ACCOK as [k ? ?]; simpl in *.

    unfold getN.
    rewrite G, SZ, dec_eq_true, value_chunk_ok1; try done.
    destruct (ZTree.get ofs bc') as [[]|] _eqn: G'; try done; try destruct eq_nat_dec;
    try rewrite load_result_undef; intro X; clarify; try by revert VOK; clear; destruct c.

    pose proof (proj1 (proj2 OK' _ _ _ G')) as [c' [SZ' [VOK' ACCOK']]].
    rewrite value_chunk_ok1; try done.
    by revert VOK VOK' SZ'; clear; destruct c'; destruct c; destruct v0.

  Case "Cont".
    pose proof (proj1 OK _ _ G) as (l & v & Gm).
    pose proof (proj1 (proj2 OK _ _ _ Gm)) as [c [SZ [VOK ACCOK]]].
    generalize (LD _ _ ACCOK).
    assert (ofsRNG: 0 <= ofs - Z_of_nat n < Int.modulus)
      by (pose proof (valid_access_bounded _ _ _ _ _ B ACCOK); omega).
    rewrite Zmod_small; try done.
    destruct ACCOK as [k ? ?]; simpl in *.
    unfold getN.
    rewrite Gm, SZ, dec_eq_true, value_chunk_ok1; try done.
    destruct (ZTree.get (ofs - Z_of_nat n) bc') as [[]|] _eqn: G'; try done; try destruct eq_nat_dec;
    try rewrite load_result_undef; intro X; clarify; try by revert VOK; clear; destruct c.
    destruct n.
      by simpl in *; rewrite Zminus_0_r in *; rewrite G in Gm.

    pose proof (proj1 (proj2 OK' _ _ _ G')) as [c' [SZ' [VOK' ACCOK']]].
    exploit (check_cont_inside _ _ _ _ ofs (proj2 (proj2 OK' _ _ _ G')));
      unfold contents; rewrite inj_S.
    omega.
    intros ->; f_equal; f_equal.
    replace (ofs - (ofs - Zsucc (Z_of_nat n) + 1)) with (Z_of_nat n); [rewrite Zabs_nat_of_nat|]; omega.

  Case "None".
    destruct (ZTree.get ofs bc') as [[]|] _eqn: G'; try done.

    SCase "Datum".
      pose proof (proj1 (proj2 OK' _ _ _ G')) as [c [SZ [VOK ACCOK]]].
      generalize (LD c ofs ACCOK).
      assert (ofsRNG: 0 <= ofs < Int.modulus)
        by (pose proof (valid_access_bounded _ _ _ _ _ B ACCOK); omega).
      rewrite Zmod_small; try done.
      destruct ACCOK as [k ? ?]; simpl in *.
      unfold getN.
      rewrite G, G', SZ, dec_eq_true, load_result_undef, value_chunk_ok1; try done.
      by revert VOK; clear; destruct c; destruct v.

    SCase "Cont".
      pose proof (proj1 OK' _ _ G') as (l & v & Gm').
      pose proof (proj1 (proj2 OK' _ _ _ Gm')) as [c [SZ [VOK ACCOK]]].
      generalize (LD _ _ ACCOK).
      assert (ofsRNG: 0 <= ofs - Z_of_nat n < Int.modulus)
        by (pose proof (valid_access_bounded _ _ _ _ _ B ACCOK); omega).
      rewrite Zmod_small; try done.
      destruct ACCOK as [k ? ?]; simpl in *.
      unfold getN.
      rewrite Gm', SZ, dec_eq_true.
      destruct (ZTree.get (ofs - Z_of_nat n) bc) as [[]|] _eqn: Gm; try done; try destruct eq_nat_dec;
      try rewrite load_result_undef; try (by revert VOK; destruct c; destruct v).
      intro X; clarify.
      destruct n.
        by simpl in *; rewrite Zminus_0_r in *; rewrite G in Gm.

      pose proof (proj1 (proj2 OK _ _ _ Gm)) as [c' [SZ' [VOK' ACCOK']]].
      exploit (check_cont_inside _ _ _ _ ofs (proj2 (proj2 OK _ _ _ Gm)));
        unfold contents; rewrite inj_S.
      omega.
      by rewrite G.
Qed.

Lemma range_allocated_implies_allocs_eq:
  forall m m' b bc bc',
  (forall (r : arange) (k : mobject_kind), range_allocated r k m  <-> range_allocated r k m') ->
  ZTree.get b (mcont m) = Some bc ->
  ZTree.get b (mcont m') = Some bc' ->
  allocs bc = allocs bc'.
Proof.
  intros [mc mr mv] [mc' mr' mv'] b [bc ba] [bc' ba'] RA EQ EQ'; simpl in *.
  pose proof (proj2 (proj2 (proj1 (proj2 (proj2 mv _ _ EQ))))) as [hbnd [B M]].
  pose proof (proj2 (proj2 (proj1 (proj2 (proj2 mv' _ _ EQ'))))) as [hbnd' [B' M']].
  unfold range_allocated in *; simpl in *.

    assert (Y: forall ofs s k,
           range_allocated_al (Int.unsigned ofs)
              (Int.unsigned ofs + Int.unsigned s) k ba <->
            range_allocated_al (Int.unsigned ofs)
              (Int.unsigned ofs + Int.unsigned s) k ba').
      by intros; generalize (RA (Ptr b ofs, s) k); simpl; rewrite EQ, EQ'.
    clear RA; revert Y.
    simpl in *.
    clear EQ' EQ.
    revert B B' M'; cut (1 > 0); [|omega]; generalize 1 as lbnd; revert ba' hbnd'.

    induction ba as [|[l h k] ba IH]; destruct ba' as [|[l' h' k'] ba']; try done; intros hbnd' lbnd POS B B' M' Y.
    (*1*)
      exploit (proj2 (Y (Int.repr l') (Int.repr (h' - l')) k')); try done.
      apply alloclist1 in B'.
      left; simpl; f_equal; rewrite ?Zmod_small; omega.
    (*2*)
      exploit (proj1 (Y (Int.repr l) (Int.repr (h - l)) k)); try done.
      apply alloclist1 in B.
      left; simpl; f_equal; rewrite ?Zmod_small; omega.
    (* Main case *)
    assert (l = l' /\ h = h' /\ k = k') as [-> [-> ->]].
      pose proof (alloclist1 _ _ _ _ _ _ B).
      pose proof (alloclist1 _ _ _ _ _ _ B').
      exploit (proj1 (Y (Int.repr l) (Int.repr (h - l)) k)); simpl;
        rewrite ?Zmod_small, Zplus_minus; try omega; [by left|].
      exploit (proj2 (Y (Int.repr l') (Int.repr (h' - l')) k')); simpl;
        rewrite ?Zmod_small, Zplus_minus; try omega; [by left|].
      intros X' X.
      apply range_allocated_al_cons in X; destruct X as [X|X]; try done.
      apply range_allocated_al_cons in X'; destruct X' as [[-> [-> ->]]|X']; try done.
      simpl in B; destruct aligned_rng_dec; try done; destruct Z_le_dec; try done.
      simpl in B'; destruct aligned_rng_dec; try done; destruct Z_le_dec; try done.
      pose proof (alloclist_hbound_impl_l_lt_h B' X).
      pose proof (alloclist_hbound_impl_l_lt_h B X').
      omegaContradiction.
    f_equal.
    simpl in B, B'; destruct aligned_rng_dec; clarify; destruct Z_le_dec; clarify.
    apply IH with (hbnd' := hbnd') (lbnd := h'); try done.
      omega.
    intros ofs s k.
    split; intro IN.
      destruct (proj1 (Y ofs s k) (or_intror _ IN)) as [|]; clarify.
      pose proof (alloclist_hbound_impl_l_lt_h B IN).
      omegaContradiction.
    destruct (proj2 (Y ofs s k) (or_intror _ IN)) as [|]; clarify.
    pose proof (alloclist_hbound_impl_l_lt_h B' IN).
    omegaContradiction.
Qed.

Lemma mem_eq_ext:
  forall m1 m2, mem_eq m1 m2 -> m1 = m2.
Proof.
  intros [mc mr mv] [mc' mr' mv'] [LD [RA MR]]; simpl in *; subst mr'.
  cut (mc = mc'); [by intro; subst mc'; rewrite (proof_irrelevance _ mv mv')|].
  apply ZTree.ext; intros b.
  destruct (ZTree.get b mc) as [[bc ba]|] _eqn: EQ;
  destruct (ZTree.get b mc') as [[bc' ba']|] _eqn: EQ'; try done.

  Case "SomeSome".
  generalize (range_allocated_implies_allocs_eq _ _ _ _ _ RA EQ EQ'); simpl; intros <-.
  f_equal; f_equal.
  pose proof (proj1 (proj2 (proj2 mv _ _ EQ))) as V.
  pose proof (proj1 (proj2 (proj2 mv' _ _ EQ'))) as V'.
  apply (contents_eq_ext _ _ _ V V'); intros c ofs VA.
  generalize (LD c (Ptr b (Int.repr ofs))).
  simpl; unfold load; simpl; rewrite EQ, EQ'; simpl.
  rewrite Zmod_small, !in_block_true; try done.
    by intro; clarify.
  by destruct V as (? & ? & ? & B & ?);
     pose proof (valid_access_bounded _ _ _ _ _ B VA); omega.

  Case "SomeNone".
  case mv; intros _ V.
  pose proof (proj2 (V _ _ EQ)) as [[V1 [_ [hbnd [? ?]]]] M].
  destruct ba as [|[l h k] ?].
    assert (bc = ZTree.empty _); [|by elim M; subst].
    apply ZTree.ext; intro x; rewrite ZTree.gempty; apply V1; simpl.
    by intros k [? [? [RA' _]]]; inversion RA'.
  generalize (LD Mint8unsigned (Ptr b (Int.repr l))); unfold load_ptr, load;
  simpl; rewrite EQ, EQ'; simpl.
  eby rewrite in_block_empty, in_block_true; [|eapply in_block1].

  Case "NoneSome".
  case mv'; intros _ V.
  pose proof (proj2 (V _ _ EQ')) as [[V1 [_ [hbnd [? ?]]]] M].
  destruct ba' as [|[l h k] ?].
    assert (bc' = ZTree.empty _); [|by elim M; subst].
    apply ZTree.ext; intro x; rewrite ZTree.gempty; apply V1; simpl.
    by intros k [? [? [RA' _]]]; inversion RA'.
  generalize (LD Mint8unsigned (Ptr b (Int.repr l))); unfold load_ptr, load;
  simpl; rewrite EQ, EQ'; simpl.
  eby rewrite in_block_empty, in_block_true; [|eapply in_block1].
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.
Require map.Occ.
Require map.MapPermut.
Require map.MapInjection.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Inductive array (a:Type) :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (array a) :=
  (mk_array n (map.Map.const v: (map.Map.map Z a))).

(* Why3 assumption *)
Definition is_common_prefix (a:(array Z)) (x:Z) (y:Z) (l:Z): Prop :=
  (0%Z <= l)%Z /\ (((x + l)%Z <= (length a))%Z /\
  (((y + l)%Z <= (length a))%Z /\ forall (i:Z), ((0%Z <= i)%Z /\
  (i < l)%Z) -> ((get a (x + i)%Z) = (get a (y + i)%Z)))).

Axiom not_common_prefix_if_last_char_are_different : forall (a:(array Z))
  (x:Z) (y:Z) (l:Z), ((0%Z <= l)%Z /\ (((x + l)%Z < (length a))%Z /\
  (((y + l)%Z < (length a))%Z /\ ~ ((get a (x + l)%Z) = (get a
  (y + l)%Z))))) -> ~ (is_common_prefix a x y (l + 1%Z)%Z).

(* Why3 assumption *)
Definition is_longest_common_prefix (a:(array Z)) (x:Z) (y:Z) (l:Z): Prop :=
  (is_common_prefix a x y l) /\ forall (m:Z), (l < m)%Z ->
  ~ (is_common_prefix a x y m).

Axiom longest_common_prefix_succ : forall (a:(array Z)) (x:Z) (y:Z) (l:Z),
  ((is_common_prefix a x y l) /\ ~ (is_common_prefix a x y (l + 1%Z)%Z)) ->
  (is_longest_common_prefix a x y l).

(* Why3 assumption *)
Inductive ref (a:Type) :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Definition lt (a:(array Z)) (x:Z) (y:Z): Prop := let n := (length a) in
  (((0%Z <= x)%Z /\ (x <= n)%Z) /\ (((0%Z <= y)%Z /\ (y <= n)%Z) /\
  exists l:Z, (is_common_prefix a x y l) /\ (((y + l)%Z < n)%Z /\
  (((x + l)%Z = n) \/ ((get a (x + l)%Z) < (get a (y + l)%Z))%Z)))).

(* Why3 assumption *)
Definition range (a:(array Z)): Prop := (map.MapInjection.range (elts a)
  (length a)).

(* Why3 assumption *)
Definition map_eq_sub {a:Type} {a_WT:WhyType a} (a1:(map.Map.map Z a))
  (a2:(map.Map.map Z a)) (l:Z) (u:Z): Prop := forall (i:Z), ((l <= i)%Z /\
  (i < u)%Z) -> ((map.Map.get a1 i) = (map.Map.get a2 i)).

(* Why3 assumption *)
Definition array_eq_sub {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array
  a)) (l:Z) (u:Z): Prop := ((length a1) = (length a2)) /\ (((0%Z <= l)%Z /\
  (l <= (length a1))%Z) /\ (((0%Z <= u)%Z /\ (u <= (length a1))%Z) /\
  (map_eq_sub (elts a1) (elts a2) l u))).

(* Why3 assumption *)
Definition array_eq {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array
  a)): Prop := ((length a1) = (length a2)) /\ (map_eq_sub (elts a1) (elts a2)
  0%Z (length a1)).

(* Why3 assumption *)
Definition exchange {a:Type} {a_WT:WhyType a} (a1:(map.Map.map Z a))
  (a2:(map.Map.map Z a)) (l:Z) (u:Z) (i:Z) (j:Z): Prop := ((l <= i)%Z /\
  (i < u)%Z) /\ (((l <= j)%Z /\ (j < u)%Z) /\ (((map.Map.get a1
  i) = (map.Map.get a2 j)) /\ (((map.Map.get a1 j) = (map.Map.get a2 i)) /\
  forall (k:Z), ((l <= k)%Z /\ (k < u)%Z) -> ((~ (k = i)) -> ((~ (k = j)) ->
  ((map.Map.get a1 k) = (map.Map.get a2 k))))))).

Axiom exchange_set : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(map.Map.map Z a)) (l:Z) (u:Z) (i:Z) (j:Z), ((l <= i)%Z /\
  (i < u)%Z) -> (((l <= j)%Z /\ (j < u)%Z) -> (exchange a1
  (map.Map.set (map.Map.set a1 i (map.Map.get a1 j)) j (map.Map.get a1 i)) l
  u i j)).

(* Why3 assumption *)
Definition exchange1 {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array a))
  (i:Z) (j:Z): Prop := ((length a1) = (length a2)) /\ (exchange (elts a1)
  (elts a2) 0%Z (length a1) i j).

(* Why3 assumption *)
Definition permut {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array a))
  (l:Z) (u:Z): Prop := ((length a1) = (length a2)) /\ (((0%Z <= l)%Z /\
  (l <= (length a1))%Z) /\ (((0%Z <= u)%Z /\ (u <= (length a1))%Z) /\
  (map.MapPermut.permut (elts a1) (elts a2) l u))).

(* Why3 assumption *)
Definition permut_sub {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array a))
  (l:Z) (u:Z): Prop := (map_eq_sub (elts a1) (elts a2) 0%Z l) /\ ((permut a1
  a2 l u) /\ (map_eq_sub (elts a1) (elts a2) u (length a1))).

(* Why3 assumption *)
Definition permut_all {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array
  a)): Prop := ((length a1) = (length a2)) /\ (map.MapPermut.permut (elts a1)
  (elts a2) 0%Z (length a1)).

Axiom exchange_permut_sub : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (i:Z) (j:Z) (l:Z) (u:Z), (exchange1 a1
  a2 i j) -> (((l <= i)%Z /\ (i < u)%Z) -> (((l <= j)%Z /\ (j < u)%Z) ->
  ((0%Z <= l)%Z -> ((u <= (length a1))%Z -> (permut_sub a1 a2 l u))))).

Axiom permut_sub_weakening : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (l1:Z) (u1:Z) (l2:Z) (u2:Z),
  (permut_sub a1 a2 l1 u1) -> (((0%Z <= l2)%Z /\ (l2 <= l1)%Z) ->
  (((u1 <= u2)%Z /\ (u2 <= (length a1))%Z) -> (permut_sub a1 a2 l2 u2))).

Axiom exchange_permut_all : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (i:Z) (j:Z), (exchange1 a1 a2 i j) ->
  (permut_all a1 a2).

(* Why3 assumption *)
Definition le (a:(array Z)) (x:Z) (y:Z): Prop := (x = y) \/ (lt a x y).

Axiom lcp_same_index : forall (a:(array Z)) (x:Z), ((0%Z <= x)%Z /\
  (x <= (length a))%Z) -> (is_longest_common_prefix a x x
  ((length a) - x)%Z).

Axiom le_trans : forall (a:(array Z)) (x:Z) (y:Z) (z:Z), ((le a x y) /\ (le a
  y z)) -> (le a x z).

(* Why3 assumption *)
Definition sorted_sub (a:(array Z)) (data:(map.Map.map Z Z)) (l:Z)
  (u:Z): Prop := forall (i1:Z) (i2:Z), ((l <= i1)%Z /\ ((i1 <= i2)%Z /\
  (i2 < u)%Z)) -> (le a (map.Map.get data i1) (map.Map.get data i2)).

(* Why3 assumption *)
Definition sorted (a:(array Z)) (data:(array Z)): Prop := (sorted_sub a
  (elts data) 0%Z (length data)).

(* Why3 assumption *)
Definition permutation (m:(map.Map.map Z Z)) (u:Z): Prop :=
  (map.MapInjection.range m u) /\ (map.MapInjection.injective m u).

(* Why3 assumption *)
Inductive suffixArray :=
  | mk_suffixArray : (array Z) -> (array Z) -> suffixArray.
Axiom suffixArray_WhyType : WhyType suffixArray.
Existing Instance suffixArray_WhyType.

(* Why3 assumption *)
Definition suffixes (v:suffixArray): (array Z) :=
  match v with
  | (mk_suffixArray x x1) => x1
  end.

(* Why3 assumption *)
Definition values (v:suffixArray): (array Z) :=
  match v with
  | (mk_suffixArray x x1) => x
  end.

(* Why3 goal *)
Theorem permut_permutation : forall (a1:(array Z)) (a2:(array Z)),
  ((permut_all a1 a2) /\ (permutation (elts a1) (length a1))) -> (permutation
  (elts a2) (length a2)).
(* Why3 intros a1 a2 (h1,h2). *)
intros (n, m1) (n2, m2) ((h1a, h1b), (h2a, h2b)).
simpl in *. subst n2.
split.
red; intros.
(* range *)
generalize (MapPermut.permut_exists _ _ _ _ _ h1b H).
intros (j, (h1,h2)). rewrite <- h2. auto.
(* injective *)
rewrite MapInjection.injection_occ.
intros v; rewrite <- h1b.
generalize v; rewrite <- MapInjection.injection_occ.
assumption.
Qed.


(*
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     AdversaryUniverse

     ModelCheck.ProtocolFunctions
.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations.

From Frap Require Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Import SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module ShareSecretSymmetricEncProtocol.

  (* User ids *)
  Notation USR1 := 0.
  Notation USR2 := 1.

  Section IW_Simple.
    Import IdealWorld.

    Notation perms_CH := 0.
    Notation CH := (Single perms_CH).

    Notation empty_chs := (#0 #+ (CH, [])).

    Definition PERMS := $0 $+ (perms_CH, {| read := true; write := true |}).

    Definition simple_users :=
      [
        (mkiUsr USR1 PERMS
                (
                  n <- Gen
                  ; _ <- Send (Content n) CH
                  ; @Return (Base Nat) n
        ));
        (mkiUsr USR2 PERMS
                ( m <- @Recv Nat CH
                ; @Return (Base Nat) (extractContent m)))
        ].

    Definition simple_univ_start :=
      mkiU empty_chs simple_users.

  End IW_Simple.

  Section IW.
    Import IdealWorld.

    Notation pCH12 := 0.
    Notation pCH21 := 1.
    Notation CH12  := (# pCH12).
    Notation CH21  := (# pCH21).

    Notation empty_chs := (#0 #+ (CH12, []) #+ (CH21, [])).

    Notation PERMS1 := ($0 $+ (pCH12, owner) $+ (pCH21, reader)).
    Notation PERMS2 := ($0 $+ (pCH12, reader) $+ (pCH21, owner)).

    Notation ideal_users :=
      [
        (mkiUsr USR1 PERMS1
                ( chid <- CreateChannel
                  ; _ <- Send (sharePerm chid writer) CH12
                  ; m <- @Recv Access (chid #& pCH21)
                  ; n <- Gen
                  ; _ <- Send (Content n) (getPerm m #& pCH12)
                  ; @Return (Base Nat) n
        )) ;
      (mkiUsr USR2 PERMS2
              ( m <- @Recv Access CH12
                ; chid <- CreateChannel
                ; _ <- Send (sharePerm chid owner) (getPerm m #& pCH21)
                ; m <- @Recv Nat (chid #& pCH12)
                ; @Return (Base Nat) (extractContent m)
      ))
      ].

    Definition ideal_univ_start :=
      mkiU empty_chs ideal_users.

  End IW.

  Section RW.
    Import RealWorld.

    Notation KID1 := 0.
    Notation KID2 := 1.

    Notation KEYS := [ skey KID1 ; skey KID2 ].

    Notation KEYS1 := ($0 $+ (KID1, true) $+ (KID2, false)).
    Notation KEYS2 := ($0 $+ (KID1, false) $+ (KID2, true)).

    Definition real_users :=
      [
        MkRUserSpec USR1 KEYS1
                    ( kp <- GenerateKey AsymKey Encryption
                      ; c1 <- Sign KID1 USR2 (sharePubKey kp)
                      ; _  <- Send USR2 c1
                      ; c2 <- @Recv Access (SignedEncrypted KID2 (fst kp) true)
                      ; m  <- Decrypt c2
                      ; n  <- Gen
                      ; c3 <- SignEncrypt KID1 (getKey m) USR2 (message.Content n)
                      ; _  <- Send USR2 c3
                      ; @Return (Base Nat) n) ;

      MkRUserSpec USR2 KEYS2
                  ( c1 <- @Recv Access (Signed KID1 true)
                    ; v  <- Verify KID1 c1
                    ; kp <- GenerateKey SymKey Encryption
                    ; c2 <- SignEncrypt KID2 (getKey (snd v)) USR1 (sharePrivKey kp)
                    ; _  <- Send USR1 c2
                    ; c3 <- @Recv Nat (SignedEncrypted KID1 (fst kp) true)
                    ; m  <- Decrypt c3
                    ; @Return (Base Nat) (extractContent m) )
      ].

    Definition real_univ_start :=
      mkrU (mkKeys KEYS) real_users.
  End RW.

  #[export] Hint Unfold
       simple_univ_start
       ideal_univ_start
       real_univ_start
    : user_build.

  #[export] Hint Extern 0 (IdealWorld.lstep_universe _ _ _) =>
    progress(autounfold with user_build; simpl) : core.

End ShareSecretSymmetricEncProtocol.


Require Import VST.floyd.proofauto.
Require Import VST.progs.reverse_client.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition t_struct_list := Tstruct _list noattr.

Fixpoint listrep (sigma: list int) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
      data_at Tsh t_struct_list (Vint h,y) x  *  listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Arguments listrep sigma x : simpl never.

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil)).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros. entailer!. intuition.
Intros y. entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

#[export] Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep; intros; Intros; subst.
 auto with valid_pointer.
 Intros y.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

#[export] Hint Resolve listrep_valid_pointer : valid_pointer.

Definition reverse_spec :=
 DECLARE _reverse
  WITH sigma : list int, p: val
  PRE  [ tptr t_struct_list ]
     PROP ()
     PARAMS (p)
     SEP (listrep sigma p)
  POST [ (tptr t_struct_list) ]
    EX q:val,
     PROP () RETURN (q)
     SEP (listrep (rev sigma) q).

Definition last_foo_spec :=
 DECLARE _last_foo
  WITH sigma : list int, p: val, sigma': list int, x: int
  PRE  [ tptr t_struct_list ]
     PROP (sigma = sigma' ++ x :: nil)
     PARAMS (p)
     SEP (listrep sigma p)
  POST [ tuint ]
     PROP () RETURN (Vint x)
     SEP (TT).

Definition Gprog : funspecs :=
         ltac:(with_library prog [ reverse_spec; last_foo_spec ]).

Lemma body_last_foo: semax_body Vprog Gprog
                                    f_last_foo last_foo_spec.
Proof.
  start_function.
  subst sigma.
  forward_call (sigma' ++ [x], p). (* p = reverse (p); *)
  Intros p'.
  rewrite rev_app_distr; simpl.
  unfold listrep; fold listrep.
  Intros q.
  forward. (* res = p -> head; *)
  forward. (* return res; *)
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Function calling conventions and other conventions regarding the use of
    machine registers and stack slots. *)

Require Import Coqlib.
Require Import AST.
Require Import Events.
Require Import Locations.

(** * Classification of machine registers *)

(** Machine registers (type [mreg] in module [Locations]) are divided in
  the following groups:
- Callee-save registers, whose value is preserved across a function call.
- Caller-save registers that can be modified during a function call.

  We follow the PowerPC/EABI application binary interface (ABI) in our choice
  of callee- and caller-save registers.
*)

Definition int_caller_save_regs :=
  R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: R11 :: R12 :: nil.

Definition float_caller_save_regs :=
  F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: nil.

Definition int_callee_save_regs :=
  R31 :: R30 :: R29 :: R28 :: R27 :: R26 :: R25 :: R24 :: R23 ::
  R22 :: R21 :: R20 :: R19 :: R18 :: R17 :: R16 :: R15 :: R14 :: nil.

Definition float_callee_save_regs :=
  F31 :: F30 :: F29 :: F28 :: F27 :: F26 :: F25 :: F24 :: F23 ::
  F22 :: F21 :: F20 :: F19 :: F18 :: F17 :: F16 :: F15 :: F14 :: nil.

Definition destroyed_at_call :=
  int_caller_save_regs ++ float_caller_save_regs.

Definition dummy_int_reg := R3.     (**r Used in [Coloring]. *)
Definition dummy_float_reg := F0.   (**r Used in [Coloring]. *)

(** The [index_int_callee_save] and [index_float_callee_save] associate
  a unique positive integer to callee-save registers.  This integer is
  used in [Stacking] to determine where to save these registers in
  the activation record if they are used by the current function. *)

Definition index_int_callee_save (r: mreg) :=
  match r with
  | R14 => 17 | R15 => 16 | R16 => 15 | R17 => 14
  | R18 => 13 | R19 => 12 | R20 => 11 | R21 => 10
  | R22 => 9  | R23 => 8  | R24 => 7  | R25 => 6
  | R26 => 5  | R27 => 4  | R28 => 3  | R29 => 2
  | R30 => 1  | R31 => 0  | _ => -1
  end.

Definition index_float_callee_save (r: mreg) :=
  match r with
  | F14 => 17 | F15 => 16 | F16 => 15 | F17 => 14
  | F18 => 13 | F19 => 12 | F20 => 11 | F21 => 10
  | F22 => 9  | F23 => 8  | F24 => 7  | F25 => 6
  | F26 => 5  | F27 => 4  | F28 => 3  | F29 => 2
  | F30 => 1  | F31 => 0  | _ => -1
  end.

Ltac ElimOrEq :=
  match goal with
  |  |- (?x = ?y) \/ _ -> _ =>
       let H := fresh in
       (intro H; elim H; clear H;
        [intro H; rewrite <- H; clear H | ElimOrEq])
  |  |- False -> _ =>
       let H := fresh in (intro H; contradiction)
  end.

Ltac OrEq :=
  match goal with
  | |- (?x = ?x) \/ _ => left; reflexivity
  | |- (?x = ?y) \/ _ => right; OrEq
  | |- False => fail
  end.

Ltac NotOrEq :=
  match goal with
  | |- (?x = ?y) \/ _ -> False =>
       let H := fresh in (
       intro H; elim H; clear H; [intro; discriminate | NotOrEq])
  | |- False -> False =>
       contradiction
  end.

Lemma index_int_callee_save_pos:
  forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0.
Proof.
  intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega.
Qed.

Lemma index_float_callee_save_pos:
  forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0.
Proof.
  intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega.
Qed.

Lemma index_int_callee_save_pos2:
  forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs.
Proof.
  destruct r; simpl; intro; omegaContradiction || OrEq.
Qed.

Lemma index_float_callee_save_pos2:
  forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs.
Proof.
  destruct r; simpl; intro; omegaContradiction || OrEq.
Qed.

Lemma index_int_callee_save_inj:
  forall r1 r2,
  In r1 int_callee_save_regs ->
  In r2 int_callee_save_regs ->
  r1 <> r2 ->
  index_int_callee_save r1 <> index_int_callee_save r2.
Proof.
  intros r1 r2.
  simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save;
  intros; congruence.
Qed.

Lemma index_float_callee_save_inj:
  forall r1 r2,
  In r1 float_callee_save_regs ->
  In r2 float_callee_save_regs ->
  r1 <> r2 ->
  index_float_callee_save r1 <> index_float_callee_save r2.
Proof.
  intros r1 r2.
  simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save;
  intros; congruence.
Qed.

(** The following lemmas show that
    (temporaries, destroyed at call, integer callee-save, float callee-save)
    is a partition of the set of machine registers. *)

Lemma int_float_callee_save_disjoint:
  list_disjoint int_callee_save_regs float_callee_save_regs.
Proof.
  red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate.
Qed.

Lemma register_classification:
  forall r,
  In r destroyed_at_call \/ In r int_callee_save_regs \/ In r float_callee_save_regs.
Proof.
  destruct r;
  try (left; simpl; OrEq);
  try (right; left; simpl; OrEq);
  try (right; right; simpl; OrEq).
Qed.

Lemma int_callee_save_not_destroyed:
  forall r,
    In r destroyed_at_call -> In r int_callee_save_regs -> False.
Proof.
  intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
Qed.

Lemma float_callee_save_not_destroyed:
  forall r,
    In r destroyed_at_call -> In r float_callee_save_regs -> False.
Proof.
  intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
Qed.

Lemma int_callee_save_type:
  forall r, In r int_callee_save_regs -> mreg_type r = Tany32.
Proof.
  intro. simpl; ElimOrEq; reflexivity.
Qed.

Lemma float_callee_save_type:
  forall r, In r float_callee_save_regs -> mreg_type r = Tany64.
Proof.
  intro. simpl; ElimOrEq; reflexivity.
Qed.

Ltac NoRepet :=
  match goal with
  | |- list_norepet nil =>
      apply list_norepet_nil
  | |- list_norepet (?a :: ?b) =>
      apply list_norepet_cons; [simpl; intuition discriminate | NoRepet]
  end.

Lemma int_callee_save_norepet:
  list_norepet int_callee_save_regs.
Proof.
  unfold int_callee_save_regs; NoRepet.
Qed.

Lemma float_callee_save_norepet:
  list_norepet float_callee_save_regs.
Proof.
  unfold float_callee_save_regs; NoRepet.
Qed.

(** * Function calling conventions *)

(** The functions in this section determine the locations (machine registers
  and stack slots) used to communicate arguments and results between the
  caller and the callee during function calls.  These locations are functions
  of the signature of the function and of the call instruction.
  Agreement between the caller and the callee on the locations to use
  is guaranteed by our dynamic semantics for Cminor and RTL, which demand
  that the signature of the call instruction is identical to that of the
  called function.

  Calling conventions are largely arbitrary: they must respect the properties
  proved in this section (such as no overlapping between the locations
  of function arguments), but this leaves much liberty in choosing actual
  locations.  To ensure binary interoperability of code generated by our
  compiler with libraries compiled by another PowerPC compiler, we
  implement the standard conventions defined in the PowerPC/EABI
  application binary interface. *)

(** ** Location of function result *)

(** The result value of a function is passed back to the caller in
  registers [R3] or [F1] or [R3, R4], depending on the type of the returned value.
  We treat a function without result as a function with one integer result. *)

Definition loc_result (s: signature) : list mreg :=
  match s.(sig_res) with
  | None => R3 :: nil
  | Some (Tint | Tany32) => R3 :: nil
  | Some (Tfloat | Tsingle | Tany64) => F1 :: nil
  | Some Tlong => R3 :: R4 :: nil
  end.

(** The result registers have types compatible with that given in the signature. *)

Lemma loc_result_type:
  forall sig,
  subtype_list (proj_sig_res' sig) (map mreg_type (loc_result sig)) = true.
Proof.
  intros. unfold proj_sig_res', loc_result. destruct (sig_res sig) as [[]|]; auto.
Qed.

(** The result locations are caller-save registers *)

Lemma loc_result_caller_save:
  forall (s: signature) (r: mreg),
  In r (loc_result s) -> In r destroyed_at_call.
Proof.
  intros.
  assert (r = R3 \/ r = R4 \/ r = F1).
    unfold loc_result in H. destruct (sig_res s); [destruct t|idtac]; simpl in H; intuition.
  destruct H0 as [A | [A | A]]; subst r; simpl; OrEq.
Qed.

(** ** Location of function arguments *)

(** The PowerPC EABI states the following convention for passing arguments
  to a function:
- The first 8 integer arguments are passed in registers [R3] to [R10].
- The first 8 float arguments are passed in registers [F1] to [F8].
- The first 4 long integer arguments are passed in register pairs [R3,R4] ... [R9,R10].
- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively
  assigned (1 word for an integer argument, 2 words for a float),
  starting at word offset 0.
- No stack space is reserved for the arguments that are passed in registers.
*)

Definition int_param_regs :=
  R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil.
Definition float_param_regs :=
  F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: nil.

Fixpoint loc_arguments_rec
    (tyl: list typ) (ir fr ofs: Z) {struct tyl} : list loc :=
  match tyl with
  | nil => nil
  | (Tint | Tany32) as ty :: tys =>
      match list_nth_z int_param_regs ir with
      | None =>
          S Outgoing ofs ty :: loc_arguments_rec tys ir fr (ofs + 1)
      | Some ireg =>
          R ireg :: loc_arguments_rec tys (ir + 1) fr ofs
      end
  | (Tfloat | Tsingle | Tany64) as ty :: tys =>
      match list_nth_z float_param_regs fr with
      | None =>
          let ofs := align ofs 2 in
          S Outgoing ofs ty :: loc_arguments_rec tys ir fr (ofs + 2)
      | Some freg =>
          R freg :: loc_arguments_rec tys ir (fr + 1) ofs
      end
  | Tlong :: tys =>
      let ir := align ir 2 in
      match list_nth_z int_param_regs ir, list_nth_z int_param_regs (ir + 1) with
      | Some r1, Some r2 =>
          R r1 :: R r2 :: loc_arguments_rec tys (ir + 2) fr ofs
      | _, _ =>
          let ofs := align ofs 2 in
          S Outgoing ofs Tint :: S Outgoing (ofs + 1) Tint :: loc_arguments_rec tys ir fr (ofs + 2)
      end
  end.

(** [loc_arguments s] returns the list of locations where to store arguments
  when calling a function with signature [s].  *)

Definition loc_arguments (s: signature) : list loc :=
  loc_arguments_rec s.(sig_args) 0 0 0.

(** [size_arguments s] returns the number of [Outgoing] slots used
  to call a function with signature [s]. *)

Fixpoint size_arguments_rec (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z :=
  match tyl with
  | nil => ofs
  | (Tint | Tany32) :: tys =>
      match list_nth_z int_param_regs ir with
      | None => size_arguments_rec tys ir fr (ofs + 1)
      | Some ireg => size_arguments_rec tys (ir + 1) fr ofs
      end
  | (Tfloat | Tsingle | Tany64) :: tys =>
      match list_nth_z float_param_regs fr with
      | None => size_arguments_rec tys ir fr (align ofs 2 + 2)
      | Some freg => size_arguments_rec tys ir (fr + 1) ofs
      end
  | Tlong :: tys =>
      let ir := align ir 2 in
      match list_nth_z int_param_regs ir, list_nth_z int_param_regs (ir + 1) with
      | Some r1, Some r2 => size_arguments_rec tys (ir + 2) fr ofs
      | _, _ => size_arguments_rec tys ir fr (align ofs 2 + 2)
      end
  end.

Definition size_arguments (s: signature) : Z :=
  size_arguments_rec s.(sig_args) 0 0 0.

(** A tail-call is possible for a signature if the corresponding
    arguments are all passed in registers. *)

Definition tailcall_possible (s: signature) : Prop :=
  forall l, In l (loc_arguments s) ->
  match l with R _ => True | S _ _ _ => False end.

(** Argument locations are either caller-save registers or [Outgoing]
  stack slots at nonnegative offsets. *)

Definition loc_argument_acceptable (l: loc) : Prop :=
  match l with
  | R r => In r destroyed_at_call
  | S Outgoing ofs ty => ofs >= 0 /\ ty <> Tlong
  | _ => False
  end.

Remark loc_arguments_rec_charact:
  forall tyl ir fr ofs l,
  In l (loc_arguments_rec tyl ir fr ofs) ->
  match l with
  | R r => In r int_param_regs \/ In r float_param_regs
  | S Outgoing ofs' ty => ofs' >= ofs /\ ty <> Tlong
  | S _ _ _ => False
  end.
Proof.
Opaque list_nth_z.
  induction tyl; simpl loc_arguments_rec; intros.
  elim H.
  destruct a.
- (* int *)
  destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H.
  subst. left. eapply list_nth_z_in; eauto.
  eapply IHtyl; eauto.
  subst. split. omega. congruence.
  exploit IHtyl; eauto. destruct l; auto. destruct sl; auto. intuition omega.
- (* float *)
  destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H.
  subst. right. eapply list_nth_z_in; eauto.
  eapply IHtyl; eauto.
  subst. split. apply Zle_ge. apply align_le. omega. congruence.
  exploit IHtyl; eauto. destruct l; auto. destruct sl; auto.
  assert (ofs <= align ofs 2) by (apply align_le; omega).
  intuition omega.
- (* long *)
  set (ir' := align ir 2) in *.
  destruct (list_nth_z int_param_regs ir') as [r1|] eqn:E1.
  destruct (list_nth_z int_param_regs (ir' + 1)) as [r2|] eqn:E2.
  destruct H. subst; left; eapply list_nth_z_in; eauto.
  destruct H. subst; left; eapply list_nth_z_in; eauto.
  eapply IHtyl; eauto.
  assert (ofs <= align ofs 2) by (apply align_le; omega).
  destruct H. subst. split. omega. congruence.
  destruct H. subst. split. omega. congruence.
  exploit IHtyl; eauto. destruct l; auto. destruct sl; auto. intuition omega.
  assert (ofs <= align ofs 2) by (apply align_le; omega).
  destruct H. subst. split. omega. congruence.
  destruct H. subst. split. omega. congruence.
  exploit IHtyl; eauto. destruct l; auto. destruct sl; auto. intuition omega.
- (* single *)
  destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H.
  subst. right. eapply list_nth_z_in; eauto.
  eapply IHtyl; eauto.
  subst. split. apply Zle_ge. apply align_le. omega. congruence.
  exploit IHtyl; eauto. destruct l; auto. destruct sl; auto.
  assert (ofs <= align ofs 2) by (apply align_le; omega).
  intuition omega.
- (* any32 *)
  destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H.
  subst. left. eapply list_nth_z_in; eauto.
  eapply IHtyl; eauto.
  subst. split. omega. congruence.
  exploit IHtyl; eauto. destruct l; auto. destruct sl; auto. intuition omega.
- (* any64 *)
  destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H.
  subst. right. eapply list_nth_z_in; eauto.
  eapply IHtyl; eauto.
  subst. split. apply Zle_ge. apply align_le. omega. congruence.
  exploit IHtyl; eauto. destruct l; auto. destruct sl; auto.
  assert (ofs <= align ofs 2) by (apply align_le; omega).
  intuition omega.
Qed.

Lemma loc_arguments_acceptable:
  forall (s: signature) (l: loc),
  In l (loc_arguments s) -> loc_argument_acceptable l.
Proof.
  unfold loc_arguments; intros.
  generalize (loc_arguments_rec_charact _ _ _ _ _ H).
  destruct l.
  intro H0; elim H0; simpl; ElimOrEq; OrEq.
  destruct sl; try contradiction. simpl. intuition omega.
Qed.
Hint Resolve loc_arguments_acceptable: locs.

(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)

Remark size_arguments_rec_above:
  forall tyl ir fr ofs0,
  ofs0 <= size_arguments_rec tyl ir fr ofs0.
Proof.
  induction tyl; simpl; intros.
  omega.
  destruct a.
  destruct (list_nth_z int_param_regs ir); eauto. apply Zle_trans with (ofs0 + 1); auto; omega.
  destruct (list_nth_z float_param_regs fr); eauto.
  apply Zle_trans with (align ofs0 2). apply align_le; omega.
  apply Zle_trans with (align ofs0 2 + 2); auto; omega.
  set (ir' := align ir 2).
  destruct (list_nth_z int_param_regs ir'); eauto.
  destruct (list_nth_z int_param_regs (ir' + 1)); eauto.
  apply Zle_trans with (align ofs0 2). apply align_le; omega.
  apply Zle_trans with (align ofs0 2 + 2); auto; omega.
  apply Zle_trans with (align ofs0 2). apply align_le; omega.
  apply Zle_trans with (align ofs0 2 + 2); auto; omega.
  destruct (list_nth_z float_param_regs fr); eauto.
  apply Zle_trans with (align ofs0 2). apply align_le; omega.
  apply Zle_trans with (align ofs0 2 + 2); auto; omega.
  destruct (list_nth_z int_param_regs ir); eauto. apply Zle_trans with (ofs0 + 1); auto; omega.
  destruct (list_nth_z float_param_regs fr); eauto.
  apply Zle_trans with (align ofs0 2). apply align_le; omega.
  apply Zle_trans with (align ofs0 2 + 2); auto; omega.
Qed.

Lemma size_arguments_above:
  forall s, size_arguments s >= 0.
Proof.
  intros; unfold size_arguments. apply Zle_ge.
  apply size_arguments_rec_above.
Qed.

Lemma loc_arguments_bounded:
  forall (s: signature) (ofs: Z) (ty: typ),
  In (S Outgoing ofs ty) (loc_arguments s) ->
  ofs + typesize ty <= size_arguments s.
Proof.
  intros.
  assert (forall tyl ir fr ofs0,
    In (S Outgoing ofs ty) (loc_arguments_rec tyl ir fr ofs0) ->
    ofs + typesize ty <= size_arguments_rec tyl ir fr ofs0).
{
  induction tyl; simpl; intros.
  elim H0.
  destruct a.
- (* int *)
  destruct (list_nth_z int_param_regs ir); destruct H0.
  congruence.
  eauto.
  inv H0. apply size_arguments_rec_above.
  eauto.
- (* float *)
  destruct (list_nth_z float_param_regs fr); destruct H0.
  congruence.
  eauto.
  inv H0. apply size_arguments_rec_above. eauto.
- (* long *)
  set (ir' := align ir 2) in *.
  destruct (list_nth_z int_param_regs ir').
  destruct (list_nth_z int_param_regs (ir' + 1)).
  destruct H0. congruence. destruct H0. congruence. eauto.
  destruct H0. inv H0.
  transitivity (align ofs0 2 + 2). simpl; omega. eauto.  apply size_arguments_rec_above.
  destruct H0. inv H0.
  transitivity (align ofs0 2 + 2). simpl; omega. eauto.  apply size_arguments_rec_above.
  eauto.
  destruct H0. inv H0.
  transitivity (align ofs0 2 + 2). simpl; omega. eauto.  apply size_arguments_rec_above.
  destruct H0. inv H0.
  transitivity (align ofs0 2 + 2). simpl; omega. eauto.  apply size_arguments_rec_above.
  eauto.
- (* single *)
  destruct (list_nth_z float_param_regs fr); destruct H0.
  congruence.
  eauto.
  inv H0. transitivity (align ofs0 2 + 2). simpl; omega. apply size_arguments_rec_above.
  eauto.
- (* any32 *)
  destruct (list_nth_z int_param_regs ir); destruct H0.
  congruence.
  eauto.
  inv H0. apply size_arguments_rec_above.
  eauto.
- (* any64 *)
  destruct (list_nth_z float_param_regs fr); destruct H0.
  congruence.
  eauto.
  inv H0. apply size_arguments_rec_above. eauto.
  }
  eauto.
Qed.

Lemma loc_arguments_main:
  loc_arguments signature_main = nil.
Proof.
  reflexivity.
Qed.