Require Import VST.floyd.proofauto.
Require Export malloc_lemmas. (*Exports the model (constants like WA , plus lemmas)*)

(*Require Import malloc. needed for function and type names but not for compspecs
Update: Some UPenn grad students proposed to abstract over function identifiers -
doing so in our setup makes ASIs source-program-independent!*)

Global Open Scope funspec_scope.

Record MallocTokenAPD := {
  malloc_token': share -> Z -> val -> mpred;
  malloc_token'_valid_pointer: forall sh sz p,
      malloc_token' sh sz p |-- valid_pointer p;
  malloc_token'_local_facts:  forall sh sz p,
      malloc_token' sh sz p |-- !! malloc_compatible sz p;
}.

Record MallocFreeAPD := {
  MF_Tok :> MallocTokenAPD;
  mem_mgr: globals -> mpred;
}.

Definition malloc_token {cs:compspecs} M (sh: share) (t: type) (p: val): mpred :=
   !! field_compatible t [] p &&
   malloc_token' M sh (sizeof t) p.

Lemma malloc_token_valid_pointer: forall {cs: compspecs} M sh t p,
      malloc_token M sh t p |-- valid_pointer p.
Proof. intros. unfold malloc_token.
 apply andp_left2. apply malloc_token'_valid_pointer.
Qed.

#[export] Hint Resolve malloc_token'_valid_pointer : valid_pointer.
#[export] Hint Resolve malloc_token_valid_pointer : valid_pointer.

Lemma malloc_token_local_facts:  forall {cs: compspecs} M sh t p,
      malloc_token M sh t p |-- !! (field_compatible t [] p /\ malloc_compatible (sizeof t) p).
Proof. intros.
 unfold malloc_token.
 normalize. rewrite prop_and.
 apply andp_right. apply prop_right; auto.
 apply malloc_token'_local_facts.
Qed.

#[export] Hint Resolve malloc_token'_local_facts : saturate_local.
#[export] Hint Resolve malloc_token_local_facts : saturate_local.

Section Malloc_ASI.
Variable M: MallocFreeAPD.
Variable mallocID:ident.
Variable freeID:ident.

Definition malloc_spec' :=
   DECLARE (*_malloc*)mallocID
   WITH n:Z, gv:globals
   PRE [ size_t ]
       PROP (0 <= n <= Ptrofs.max_unsigned - (WA+WORD))
       PARAMS ((Vptrofs (Ptrofs.repr n))) GLOBALS (gv)
       SEP ( mem_mgr M gv )
   POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP ( mem_mgr M gv;
             if eq_dec p nullval then emp
             else (malloc_token' M Ews n p * memory_block Ews n p)).

Definition free_spec' :=
 DECLARE (*_free*)freeID
   WITH n:Z, p:val, gv: globals
   PRE [ tptr tvoid ]
       PROP ()
       PARAMS (p) GLOBALS (gv)
       SEP (mem_mgr M gv;
            if eq_dec p nullval then emp
            else (malloc_token' M Ews n p * memory_block Ews n p))
    POST [ Tvoid ]
       PROP ()
       LOCAL ()
       SEP (mem_mgr M gv).

Definition Malloc_ASI:funspecs := [malloc_spec'; free_spec'].
End Malloc_ASI.

Record MallocFree_R_APD := {
  MF_Tok_R :> MallocTokenAPD;
  mem_mgr_R: resvec -> globals -> mpred; (*changed order of arguments*)
}.
(*
Definition malloc_token_R {cs:compspecs} M (sh: share) (t: type) (p: val): mpred :=
   !! field_compatible t [] p &&
   malloc_token_R' M sh (sizeof t) p.

Lemma malloc_token_R_valid_pointer: forall {cs: compspecs} M sh t p,
      malloc_token_R M sh t p |-- valid_pointer p.
Proof. intros. unfold malloc_token.
 apply andp_left2. apply malloc_token_R'_valid_pointer.
Qed.

#[export] Hint Resolve malloc_token_R'_valid_pointer : valid_pointer.
#[export] Hint Resolve malloc_token_R_valid_pointer : valid_pointer.

Lemma malloc_token_R_local_facts:  forall {cs: compspecs} M sh t p,
      malloc_token_R M sh t p |-- !! (field_compatible t [] p /\ malloc_compatible (sizeof t) p).
Proof. intros.
 unfold malloc_token_R.
 normalize. rewrite prop_and.
 apply andp_right. apply prop_right; auto.
 apply malloc_token_R'_local_facts.
Qed.

#[export] Hint Resolve malloc_token_R'_local_facts : saturate_local.
#[export] Hint Resolve malloc_token_R_local_facts : saturate_local.
*)
Require Import VST.floyd.VSU.

Section Malloc_R_ASI.
Variable M: MallocFree_R_APD.
Variable prefillID:ident.
Variable tryprefillID:ident.
Variable mallocID:ident.
Variable freeID:ident.

Definition pre_fill_spec' :=
 DECLARE (*_pre_fill*) prefillID
   WITH n:Z, p:val, gv:globals, rvec:resvec
   PRE [ tuint, tptr tvoid ]
       PROP (0 <= n <= maxSmallChunk /\ malloc_compatible BIGBLOCK p)
       PARAMS ((Vptrofs (Ptrofs.repr n)); p) GLOBALS (gv)
       SEP (mem_mgr_R M rvec gv; memory_block Tsh BIGBLOCK p)
    POST [ Tvoid ]
       PROP ()
       LOCAL ()
       SEP (mem_mgr_R M (add_resvec rvec (size2binZ n)
                                     (chunks_from_block (size2binZ n))) gv).

Definition try_pre_fill_spec' :=
 DECLARE (*_try_pre_fill*) tryprefillID
   WITH n:Z, req:Z, rvec:resvec, gv:globals
   PRE [ tuint, tint ]
       PROP (0 <= n <= maxSmallChunk /\ 0 <= req <= Int.max_signed)
       PARAMS ((Vint (Int.repr n)); (Vint (Int.repr req))) GLOBALS (gv)
       SEP (mem_mgr_R M rvec gv)
   POST [ tint ] EX result: Z,
     PROP ()
     LOCAL (temp ret_temp (Vint (Int.repr result)))
     SEP (mem_mgr_R M (add_resvec rvec (size2binZ n) result) gv).

Definition malloc_spec_R' :=
   DECLARE (*_malloc*)mallocID
   WITH n:Z, gv:globals, rvec:resvec
   PRE [ size_t ]
       PROP (0 <= n <= Ptrofs.max_unsigned - (WA+WORD))
       PARAMS ((* _nbytes *) (Vptrofs (Ptrofs.repr n))) GLOBALS (gv)
       SEP ( mem_mgr_R M rvec gv)
   POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP ( if guaranteed rvec n
             then mem_mgr_R M (add_resvec rvec (size2binZ n) (-1)) gv *
                  malloc_token' M Ews n p * memory_block Ews n p
             else if eq_dec p nullval
                  then mem_mgr_R M rvec gv
                  else (if n <=? maxSmallChunk
                        then (EX rvec':_, !!(eq_except rvec' rvec (size2binZ n))
                                            && (mem_mgr_R M rvec' gv))
                        else mem_mgr_R M rvec gv) *
                       malloc_token' M Ews n p * memory_block Ews n p).

Definition free_spec_R' :=
 DECLARE (*_free*)freeID
   WITH n:Z, p:val, gv:globals, rvec:resvec
   PRE [ tptr tvoid ]
       PROP ()
       PARAMS (p) GLOBALS (gv)
       SEP (mem_mgr_R M rvec gv;
            if eq_dec p nullval then emp
            else (malloc_token' M Ews n p * memory_block Ews n p))
    POST [ Tvoid ]
       PROP ()
       LOCAL ()
       SEP (if eq_dec p nullval
            then mem_mgr_R M rvec gv
            else if n <=? maxSmallChunk
                 then mem_mgr_R M (add_resvec rvec (size2binZ n) 1) gv
                 else mem_mgr_R M rvec gv).

Definition Malloc_R_ASI:funspecs := [pre_fill_spec'; try_pre_fill_spec'; malloc_spec_R'; free_spec_R'].

Definition ForgetR:MallocFreeAPD :=
  Build_MallocFreeAPD (MF_Tok_R M) (fun gv => EX R, mem_mgr_R M R gv).

Lemma malloc_spec_R_sub i: funspec_sub (snd malloc_spec_R') (snd (malloc_spec' ForgetR i)).
Proof.
do_funspec_sub. destruct w as [n gv]. clear H.
unfold mem_mgr.
Intros rvec.
Exists (n, gv, rvec) emp. (* empty frame *)
simpl; entailer!.
intros tau ? ?.
set (p:=eval_id ret_temp tau).
Exists p; entailer!.
destruct (guaranteed rvec n) eqn:guar.
- (* guaranteed *)
  if_tac; auto.
  Exists (add_resvec rvec (size2binZ n) (-1)); entailer!.
  rewrite H4; entailer!.
  Exists (add_resvec rvec (size2binZ n) (-1)); entailer!.
- (* not guaranteed *)
  bdestruct (n <=? maxSmallChunk).
  + if_tac; auto. Exists rvec; entailer!. Intros rvec'; Exists rvec'; entailer!.
  + if_tac; auto; Exists rvec; entailer!.
Qed.

Lemma free_spec_R_sub i: funspec_sub (snd free_spec_R') (snd (free_spec' ForgetR i)).
Proof.
do_funspec_sub.
destruct w as [[n p] gv]. clear H.
unfold mem_mgr.
Intros rvec. Exists (n,p,gv,rvec) emp.
simpl; entailer!.
intros tau ?.
if_tac.
Exists rvec; entailer!.
bdestruct (n <=? maxSmallChunk).
- (* small *)
  Exists (add_resvec rvec (size2binZ n) 1); entailer!.
- (* large *)
  Exists rvec; entailer!.
Qed.

Variable distinctIDs: list_norepet [prefillID; tryprefillID; mallocID; freeID].

Lemma MallocASI_sqsub_MallocR_ASI:
      funspecs_sqsub Malloc_R_ASI (Malloc_ASI ForgetR mallocID freeID).
Proof. red; intros. simpl in H.
  if_tac in H. inv H.
  { eexists; split. simpl. rewrite 2 if_false. rewrite if_true by trivial.  reflexivity.
    intros N; subst. inv distinctIDs. inv H2. apply H3. left; trivial.
    intros N; subst. inv distinctIDs. apply H1. right; left; trivial.
    apply (malloc_spec_R_sub mallocID).  }
  if_tac in H. inv H.
  { eexists; split. simpl. rewrite 3 if_false. rewrite if_true by trivial.  reflexivity.
    intros N; subst. apply H0; trivial.
    intros N; subst. inv distinctIDs. inv H3. apply H4. right; left; trivial.
    intros N; subst. inv distinctIDs. inv H3. apply H2. do 2 right; left; trivial.
    apply (free_spec_R_sub freeID). }
  congruence.
(*
  repeat (if_tac in H. [ inv H; eexists; split; [ reflexivity |] |]).
  repeat (if_tac in H; [ inv H; eexists; split; [ reflexivity |] |])
  apply malloc_spec_R_sub. apply free_spec_R_sub. congruence.*)
Qed.

End Malloc_R_ASI.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* Extraction to Ocaml : special handling of ascii and strings *)

Require Coq.extraction.Extraction.

Require Import Ascii String.

Extract Inductive ascii => char
[
"(* If this appears, you're using Ascii internals. Please don't *)
 (fun (b0,b1,b2,b3,b4,b5,b6,b7) ->
  let f b i = if b then 1 lsl i else 0 in
  Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))"
]
"(* If this appears, you're using Ascii internals. Please don't *)
 (fun f c ->
  let n = Char.code c in
  let h i = (n land (1 lsl i)) <> 0 in
  f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))".

Extract Constant zero => "'\000'".
Extract Constant one => "'\001'".
Extract Constant shift =>
 "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)".

Extract Inlined Constant ascii_dec => "(=)".

Extract Inductive string => "char list" [ "[]" "(::)" ].

(*
Definition test := "ceci est un test"%string.
Recursive Extraction test Ascii.zero Ascii.one.
*)


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

(** Elimination of unneeded computations over RTL: correctness proof. *)

Require Import FunInd.
Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
Require Import AST Linking.
Require Import Values Memory Globalenvs Events Smallstep.
Require Import Registers Op RTL.
Require Import ValueDomain ValueAnalysis NeedDomain NeedOp Deadcode.
Require Import sflib.

Definition match_prog (prog tprog: RTL.program) :=
  match_program (fun cu f tf => transf_fundef (romem_for cu) f = OK tf) eq prog tprog.

Lemma transf_program_match:
  forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog.
Proof.
  intros. eapply match_transform_partial_program_contextual; eauto.
Qed.

(** * Relating the memory states *)

(** The [magree] predicate is a variant of [Mem.extends] where we
  allow the contents of the two memory states to differ arbitrarily
  on some locations.  The predicate [P] is true on the locations whose
  contents must be in the [lessdef] relation. *)

Definition locset := block -> Z -> Prop.

Record magree (m1 m2: mem) (P: locset) : Prop := mk_magree {
  ma_perm:
    forall b ofs k p,
    Mem.perm m1 b ofs k p -> Mem.perm m2 b ofs k p;
  ma_perm_inv:
    forall b ofs k p,
    Mem.perm m2 b ofs k p -> Mem.perm m1 b ofs k p \/ ~Mem.perm m1 b ofs Max Nonempty;
  ma_memval:
    forall b ofs,
    Mem.perm m1 b ofs Cur Readable ->
    P b ofs ->
    memval_lessdef (ZMap.get ofs (PMap.get b (Mem.mem_contents m1)))
                   (ZMap.get ofs (PMap.get b (Mem.mem_contents m2)));
  ma_nextblock:
    Mem.nextblock m2 = Mem.nextblock m1
}.

Lemma magree_monotone:
  forall m1 m2 (P Q: locset),
  magree m1 m2 P ->
  (forall b ofs, Q b ofs -> P b ofs) ->
  magree m1 m2 Q.
Proof.
  intros. destruct H. constructor; auto.
Qed.

Lemma mextends_agree:
  forall m1 m2 P, Mem.extends m1 m2 -> magree m1 m2 P.
Proof.
  intros. destruct H. destruct mext_inj. constructor; intros.
- replace ofs with (ofs + 0) by omega. eapply mi_perm; eauto. auto.
- eauto.
- exploit mi_memval; eauto. unfold inject_id; eauto.
  rewrite Z.add_0_r. auto.
- auto.
Qed.

Lemma magree_extends:
  forall m1 m2 (P: locset),
  (forall b ofs, P b ofs) ->
  magree m1 m2 P -> Mem.extends m1 m2.
Proof.
  intros. destruct H0. constructor; auto. constructor; unfold inject_id; intros.
- inv H0. rewrite Z.add_0_r. eauto.
- inv H0. apply Z.divide_0_r.
- inv H0. rewrite Z.add_0_r. eapply ma_memval0; eauto.
Qed.

Lemma magree_loadbytes:
  forall m1 m2 P b ofs n bytes,
  magree m1 m2 P ->
  Mem.loadbytes m1 b ofs n = Some bytes ->
  (forall i, ofs <= i < ofs + n -> P b i) ->
  exists bytes', Mem.loadbytes m2 b ofs n = Some bytes' /\ list_forall2 memval_lessdef bytes bytes'.
Proof.
  assert (GETN: forall c1 c2 n ofs,
    (forall i, ofs <= i < ofs + Z.of_nat n -> memval_lessdef (ZMap.get i c1) (ZMap.get i c2)) ->
    list_forall2 memval_lessdef (Mem.getN n ofs c1) (Mem.getN n ofs c2)).
  {
    induction n; intros; simpl.
    constructor.
    rewrite Nat2Z.inj_succ in H. constructor.
    apply H. omega.
    apply IHn. intros; apply H; omega.
  }
Local Transparent Mem.loadbytes.
  unfold Mem.loadbytes; intros. destruct H.
  destruct (Mem.range_perm_dec m1 b ofs (ofs + n) Cur Readable); inv H0.
  rewrite pred_dec_true. econstructor; split; eauto.
  apply GETN. intros. rewrite Z_to_nat_max in H.
  assert (ofs <= i < ofs + n) by xomega.
  apply ma_memval0; auto.
  red; intros; eauto.
Qed.

Lemma magree_load:
  forall m1 m2 P chunk b ofs v,
  magree m1 m2 P ->
  Mem.load chunk m1 b ofs = Some v ->
  (forall i, ofs <= i < ofs + size_chunk chunk -> P b i) ->
  exists v', Mem.load chunk m2 b ofs = Some v' /\ Val.lessdef v v'.
Proof.
  intros. exploit Mem.load_valid_access; eauto. intros [A B].
  exploit Mem.load_loadbytes; eauto. intros [bytes [C D]].
  exploit magree_loadbytes; eauto. intros [bytes' [E F]].
  exists (decode_val chunk bytes'); split.
  apply Mem.loadbytes_load; auto.
  apply val_inject_id. subst v. apply decode_val_inject; auto.
Qed.

Lemma magree_storebytes_parallel:
  forall m1 m2 (P Q: locset) b ofs bytes1 m1' bytes2,
  magree m1 m2 P ->
  Mem.storebytes m1 b ofs bytes1 = Some m1' ->
  (forall b' i, Q b' i ->
                b' <> b \/ i < ofs \/ ofs + Z.of_nat (length bytes1) <= i ->
                P b' i) ->
  list_forall2 memval_lessdef bytes1 bytes2 ->
  exists m2', Mem.storebytes m2 b ofs bytes2 = Some m2' /\ magree m1' m2' Q.
Proof.
  assert (SETN: forall (access: Z -> Prop) bytes1 bytes2,
    list_forall2 memval_lessdef bytes1 bytes2 ->
    forall p c1 c2,
    (forall i, access i -> i < p \/ p + Z.of_nat (length bytes1) <= i -> memval_lessdef (ZMap.get i c1) (ZMap.get i c2)) ->
    forall q, access q ->
    memval_lessdef (ZMap.get q (Mem.setN bytes1 p c1))
                   (ZMap.get q (Mem.setN bytes2 p c2))).
  {
    induction 1; intros; simpl.
  - apply H; auto. simpl. omega.
  - simpl length in H1; rewrite Nat2Z.inj_succ in H1.
    apply IHlist_forall2; auto.
    intros. rewrite ! ZMap.gsspec. destruct (ZIndexed.eq i p). auto.
    apply H1; auto. unfold ZIndexed.t in *; omega.
  }
  intros.
  destruct (Mem.range_perm_storebytes m2 b ofs bytes2) as [m2' ST2].
  { erewrite <- list_forall2_length by eauto. red; intros.
    eapply ma_perm; eauto.
    eapply Mem.storebytes_range_perm; eauto. }
  exists m2'; split; auto.
  constructor; intros.
- eapply Mem.perm_storebytes_1; eauto. eapply ma_perm; eauto.
  eapply Mem.perm_storebytes_2; eauto.
- exploit ma_perm_inv; eauto using Mem.perm_storebytes_2.
  intuition eauto using Mem.perm_storebytes_1, Mem.perm_storebytes_2.
- rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H0).
  rewrite (Mem.storebytes_mem_contents _ _ _ _ _ ST2).
  rewrite ! PMap.gsspec. destruct (peq b0 b).
+ subst b0. apply SETN with (access := fun ofs => Mem.perm m1' b ofs Cur Readable /\ Q b ofs); auto.
  intros. destruct H5. eapply ma_memval; eauto.
  eapply Mem.perm_storebytes_2; eauto.
+ eapply ma_memval; eauto. eapply Mem.perm_storebytes_2; eauto.
- rewrite (Mem.nextblock_storebytes _ _ _ _ _ H0).
  rewrite (Mem.nextblock_storebytes _ _ _ _ _ ST2).
  eapply ma_nextblock; eauto.
Qed.

Lemma magree_store_parallel:
  forall m1 m2 (P Q: locset) chunk b ofs v1 m1' v2,
  magree m1 m2 P ->
  Mem.store chunk m1 b ofs v1 = Some m1' ->
  vagree v1 v2 (store_argument chunk) ->
  (forall b' i, Q b' i ->
                b' <> b \/ i < ofs \/ ofs + size_chunk chunk <= i ->
                P b' i) ->
  exists m2', Mem.store chunk m2 b ofs v2 = Some m2' /\ magree m1' m2' Q.
Proof.
  intros.
  exploit Mem.store_valid_access_3; eauto. intros [A B].
  exploit Mem.store_storebytes; eauto. intros SB1.
  exploit magree_storebytes_parallel. eauto. eauto.
  instantiate (1 := Q). intros. rewrite encode_val_length in H4.
  rewrite <- size_chunk_conv in H4. apply H2; auto.
  eapply store_argument_sound; eauto.
  intros [m2' [SB2 AG]].
  exists m2'; split; auto.
  apply Mem.storebytes_store; auto.
Qed.

Lemma magree_storebytes_left:
  forall m1 m2 P b ofs bytes1 m1',
  magree m1 m2 P ->
  Mem.storebytes m1 b ofs bytes1 = Some m1' ->
  (forall i, ofs <= i < ofs + Z.of_nat (length bytes1) -> ~(P b i)) ->
  magree m1' m2 P.
Proof.
  intros. constructor; intros.
- eapply ma_perm; eauto. eapply Mem.perm_storebytes_2; eauto.
- exploit ma_perm_inv; eauto.
  intuition eauto using Mem.perm_storebytes_1, Mem.perm_storebytes_2.
- rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H0).
  rewrite PMap.gsspec. destruct (peq b0 b).
+ subst b0. rewrite Mem.setN_outside. eapply ma_memval; eauto. eapply Mem.perm_storebytes_2; eauto.
  destruct (zlt ofs0 ofs); auto. destruct (zle (ofs + Z.of_nat (length bytes1)) ofs0); try omega.
  elim (H1 ofs0). omega. auto.
+ eapply ma_memval; eauto. eapply Mem.perm_storebytes_2; eauto.
- rewrite (Mem.nextblock_storebytes _ _ _ _ _ H0).
  eapply ma_nextblock; eauto.
Qed.

Lemma magree_store_left:
  forall m1 m2 P chunk b ofs v1 m1',
  magree m1 m2 P ->
  Mem.store chunk m1 b ofs v1 = Some m1' ->
  (forall i, ofs <= i < ofs + size_chunk chunk -> ~(P b i)) ->
  magree m1' m2 P.
Proof.
  intros. eapply magree_storebytes_left; eauto.
  eapply Mem.store_storebytes; eauto.
  intros. rewrite encode_val_length in H2.
  rewrite <- size_chunk_conv in H2. apply H1; auto.
Qed.

Lemma magree_free:
  forall m1 m2 (P Q: locset) b lo hi m1',
  magree m1 m2 P ->
  Mem.free m1 b lo hi = Some m1' ->
  (forall b' i, Q b' i ->
                b' <> b \/ ~(lo <= i < hi) ->
                P b' i) ->
  exists m2', Mem.free m2 b lo hi = Some m2' /\ magree m1' m2' Q.
Proof.
  intros.
  destruct (Mem.range_perm_free m2 b lo hi) as [m2' FREE].
  red; intros. eapply ma_perm; eauto. eapply Mem.free_range_perm; eauto.
  exists m2'; split; auto.
  constructor; intros.
- (* permissions *)
  assert (Mem.perm m2 b0 ofs k p). { eapply ma_perm; eauto. eapply Mem.perm_free_3; eauto. }
  exploit Mem.perm_free_inv; eauto. intros [[A B] | A]; auto.
  subst b0. eelim Mem.perm_free_2. eexact H0. eauto. eauto.
- (* inverse permissions *)
  exploit ma_perm_inv; eauto using Mem.perm_free_3. intros [A|A].
  eapply Mem.perm_free_inv in A; eauto. destruct A as [[A B] | A]; auto.
  subst b0; right; eapply Mem.perm_free_2; eauto.
  right; intuition eauto using Mem.perm_free_3.
- (* contents *)
  rewrite (Mem.free_result _ _ _ _ _ H0).
  rewrite (Mem.free_result _ _ _ _ _ FREE).
  simpl. eapply ma_memval; eauto. eapply Mem.perm_free_3; eauto.
  apply H1; auto. destruct (eq_block b0 b); auto.
  subst b0. right. red; intros. eelim Mem.perm_free_2. eexact H0. eauto. eauto.
- (* nextblock *)
  rewrite (Mem.free_result _ _ _ _ _ H0).
  rewrite (Mem.free_result _ _ _ _ _ FREE).
  simpl. eapply ma_nextblock; eauto.
Qed.

Lemma magree_valid_access:
  forall m1 m2 (P: locset) chunk b ofs p,
  magree m1 m2 P ->
  Mem.valid_access m1 chunk b ofs p ->
  Mem.valid_access m2 chunk b ofs p.
Proof.
  intros. destruct H0; split; auto.
  red; intros. eapply ma_perm; eauto.
Qed.

(** * Properties of the need environment *)

Lemma add_need_all_eagree:
  forall e e' r ne,
  eagree e e' (add_need_all r ne) -> eagree e e' ne.
Proof.
  intros; red; intros. generalize (H r0). unfold add_need_all.
  rewrite NE.gsspec. destruct (peq r0 r); auto with na.
Qed.

Lemma add_need_all_lessdef:
  forall e e' r ne,
  eagree e e' (add_need_all r ne) -> Val.lessdef e#r e'#r.
Proof.
  intros. generalize (H r); unfold add_need_all.
  rewrite NE.gsspec, peq_true. auto with na.
Qed.

Lemma add_need_eagree:
  forall e e' r nv ne,
  eagree e e' (add_need r nv ne) -> eagree e e' ne.
Proof.
  intros; red; intros. generalize (H r0); unfold add_need.
  rewrite NE.gsspec. destruct (peq r0 r); auto.
  subst r0. intros. eapply nge_agree; eauto. apply nge_lub_r.
Qed.

Lemma add_need_vagree:
  forall e e' r nv ne,
  eagree e e' (add_need r nv ne) -> vagree e#r e'#r nv.
Proof.
  intros. generalize (H r); unfold add_need.
  rewrite NE.gsspec, peq_true. intros. eapply nge_agree; eauto. apply nge_lub_l.
Qed.

Lemma add_needs_all_eagree:
  forall rl e e' ne,
  eagree e e' (add_needs_all rl ne) -> eagree e e' ne.
Proof.
  induction rl; simpl; intros.
  auto.
  apply IHrl. eapply add_need_all_eagree; eauto.
Qed.

Lemma add_needs_all_lessdef:
  forall rl e e' ne,
  eagree e e' (add_needs_all rl ne) -> Val.lessdef_list e##rl e'##rl.
Proof.
  induction rl; simpl; intros.
  constructor.
  constructor. eapply add_need_all_lessdef; eauto.
  eapply IHrl. eapply add_need_all_eagree; eauto.
Qed.

Lemma add_needs_eagree:
  forall rl nvl e e' ne,
  eagree e e' (add_needs rl nvl ne) -> eagree e e' ne.
Proof.
  induction rl; simpl; intros.
  auto.
  destruct nvl. apply add_needs_all_eagree with (a :: rl); auto.
  eapply IHrl. eapply add_need_eagree; eauto.
Qed.

Lemma add_needs_vagree:
  forall rl nvl e e' ne,
  eagree e e' (add_needs rl nvl ne) -> vagree_list e##rl e'##rl nvl.
Proof.
  induction rl; simpl; intros.
  constructor.
  destruct nvl.
  apply vagree_lessdef_list. eapply add_needs_all_lessdef with (rl := a :: rl); eauto.
  constructor. eapply add_need_vagree; eauto.
  eapply IHrl. eapply add_need_eagree; eauto.
Qed.

Lemma add_ros_need_eagree:
  forall e e' ros ne, eagree e e' (add_ros_need_all ros ne) -> eagree e e' ne.
Proof.
  intros. destruct ros; simpl in *. eapply add_need_all_eagree; eauto. auto.
Qed.

Hint Resolve add_need_all_eagree add_need_all_lessdef
             add_need_eagree add_need_vagree
             add_needs_all_eagree add_needs_all_lessdef
             add_needs_eagree add_needs_vagree
             add_ros_need_eagree: na.

Lemma eagree_init_regs:
  forall rl vl1 vl2 ne,
  Val.lessdef_list vl1 vl2 ->
  eagree (init_regs vl1 rl) (init_regs vl2 rl) ne.
Proof.
  induction rl; intros until ne; intros LD; simpl.
- red; auto with na.
- inv LD.
  + red; auto with na.
  + apply eagree_update; auto with na.
Qed.

(** * Basic properties of the translation *)

Section PRESERVATION.

Variable prog: program.
Variable tprog: program.
Hypothesis TRANSF: match_prog prog tprog.

Section CORELEMMA.

Variable (se tse: Senv.t).
Hypothesis (MATCH_SENV: Senv.equiv se tse).
Variable ge tge: genv.

Hypothesis (MATCH_GENV: Genv.match_genvs (match_globdef (fun cu f tf => transf_fundef (romem_for cu) f = OK tf) eq prog) ge tge).

Lemma symbols_preserved:
  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
Proof (Genv.find_symbol_match_genv MATCH_GENV).

Lemma senv_preserved:
  Senv.equiv ge tge.
Proof (Genv.senv_match_genv MATCH_GENV).

Lemma functions_translated:
  forall (v: val) (f: RTL.fundef),
  Genv.find_funct ge v = Some f ->
  exists cu tf,
  Genv.find_funct tge v = Some tf /\ transf_fundef (romem_for cu) f = OK tf /\ linkorder cu prog.
Proof (Genv.find_funct_match_genv MATCH_GENV).

Lemma function_ptr_translated:
  forall (b: block) (f: RTL.fundef),
  Genv.find_funct_ptr ge b = Some f ->
  exists cu tf,
  Genv.find_funct_ptr tge b = Some tf /\ transf_fundef (romem_for cu) f = OK tf /\ linkorder cu prog.
Proof (Genv.find_funct_ptr_match_genv MATCH_GENV).

Lemma sig_function_translated:
  forall rm f tf,
  transf_fundef rm f = OK tf ->
  funsig tf = funsig f.
Proof.
  intros; destruct f; monadInv H.
  unfold transf_function in EQ.
  destruct (analyze (ValueAnalysis.analyze rm f) f); inv EQ; auto.
  auto.
Qed.

Lemma stacksize_translated:
  forall rm f tf,
  transf_function rm f = OK tf -> tf.(fn_stacksize) = f.(fn_stacksize).
Proof.
  unfold transf_function; intros. destruct (analyze (ValueAnalysis.analyze rm f) f); inv H; auto.
Qed.

Definition vanalyze (cu: program) (f: function) :=
  ValueAnalysis.analyze (romem_for cu) f.

Lemma transf_function_at:
  forall cu f tf an pc instr,
  transf_function (romem_for cu) f = OK tf ->
  analyze (vanalyze cu f) f = Some an ->
  f.(fn_code)!pc = Some instr ->
  tf.(fn_code)!pc = Some(transf_instr (vanalyze cu f) an pc instr).
Proof.
  intros. unfold transf_function in H. unfold vanalyze in H0. rewrite H0 in H. inv H; simpl.
  rewrite PTree.gmap. rewrite H1; auto.
Qed.

Lemma is_dead_sound_1:
  forall nv, is_dead nv = true -> nv = Nothing.
Proof.
  destruct nv; simpl; congruence.
Qed.

Lemma is_dead_sound_2:
  forall nv, is_dead nv = false -> nv <> Nothing.
Proof.
  intros; red; intros. subst nv; discriminate.
Qed.

Hint Resolve is_dead_sound_1 is_dead_sound_2: na.

Lemma is_int_zero_sound:
  forall nv, is_int_zero nv = true -> nv = I Int.zero.
Proof.
  unfold is_int_zero; destruct nv; try discriminate.
  predSpec Int.eq Int.eq_spec m Int.zero; congruence.
Qed.

Lemma find_function_translated:
  forall ros rs fptr trs ne,
  find_function_ptr ge ros rs = fptr ->
  eagree rs trs (add_ros_need_all ros ne) ->
  exists tfptr,
    find_function_ptr tge ros trs = tfptr
    /\ Val.lessdef fptr tfptr.
Proof.
  intros. destruct ros as [r|id]; simpl in *.
- assert (LD: Val.lessdef rs#r trs#r) by eauto with na. inv LD.
  { eauto. } { rewrite <- H2. eauto. }
- rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try discriminate.
  { eauto. } { rewrite <- H. eauto. }
Qed.

(** * Semantic invariant *)

Inductive match_stackframes: stackframe -> stackframe -> Prop :=
  | match_stackframes_intro:
      forall res f sp pc e tf te cu an
        (LINK: linkorder cu prog)
        (FUN: transf_function (romem_for cu) f = OK tf)
        (ANL: analyze (vanalyze cu f) f = Some an)
        (RES: forall v tv,
              Val.lessdef v tv ->
              eagree (e#res <- v) (te#res<- tv)
                     (fst (transfer f (vanalyze cu f) pc an!!pc))),
      match_stackframes (Stackframe res f (Vptr sp Ptrofs.zero) pc e)
                        (Stackframe res tf (Vptr sp Ptrofs.zero) pc te).

Inductive match_states: state -> state -> Prop :=
  | match_regular_states:
      forall s f sp pc e m ts tf te tm cu an
        (STACKS: list_forall2 match_stackframes s ts)
        (LINK: linkorder cu prog)
        (FUN: transf_function (romem_for cu) f = OK tf)
        (ANL: analyze (vanalyze cu f) f = Some an)
        (ENV: eagree e te (fst (transfer f (vanalyze cu f) pc an!!pc)))
        (MEM: magree m tm (nlive ge sp (snd (transfer f (vanalyze cu f) pc an!!pc)))),
      match_states (State s f (Vptr sp Ptrofs.zero) pc e m)
                   (State ts tf (Vptr sp Ptrofs.zero) pc te tm)
  | match_call_states:
      forall s fptr args m ts tfptr targs tm sg
        (STACKS: list_forall2 match_stackframes s ts)
        (FPTR: Val.lessdef fptr tfptr)
        (ARGS: Val.lessdef_list args targs)
        (MEM: Mem.extends m tm),
      match_states (Callstate s fptr sg args m)
                   (Callstate ts tfptr sg targs tm)
  | match_return_states:
      forall s v m ts tv tm
        (STACKS: list_forall2 match_stackframes s ts)
        (RES: Val.lessdef v tv)
        (MEM: Mem.extends m tm),
      match_states (Returnstate s v m)
                   (Returnstate ts tv tm).

(** [match_states] and CFG successors *)

Lemma analyze_successors:
  forall cu f an pc instr pc',
  analyze (vanalyze cu f) f = Some an ->
  f.(fn_code)!pc = Some instr ->
  In pc' (successors_instr instr) ->
  NA.ge an!!pc (transfer f (vanalyze cu f) pc' an!!pc').
Proof.
  intros. eapply DS.fixpoint_solution; eauto.
  intros. unfold transfer; rewrite H2. destruct a. apply DS.L.eq_refl.
Qed.

Lemma match_succ_states:
  forall s f sp pc e m ts tf te tm an pc' cu instr ne nm
    (LINK: linkorder cu prog)
    (STACKS: list_forall2 match_stackframes s ts)
    (FUN: transf_function (romem_for cu) f = OK tf)
    (ANL: analyze (vanalyze cu f) f = Some an)
    (INSTR: f.(fn_code)!pc = Some instr)
    (SUCC: In pc' (successors_instr instr))
    (ANPC: an!!pc = (ne, nm))
    (ENV: eagree e te ne)
    (MEM: magree m tm (nlive ge sp nm)),
  match_states (State s f (Vptr sp Ptrofs.zero) pc' e m)
               (State ts tf (Vptr sp Ptrofs.zero) pc' te tm).
Proof.
  intros. exploit analyze_successors; eauto. rewrite ANPC; simpl. intros [A B].
  econstructor; eauto.
  eapply eagree_ge; eauto.
  eapply magree_monotone; eauto.
Qed.

(** Builtin arguments and results *)

Lemma eagree_set_res:
  forall e1 e2 v1 v2 res ne,
  Val.lessdef v1 v2 ->
  eagree e1 e2 (kill_builtin_res res ne) ->
  eagree (regmap_setres res v1 e1) (regmap_setres res v2 e2) ne.
Proof.
  intros. destruct res; simpl in *; auto.
  apply eagree_update; eauto. apply vagree_lessdef; auto.
Qed.

Lemma transfer_builtin_arg_sound:
  forall bc e e' sp m m' a v,
  eval_builtin_arg ge (fun r => e#r) (Vptr sp Ptrofs.zero) m a v ->
  forall nv ne1 nm1 ne2 nm2,
  transfer_builtin_arg nv (ne1, nm1) a = (ne2, nm2) ->
  eagree e e' ne2 ->
  magree m m' (nlive ge sp nm2) ->
  genv_match bc ge ->
  bc sp = BCstack ->
  exists v',
     eval_builtin_arg ge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' a  v'
  /\ vagree v v' nv
  /\ eagree e e' ne1
  /\ magree m m' (nlive ge sp nm1).
Proof.
  induction 1; simpl; intros until nm2; intros TR EA MA GM SPM; inv TR.
- exists e'#x; intuition auto. constructor. eauto 2 with na. eauto 2 with na.
- exists (Vint n); intuition auto. constructor. apply vagree_same.
- exists (Vlong n); intuition auto. constructor. apply vagree_same.
- exists (Vfloat n); intuition auto. constructor. apply vagree_same.
- exists (Vsingle n); intuition auto. constructor. apply vagree_same.
- simpl in H. exploit magree_load; eauto.
  intros. eapply nlive_add; eauto with va. rewrite Ptrofs.add_zero_l in H0; auto.
  intros (v' & A & B).
  exists v'; intuition auto. constructor; auto. apply vagree_lessdef; auto.
  eapply magree_monotone; eauto. intros; eapply incl_nmem_add; eauto.
- exists (Vptr sp (Ptrofs.add Ptrofs.zero ofs)); intuition auto with na. constructor.
- unfold Senv.symbol_address in H; simpl in H.
  destruct (Genv.find_symbol ge id) as [b|] eqn:FS; simpl in H; try discriminate.
  exploit magree_load; eauto.
  intros. eapply nlive_add; eauto. constructor. apply GM; auto.
  intros (v' & A & B).
  exists v'; intuition auto.
  constructor. simpl. unfold Senv.symbol_address; simpl; rewrite FS; auto.
  apply vagree_lessdef; auto.
  eapply magree_monotone; eauto. intros; eapply incl_nmem_add; eauto.
- exists (Senv.symbol_address ge id ofs); intuition auto with na. constructor.
- destruct (transfer_builtin_arg All (ne1, nm1) hi) as [ne' nm'] eqn:TR.
  exploit IHeval_builtin_arg2; eauto. intros (vlo' & A & B & C & D).
  exploit IHeval_builtin_arg1; eauto. intros (vhi' & P & Q & R & S).
  exists (Val.longofwords vhi' vlo'); intuition auto.
  constructor; auto.
  apply vagree_lessdef.
  apply Val.longofwords_lessdef; apply lessdef_vagree; auto.
- destruct (transfer_builtin_arg All (ne1, nm1) a1) as [ne' nm'] eqn:TR.
  exploit IHeval_builtin_arg2; eauto. intros (v2' & A & B & C & D).
  exploit IHeval_builtin_arg1; eauto. intros (v1' & P & Q & R & S).
  econstructor; intuition auto.
  econstructor; eauto.
  destruct Archi.ptr64; auto using Val.add_lessdef, Val.addl_lessdef, vagree_lessdef, lessdef_vagree.
Qed.

Lemma transfer_builtin_args_sound:
  forall e sp m e' m' bc al vl,
  eval_builtin_args ge (fun r => e#r) (Vptr sp Ptrofs.zero) m al vl ->
  forall ne1 nm1 ne2 nm2,
  transfer_builtin_args (ne1, nm1) al = (ne2, nm2) ->
  eagree e e' ne2 ->
  magree m m' (nlive ge sp nm2) ->
  genv_match bc ge ->
  bc sp = BCstack ->
  exists vl',
     eval_builtin_args ge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' al vl'
  /\ Val.lessdef_list vl vl'
  /\ eagree e e' ne1
  /\ magree m m' (nlive ge sp nm1).
Proof.
Local Opaque transfer_builtin_arg.
  induction 1; simpl; intros.
- inv H. exists (@nil val); intuition auto. constructor.
- destruct (transfer_builtin_arg All (ne1, nm1) a1) as [ne' nm'] eqn:TR.
  exploit IHlist_forall2; eauto. intros (vs' & A1 & B1 & C1 & D1).
  exploit transfer_builtin_arg_sound; eauto. intros (v1' & A2 & B2 & C2 & D2).
  exists (v1' :: vs'); intuition auto. constructor; auto.
Qed.

Lemma can_eval_builtin_arg:
  forall sp e m e' m' P,
  magree m m' P ->
  forall a v,
  eval_builtin_arg ge (fun r => e#r) (Vptr sp Ptrofs.zero) m a v ->
  exists v', eval_builtin_arg tge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' a v'.
Proof.
  intros until P; intros MA.
  assert (LD: forall chunk addr v,
              Mem.loadv chunk m addr = Some v ->
              exists v', Mem.loadv chunk m' addr = Some v').
  {
    intros. destruct addr; simpl in H; try discriminate.
    eapply Mem.valid_access_load. eapply magree_valid_access; eauto.
    eapply Mem.load_valid_access; eauto. }
  induction 1; try (econstructor; now constructor).
- exploit LD; eauto. intros (v' & A). exists v'; constructor; auto.
- exploit LD; eauto. intros (v' & A). exists v'; constructor.
  unfold Senv.symbol_address, Senv.find_symbol. rewrite symbols_preserved. assumption.
- destruct IHeval_builtin_arg1 as (v1' & A1).
  destruct IHeval_builtin_arg2 as (v2' & A2).
  exists (Val.longofwords v1' v2'); constructor; auto.
- destruct IHeval_builtin_arg1 as (v1' & A1).
  destruct IHeval_builtin_arg2 as (v2' & A2).
  econstructor; econstructor; eauto.
Qed.

Lemma can_eval_builtin_args:
  forall sp e m e' m' P,
  magree m m' P ->
  forall al vl,
  eval_builtin_args ge (fun r => e#r) (Vptr sp Ptrofs.zero) m al vl ->
  exists vl', eval_builtin_args tge (fun r => e'#r) (Vptr sp Ptrofs.zero) m' al vl'.
Proof.
  induction 2.
- exists (@nil val); constructor.
- exploit can_eval_builtin_arg; eauto. intros (v' & A).
  destruct IHlist_forall2 as (vl' & B).
  exists (v' :: vl'); constructor; eauto.
Qed.

(** Properties of volatile memory accesses *)

Lemma transf_volatile_store:
  forall v1 v2 v1' v2' m tm chunk sp nm t v m',
  volatile_store_sem chunk se (v1::v2::nil) m t v m' ->
  Val.lessdef v1 v1' ->
  vagree v2 v2' (store_argument chunk) ->
  magree m tm (nlive ge sp nm) ->
  v = Vundef /\
  exists tm', volatile_store_sem chunk se (v1'::v2'::nil) tm t Vundef tm'
           /\ magree m' tm' (nlive ge sp nm).
Proof.
  intros. inv H. split; auto.
  inv H0. inv H9.
- (* volatile *)
  exists tm; split; auto. econstructor. econstructor; eauto.
  eapply eventval_match_lessdef; eauto. apply store_argument_load_result; auto.
- (* not volatile *)
  exploit magree_store_parallel. eauto. eauto. eauto.
  instantiate (1 := nlive ge sp nm). auto.
  intros (tm' & P & Q).
  exists tm'; split. econstructor. econstructor; eauto. auto.
Qed.

Lemma eagree_set_undef:
  forall e1 e2 ne r, eagree e1 e2 ne -> eagree (e1#r <- Vundef) e2 ne.
Proof.
  intros; red; intros. rewrite PMap.gsspec. destruct (peq r0 r); auto with na.
Qed.

(** * The simulation diagram *)

Theorem step_simulation:
  forall S1 t S2, step se ge S1 t S2 ->
  forall S1', match_states S1 S1' -> (exists su0, sound_state prog ge su0 S1) ->
  exists S2', step tse tge S1' t S2' /\ match_states S2 S2'.
Proof.

Ltac TransfInstr :=
  match goal with
  | [INSTR: (fn_code _)!_ = Some _,
     FUN: transf_function _ _ = OK _,
     ANL: analyze _ _ = Some _ |- _ ] =>
       generalize (transf_function_at _ _ _ _ _ _ FUN ANL INSTR);
       let TI := fresh "TI" in
       intro TI; unfold transf_instr in TI
  end.

Ltac UseTransfer :=
  match goal with
  | [INSTR: (fn_code _)!?pc = Some _,
     ANL: analyze _ _ = Some ?an |- _ ] =>
       destruct (an!!pc) as [ne nm] eqn:ANPC;
       unfold transfer in *;
       rewrite INSTR in *;
       simpl in *
  end.

  induction 1; intros S1' MS SS; inv MS; destruct SS as [su0 SS].

- (* nop *)
  TransfInstr; UseTransfer.
  econstructor; split.
  eapply exec_Inop; eauto.
  eapply match_succ_states; eauto. simpl; auto.

- (* op *)
  TransfInstr; UseTransfer.
  destruct (is_dead (nreg ne res)) eqn:DEAD;
  [idtac|destruct (is_int_zero (nreg ne res)) eqn:INTZERO;
  [idtac|destruct (operation_is_redundant op (nreg ne res)) eqn:REDUNDANT]].
+ (* dead instruction, turned into a nop *)
  econstructor; split.
  eapply exec_Inop; eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_update_dead; auto with na.
+ (* instruction with needs = [I Int.zero], turned into a load immediate of zero. *)
  econstructor; split.
  eapply exec_Iop with (v := Vint Int.zero); eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_update; auto.
  rewrite is_int_zero_sound by auto.
  destruct v; simpl; auto. apply iagree_zero.
+ (* redundant operation *)
  destruct args.
  * (* kept as is because no arguments -- should never happen *)
  simpl in *.
  exploit needs_of_operation_sound. eapply ma_perm; eauto.
  eauto. instantiate (1 := nreg ne res). eauto with na. eauto with na. intros [tv [A B]].
  econstructor; split.
  eapply exec_Iop with (v := tv); eauto.
  rewrite <- A. apply eval_operation_preserved. exact symbols_preserved.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_update; auto.
  * (* turned into a move *)
  unfold fst in ENV. unfold snd in MEM. simpl in H0.
  assert (VA: vagree v te#r (nreg ne res)).
  { eapply operation_is_redundant_sound with (arg1' := te#r) (args' := te##args).
    eauto. eauto. exploit add_needs_vagree; eauto. }
  econstructor; split.
  eapply exec_Iop; eauto. simpl; reflexivity.
  eapply match_succ_states; eauto. simpl; auto.
  eapply eagree_update; eauto 2 with na.
+ (* preserved operation *)
  simpl in *.
  exploit needs_of_operation_sound. eapply ma_perm; eauto. eauto. eauto 2 with na. eauto with na.
  intros [tv [A B]].
  econstructor; split.
  eapply exec_Iop with (v := tv); eauto.
  rewrite <- A. apply eval_operation_preserved. exact symbols_preserved.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_update; eauto 2 with na.

- (* load *)
  TransfInstr; UseTransfer.
  destruct (is_dead (nreg ne dst)) eqn:DEAD;
  [idtac|destruct (is_int_zero (nreg ne dst)) eqn:INTZERO];
  simpl in *.
+ (* dead instruction, turned into a nop *)
  econstructor; split.
  eapply exec_Inop; eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_update_dead; auto with na.
+ (* instruction with needs = [I Int.zero], turned into a load immediate of zero. *)
  econstructor; split.
  eapply exec_Iop with (v := Vint Int.zero); eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_update; auto.
  rewrite is_int_zero_sound by auto.
  destruct v; simpl; auto. apply iagree_zero.
+ (* preserved *)
  exploit eval_addressing_lessdef. eapply add_needs_all_lessdef; eauto. eauto.
  intros (ta & U & V). inv V; try discriminate.
  destruct ta; simpl in H1; try discriminate.
  exploit magree_load; eauto.
  exploit aaddressing_sound; eauto. intros (bc & A & B & C).
  intros. apply nlive_add with bc i; assumption.
  intros (tv & P & Q).
  econstructor; split.
  eapply exec_Iload with (a := Vptr b i). eauto.
  rewrite <- U. apply eval_addressing_preserved. exact symbols_preserved.
  eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_update; eauto 2 with na.
  eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto.

- (* store *)
  TransfInstr; UseTransfer.
  destruct (nmem_contains nm (aaddressing (vanalyze cu f) # pc addr args)
             (size_chunk chunk)) eqn:CONTAINS.
+ (* preserved *)
  simpl in *.
  exploit eval_addressing_lessdef. eapply add_needs_all_lessdef; eauto. eauto.
  intros (ta & U & V). inv V; try discriminate.
  destruct ta; simpl in H1; try discriminate.
  exploit magree_store_parallel. eauto. eauto. instantiate (1 := te#src). eauto with na.
  instantiate (1 := nlive ge sp0 nm).
  exploit aaddressing_sound; eauto. intros (bc & A & B & C).
  intros. apply nlive_remove with bc b i; assumption.
  intros (tm' & P & Q).
  econstructor; split.
  eapply exec_Istore with (a := Vptr b i). eauto.
  rewrite <- U. apply eval_addressing_preserved. exact symbols_preserved.
  eauto.
  eapply match_succ_states; eauto. simpl; auto.
  eauto 3 with na.
+ (* dead instruction, turned into a nop *)
  destruct a; simpl in H1; try discriminate.
  econstructor; split.
  eapply exec_Inop; eauto.
  eapply match_succ_states; eauto. simpl; auto.
  eapply magree_store_left; eauto.
  exploit aaddressing_sound; eauto. intros (bc & A & B & C).
  intros. eapply nlive_contains; eauto.

- (* call *)
  TransfInstr; UseTransfer.
  exploit find_function_translated; eauto 2 with na. intros (tfptr & A & B).
  econstructor; split.
  eapply exec_Icall; eauto. econstructor.
  eapply match_call_states; eauto.
  constructor; auto. eapply match_stackframes_intro with (cu := cu); eauto.
  intros.
  edestruct analyze_successors; eauto. simpl; eauto.
  eapply eagree_ge; eauto. rewrite ANPC. simpl.
  apply eagree_update; eauto with na.
  { inversion FPTR. rewrite A. apply B. }
  eauto 2 with na.
  eapply magree_extends; eauto. apply nlive_all.

- (* tailcall *)
  TransfInstr; UseTransfer.
  exploit find_function_translated; eauto 2 with na. intros (tfptr & A & B).
  exploit magree_free. eauto. eauto. instantiate (1 := nlive ge stk nmem_all).
  intros; eapply nlive_dead_stack; eauto.
  intros (tm' & C & D).
  econstructor; split.
  eapply exec_Itailcall; eauto. econstructor.
  erewrite stacksize_translated by eauto. eexact C.
  eapply match_call_states; eauto 2 with na.
  { inversion FPTR. rewrite A. apply B. }
  eapply magree_extends; eauto. apply nlive_all.

- (* builtin *)
  TransfInstr; UseTransfer. revert ENV MEM TI.
  functional induction (transfer_builtin (vanalyze cu f)#pc ef args res ne nm);
  simpl in *; intros.
+ (* volatile load *)
  inv H0. inv H6. rename b1 into v1.
  destruct (transfer_builtin_arg All
              (kill_builtin_res res ne,
              nmem_add nm (aaddr_arg (vanalyze cu f) # pc a1)
                (size_chunk chunk)) a1) as (ne1, nm1) eqn: TR.
  InvSoundState. exploit transfer_builtin_arg_sound; eauto.
  intros (tv1 & A & B & C & D).
  inv H1. simpl in B. inv B.
  assert (X: exists tvres, volatile_load se chunk tm b ofs t tvres /\ Val.lessdef vres tvres).
  {
    inv H2.
  * exists (Val.load_result chunk v); split; auto. constructor; auto.
  * exploit magree_load; eauto.
    exploit aaddr_arg_sound_1; eauto. rewrite <- AN. intros.
    intros. eapply nlive_add; eassumption.
    intros (tv & P & Q).
    exists tv; split; auto. constructor; auto.
  }
  destruct X as (tvres & P & Q).
  econstructor; split.
  eapply exec_Ibuiltin; eauto.
  apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved.
  constructor. eauto. constructor.
  eapply external_call_symbols_preserved. apply MATCH_SENV.
  constructor. simpl. eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_set_res; auto.
  eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto.
+ (* volatile store *)
  inv H0. inv H6. inv H7. rename b1 into v1. rename b0 into v2.
  destruct (transfer_builtin_arg (store_argument chunk)
              (kill_builtin_res res ne, nm) a2) as (ne2, nm2) eqn: TR2.
  destruct (transfer_builtin_arg All (ne2, nm2) a1) as (ne1, nm1) eqn: TR1.
  InvSoundState.
  exploit transfer_builtin_arg_sound. eexact H4. eauto. eauto. eauto. eauto. eauto.
  intros (tv1 & A1 & B1 & C1 & D1).
  exploit transfer_builtin_arg_sound. eexact H3. eauto. eauto. eauto. eauto. eauto.
  intros (tv2 & A2 & B2 & C2 & D2).
  exploit transf_volatile_store; eauto.
  intros (EQ & tm' & P & Q). subst vres.
  econstructor; split.
  eapply exec_Ibuiltin; eauto.
  apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved.
  constructor. eauto. constructor. eauto. constructor.
  eapply external_call_symbols_preserved. apply MATCH_SENV.
  simpl; eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_set_res; auto.
+ (* memcpy *)
  rewrite e1 in TI.
  inv H0. inv H6. inv H7. rename b1 into v1. rename b0 into v2.
  set (adst := aaddr_arg (vanalyze cu f) # pc dst) in *.
  set (asrc := aaddr_arg (vanalyze cu f) # pc src) in *.
  destruct (transfer_builtin_arg All
              (kill_builtin_res res ne,
               nmem_add (nmem_remove nm adst sz) asrc sz) dst)
           as (ne2, nm2) eqn: TR2.
  destruct (transfer_builtin_arg All (ne2, nm2) src) as (ne1, nm1) eqn: TR1.
  InvSoundState.
  exploit transfer_builtin_arg_sound. eexact H3. eauto. eauto. eauto. eauto. eauto.
  intros (tv1 & A1 & B1 & C1 & D1).
  exploit transfer_builtin_arg_sound. eexact H4. eauto. eauto. eauto. eauto. eauto.
  intros (tv2 & A2 & B2 & C2 & D2).
  inv H1.
  exploit magree_loadbytes. eauto. eauto.
  intros. eapply nlive_add; eauto.
  unfold asrc, vanalyze; rewrite AN; eapply aaddr_arg_sound_1; eauto.
  intros (tbytes & P & Q).
  exploit magree_storebytes_parallel.
  eapply magree_monotone. eexact D2.
  instantiate (1 := nlive ge sp0 (nmem_remove nm adst sz)).
  intros. apply incl_nmem_add; auto.
  eauto.
  instantiate (1 := nlive ge sp0 nm).
  intros. eapply nlive_remove; eauto.
  unfold adst, vanalyze; rewrite AN; eapply aaddr_arg_sound_1; eauto.
  erewrite Mem.loadbytes_length in H1 by eauto.
  rewrite Z2Nat.id in H1 by omega. auto.
  eauto.
  intros (tm' & A & B).
  econstructor; split.
  eapply exec_Ibuiltin; eauto.
  apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved.
  constructor. eauto. constructor. eauto. constructor.
  eapply external_call_symbols_preserved. apply MATCH_SENV.
  simpl in B1; inv B1. simpl in B2; inv B2. econstructor; eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_set_res; auto.
+ (* memcpy eliminated *)
  rewrite e1 in TI.
  inv H0. inv H6. inv H7. rename b1 into v1. rename b0 into v2.
  set (adst := aaddr_arg (vanalyze cu f) # pc dst) in *.
  set (asrc := aaddr_arg (vanalyze cu f) # pc src) in *.
  inv H1.
  econstructor; split.
  eapply exec_Inop; eauto.
  eapply match_succ_states; eauto. simpl; auto.
  destruct res; auto. apply eagree_set_undef; auto.
  eapply magree_storebytes_left; eauto.
  clear H3.
  exploit aaddr_arg_sound; eauto.
  intros (bc & A & B & C).
  intros. eapply nlive_contains; eauto.
  erewrite Mem.loadbytes_length in H0 by eauto.
  rewrite Z2Nat.id in H0 by omega. auto.
+ (* annot *)
  destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR.
  InvSoundState.
  exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D).
  inv H1.
  econstructor; split.
  eapply exec_Ibuiltin; eauto.
  apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
  eapply external_call_symbols_preserved. apply MATCH_SENV.
  constructor. eapply eventval_list_match_lessdef; eauto 2 with na.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_set_res; auto.
+ (* annot val *)
  destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR.
  InvSoundState.
  exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D).
  inv H1. inv B. inv H6.
  econstructor; split.
  eapply exec_Ibuiltin; eauto.
  apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
  eapply external_call_symbols_preserved. apply MATCH_SENV.
  constructor.
  eapply eventval_match_lessdef; eauto 2 with na.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_set_res; auto.
+ (* debug *)
  inv H1.
  exploit can_eval_builtin_args; eauto. intros (vargs' & A).
  econstructor; split.
  eapply exec_Ibuiltin; eauto. constructor.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_set_res; auto.
+ (* all other builtins *)
  assert ((fn_code tf)!pc = Some(Ibuiltin _x _x0 res pc')).
  {
    destruct _x; auto. destruct _x0; auto. destruct _x0; auto. destruct _x0; auto. contradiction.
  }
  clear y TI.
  destruct (transfer_builtin_args (kill_builtin_res res ne, nmem_all) _x0) as (ne1, nm1) eqn:TR.
  InvSoundState.
  exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D).
  exploit external_call_mem_extends; eauto 2 with na.
  eapply magree_extends; eauto. intros. apply nlive_all.
  intros (v' & tm' & P & Q & R & S).
  econstructor; split.
  eapply exec_Ibuiltin; eauto.
  apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
  eapply external_call_symbols_preserved. apply MATCH_SENV. eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_set_res; auto.
  eapply mextends_agree; eauto.

- (* conditional *)
  TransfInstr; UseTransfer. destruct (peq ifso ifnot).
+ replace (if b then ifso else ifnot) with ifso by (destruct b; congruence).
  econstructor; split.
  eapply exec_Inop; eauto.
  eapply match_succ_states; eauto. simpl; auto.
+ econstructor; split.
  eapply exec_Icond; eauto.
  eapply needs_of_condition_sound. eapply ma_perm; eauto. eauto. eauto with na.
  eapply match_succ_states; eauto 2 with na.
  simpl; destruct b; auto.

- (* jumptable *)
  TransfInstr; UseTransfer.
  assert (LD: Val.lessdef rs#arg te#arg) by eauto 2 with na.
  rewrite H0 in LD. inv LD.
  econstructor; split.
  eapply exec_Ijumptable; eauto.
  eapply match_succ_states; eauto 2 with na.
  simpl. eapply list_nth_z_in; eauto.

- (* return *)
  TransfInstr; UseTransfer.
  exploit magree_free. eauto. eauto. instantiate (1 := nlive ge stk nmem_all).
  intros; eapply nlive_dead_stack; eauto.
  intros (tm' & A & B).
  econstructor; split.
  eapply exec_Ireturn; eauto.
  erewrite stacksize_translated by eauto. eexact A.
  constructor; auto.
  destruct or; simpl; eauto 2 with na.
  eapply magree_extends; eauto. apply nlive_all.

- (* internal function *)
  exploit functions_translated; eauto. intros [cu [tf [FPTR' [FUN LINK]]]].
  assert (fptr = tfptr).
  { eapply find_funct_lessdef; eauto. }
  monadInv FUN. generalize EQ. unfold transf_function. fold (vanalyze cu f). intros EQ'.
  destruct (analyze (vanalyze cu f) f) as [an|] eqn:AN; inv EQ'.
  exploit Mem.alloc_extends; eauto. apply Z.le_refl. apply Z.le_refl.
  intros (tm' & A & B).
  econstructor; split.
  econstructor; simpl; eauto.
  simpl. econstructor; eauto.
  apply eagree_init_regs; auto.
  apply mextends_agree; auto.

- (* external function *)
  exploit functions_translated; eauto. intros [cu [tf [FPTR' [FUN LINK]]]].
  assert (fptr = tfptr).
  { eapply find_funct_lessdef; eauto. }
  exploit external_call_mem_extends; eauto.
  intros (res' & tm' & A & B & C & D).
  simpl in FUN. inv FUN.
  econstructor; split.
  econstructor; eauto.
  eapply external_call_symbols_preserved; eauto.
  econstructor; eauto.

- (* return *)
  inv STACKS. inv H1.
  econstructor; split.
  constructor.
  econstructor; eauto. apply mextends_agree; auto.
Qed.

End CORELEMMA.

Section WHOLE.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Let MATCH_GENV: Genv.match_genvs (match_globdef (fun cu f tf => transf_fundef (romem_for cu) f = OK tf) eq prog) ge tge.
Proof. apply Genv.globalenvs_match; auto. Qed.

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists st2, initial_state tprog st2 /\ match_states ge st1 st2.
Proof.
  intros. inversion H.
  exists (Callstate nil (Vptr b Ptrofs.zero) signature_main nil m0); split.
  econstructor; eauto.
  eapply (Genv.init_mem_match TRANSF); eauto.
  replace (prog_main tprog) with (prog_main prog).
  erewrite symbols_preserved; eauto.
  symmetry; eapply match_program_main; eauto.
  econstructor; eauto. constructor. apply Mem.extends_refl.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states ge st1 st2 -> final_state st1 r -> final_state st2 r.
Proof.
  intros. inv H0. inv H. inv STACKS. inv RES. constructor.
Qed.

(** * Semantic preservation *)

Theorem transf_program_correct:
  forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
Proof.
  intros.
  apply forward_simulation_step with
     (match_states := fun s1 s2 => (exists su0, sound_state prog ge su0 s1) /\ match_states ge s1 s2).
- apply senv_preserved; eauto.
- simpl; intros. exploit transf_initial_states; eauto. intros [st2 [A B]].
  exists st2; intuition. eapply sound_initial; eauto.
- simpl; intros. destruct H. eapply transf_final_states; eauto.
- simpl; intros. destruct H0.
  destruct H0 as [su0 SS].
  assert (sound_state prog ge su0 s1') by (eapply sound_step; eauto).
  fold ge; fold tge. exploit step_simulation; eauto. { apply senv_preserved; eauto. } intros [st2' [A B]].
  exists st2'; auto. esplits; eauto.
Qed.

End WHOLE.

End PRESERVATION.


Set Implicit Arguments.

Require Import Platform.Cito.ADT.

Module Make (Import E : ADT).

  Require Import Platform.Cito.Inv.
  Module Import InvMake := Make E.
  Import Semantics.
  Import SemanticsMake.
  Require Import Platform.Cito.WordMap.
  Require Import Coq.FSets.FMapFacts.
  Module Properties := Properties WordMap.
  Module Facts := Facts WordMap.

  Require Import Platform.Cito.RepInv.

  Module Make(R : RepInv E).
    Module Import Inner := InvMake.Make(R).

    Require Import Platform.Cito.LayoutHintsUtil.
    Require Import Platform.Cito.SemanticsFacts5.

    Lemma is_heap_Equal : forall h h',
      WordMap.Equal h h'
      -> is_heap h ===> is_heap h'.
      intros; apply starL_permute; unfold heap_elements; intuition.
      apply NoDupA_NoDup; apply WordMap.elements_3w.
      apply NoDupA_NoDup; apply WordMap.elements_3w.

      apply In_InA' in H0.
      apply InA_In.
      apply Properties.F.elements_mapsto_iff in H0.
      apply Properties.F.elements_mapsto_iff.
      eapply Properties.F.Equal_mapsto_iff; eauto.
      apply Properties.F.Equal_sym; auto.

      apply In_InA' in H0.
      apply InA_In.
      apply Properties.F.elements_mapsto_iff in H0.
      apply Properties.F.elements_mapsto_iff.
      eapply Properties.F.Equal_mapsto_iff; eauto.
    Qed.

  End Make.

End Make.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require Import oeuf.ListLemmas.

Inductive expr :=
| Arg
| Self
| Var (i : nat)
| Deref (e : expr) (off : nat)
.

Inductive stmt :=
| Skip
| Seq (s1 : stmt) (s2 : stmt)
| Call (dst : nat) (f : expr) (a : expr)
| MkConstr (dst : nat) (tag : nat) (args : list expr)
| Switch (dst : nat) (cases : list stmt)
| MkClose (dst : nat) (f : function_name) (free : list expr)
| OpaqueOp (dst : nat) (op : opaque_oper_name) (args : list expr)
| Assign (dst : nat) (e : expr)
.

Definition env := list (stmt * expr).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    locals : list (nat * value)
}.

Definition set f l v :=
    Frame (arg f) (self f) ((l, v) :: locals f).

Definition local f l := lookup (locals f) l.

Inductive cont :=
| Kseq (code : stmt) (k : cont)
| Kswitch (k : cont)
| Kreturn (ret : expr) (k : cont)
| Kcall (dst : nat) (f : frame) (k : cont)
| Kstop.

Inductive state :=
| Run (s : stmt) (f : frame) (k : cont)
| Return (v : value) (k : cont).

Inductive eval : frame -> expr -> value -> Prop :=
| EArg : forall f,
        eval f Arg (arg f)
| ESelf : forall f,
        eval f Self (self f)

| EVar : forall f i v,
        local f i = Some v ->
        eval f (Var i) v

| EDerefConstr : forall f e off tag args v,
        eval f e (Constr tag args) ->
        nth_error args off = Some v ->
        eval f (Deref e off) v
| EDerefClose : forall f e off fname free v,
        eval f e (Close fname free) ->
        nth_error free off = Some v ->
        eval f (Deref e off) v
.

Inductive sstep (E : env) : state -> state -> Prop :=
| SSeq : forall s1 s2 f k,
        sstep E (Run (Seq s1 s2) f k)
                (Run s1 f (Kseq s2 k))

| SConstrDone : forall dst tag args f k vs,
        Forall2 (eval f) args vs ->
        sstep E (Run (MkConstr dst tag args) f k)
                (Run Skip (set f dst (Constr tag vs)) k)
| SCloseDone : forall dst fname free f k vs,
        Forall2 (eval f) free vs ->
        sstep E (Run (MkClose dst fname free) f k)
                (Run Skip (set f dst (Close fname vs)) k)
| SOpaqueOpDone : forall dst op args f k vs v,
        Forall2 (eval f) args vs ->
        opaque_oper_denote_higher op vs = Some v ->
        sstep E (Run (OpaqueOp dst op args) f k)
                (Run Skip (set f dst v) k)

| SMakeCall : forall dst fe ae f k  fname free arg body ret,
        eval f fe (Close fname free) ->
        eval f ae arg ->
        nth_error E fname = Some (body, ret) ->
        sstep E (Run (Call dst fe ae) f k)
                (Run body (Frame arg (Close fname free) [])
                    (Kreturn ret (Kcall dst f k)))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall dst cases f k  tag args case,
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run (Switch dst cases) f k)
                (Run case f (Kswitch k))

| SAssign : forall dst src f k v,
        eval f src v ->
        sstep E (Run (Assign dst src) f k)
                (Run Skip (set f dst v) k)

| SContSeq : forall f s k,
        sstep E (Run Skip f (Kseq s k))
                (Run s f k)
| SContSwitch : forall f k,
        sstep E (Run Skip f (Kswitch k))
                (Run Skip f k)
| SContReturn : forall f ret k v,
        eval f ret v ->
        sstep E (Run Skip f (Kreturn ret k))
                (Return v k)
| SContCall : forall v dst f k,
        sstep E (Return v (Kcall dst f k))
                (Run Skip (set f dst v) k)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body ret,
        nth_error (fst prog) fname = Some (body, ret) ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 (Kreturn ret Kstop)).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Return v Kstop) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*
Definition prog_type : Type := env * list metadata.

Inductive initial_state (prog : prog_type) : state -> Prop :=.

Inductive final_state (prog : prog_type) : state -> Prop :=
| FinalState : forall v, final_state prog (Return v Kstop).

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env
                 (sstep)
                 (initial_state prog)
                 (final_state prog)
                 (initial_env prog).

*)

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition stmt_rect_mut
        (P : stmt -> Type)
        (Pl : list stmt -> Type)
    (HSkip :    P Skip)
    (HSeq :     forall s1 s2, P s1 -> P s2 -> P (Seq s1 s2))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Pl cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HAssign :  forall dst src, P (Assign dst src))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (i : stmt) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        match i as i_ return P i_ with
        | Skip => HSkip
        | Seq s1 s2 => HSeq s1 s2 (go s1) (go s2)
        | Call dst f a => HCall dst f a
        | MkConstr dst tag args => HConstr dst tag args
        | Switch dst cases => HSwitch dst cases (go_list cases)
        | MkClose dst fname free => HClose dst fname free
        | OpaqueOp dst op args => HOpaqueOp dst op args
        | Assign dst src => HAssign dst src
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition stmt_ind' (P : stmt -> Prop)
    (HSkip :    P Skip)
    (HSeq :     forall s1 s2, P s1 -> P s2 -> P (Seq s1 s2))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Forall P cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HAssign :  forall dst src, P (Assign dst src))
    (i : stmt) : P i :=
    ltac:(refine (@stmt_rect_mut P (Forall P)
        HSkip HSeq HCall HConstr HSwitch HClose HOpaqueOp HAssign _ _ i); eauto).

Definition all_dests :=
    let fix go s :=
        let fix go_list ps :=
            match ps with
            | [] => []
            | s :: ps => go s ++ go_list ps
            end in
        match s with
        | Skip => []
        | Seq s1 s2 => go s1 ++ go s2
        | Call dst _ _ => [dst]
        | MkConstr dst _ _ => [dst]
        | Switch _ cases => go_list cases
        | MkClose dst _ _ => [dst]
        | OpaqueOp dst _ _ => [dst]
        | Assign dst _ => [dst]
        end in go.

Definition all_dests_list :=
    let go := all_dests in
    let fix go_list ps :=
        match ps with
        | [] => []
        | s :: ps => go s ++ go_list ps
        end in go_list.

Ltac refold_all_dests :=
    fold all_dests_list in *.

Definition cont_all_dests :=
    let go := all_dests in
    let fix go_cont k :=
        match k with
        | Kseq s k => go s ++ go_cont k
        | Kswitch k => go_cont k
        | Kreturn _ k => go_cont k
        | Kcall dst _ k => []
        | Kstop => []
        end in go_cont.

Definition dests_ok :=
    let fix go s :=
        let fix go_list ps :=
            match ps with
            | [] => True
            | s :: ps => go s /\ go_list ps
            end in
        match s with
        | Seq s1 s2 => go s1 /\ go s2 /\ disjoint (all_dests s1) (all_dests s2)
        | Switch _ cases => go_list cases
        | _ => True
        end in go.

Definition dests_ok_list :=
    let go := dests_ok in
    let fix go_list ps :=
        match ps with
        | [] => True
        | s :: ps => go s /\ go_list ps
        end in go_list.

Ltac refold_dests_ok :=
    fold dests_ok_list in *.

Definition check_dests_ok s : { dests_ok s } + { ~ dests_ok s }.
induction s using stmt_rect_mut with
    (Pl := fun cases =>
        { dests_ok_list cases } + { ~ dests_ok_list cases });
try solve [left; constructor].

- (* Seq *)
  destruct IHs1; [ | right; intro; simpl in *; intuition ].
  destruct IHs2; [ | right; intro; simpl in *; intuition ].
  destruct (disjoint_dec eq_nat_dec (all_dests s1) (all_dests s2));
    [ | right; intro; simpl in *; intuition ].
  left. simpl. auto.

- (* Switch *)
  destruct IHs; [ | right; assumption ].
  left. assumption.

- (* cons *)
  destruct IHs; [ | right; inversion 1; eauto ].
  destruct IHs0; [ | right; inversion 1; eauto ].
  left. constructor; eauto.
Defined.

Definition cont_dests_ok :=
    let go := dests_ok in
    let fix go_cont k :=
        match k with
        | Kseq s k => go s /\ go_cont k /\
                disjoint (all_dests s) (cont_all_dests k)
        | Kswitch k => go_cont k
        | Kreturn _ k => go_cont k
        | Kcall _ _ k => go_cont k
        | Kstop => True
        end in go_cont.

Definition state_dests_ok :=
    let go := dests_ok in
    let go_cont := cont_dests_ok in
    let go_state s :=
        match s with
        | Run s _ k => go s /\ go_cont k /\
                disjoint (all_dests s) (cont_all_dests k)
        | Return _ k => go_cont k
        end in go_state.

Lemma step_dests_ok : forall E s s',
    Forall (fun f => dests_ok (fst f)) E ->
    state_dests_ok s ->
    sstep E s s' ->
    state_dests_ok s'.
intros0 Henv II Hstep; invc Hstep;
simpl in *; refold_all_dests; refold_dests_ok.

- repeat break_and. on _, invc_using disjoint_app_inv_l.
  intuition. eauto using disjoint_app_r.

- intuition.
- intuition.
- intuition.
- fwd eapply Forall_nth_error; eauto. simpl in *. intuition.

- break_and.
  on (arg _ = _), fun H => clear H.
  generalize dependent cases. make_first cases. induction cases; intros; simpl in *.
  + destruct tag; discriminate.
  + destruct tag; simpl in *.
    * inject_some. on _, invc_using disjoint_app_inv_l. intuition.
    * on _, invc_using disjoint_app_inv_l. break_and. eapply IHcases; eauto.

- intuition.
- intuition.
- intuition.
- intuition.
- intuition.
Qed.

Lemma all_dests_list_disjoint : forall xs cases n case,
    disjoint xs (all_dests_list cases) ->
    nth_error cases n = Some case ->
    disjoint xs (all_dests case).
induction cases; intros0 Hdj Hnth; simpl in *.
- destruct n; discriminate.
- on _, invc_using disjoint_app_inv_r.
  destruct n; simpl in *.
  + inject_some. auto.
  + eapply IHcases; eauto.
Qed.


(* Semantics and Properties of the monads *)
Require Import Events.
Require Import customSmallstep.
Require Import Integers.

Require Import common.
Require Import monad.
Require Import monad_impl.
Require Import ASMinterpreter.
Require Import jit.

(** * Loop Semantics (deprecated)  *)
(* building the semantics of a monad designed to be looped *)
Inductive loop_step {mstate prog_state:Type} (prog:prog_state -> free (prog_state * trace)) (i:monad_impl mstate) :
  unit -> (prog_state * mstate) -> trace -> (prog_state * mstate) -> Prop :=
| loop:
    forall ps1 ps2 t ms1 ms2
      (EXEC_STEP: (exec (prog ps1)) i ms1 = SOK (ps2, t) ms2),
      loop_step prog i tt (ps1, ms1) t (ps2, ms2).

(* Extending the notion of initial state, from a prog_state definition, to a full state (with monad state) *)
Inductive extend_init {mstate prog_state:Type} (init:prog_state -> Prop) (i:monad_impl mstate) :
  (prog_state * mstate) -> Prop :=
| init_extend:
    forall ps
      (INIT: init ps),
      extend_init init i (ps, init_state i).

(* extending to any monad state *)
Inductive extend_final {mstate prog_state:Type} (final:prog_state -> int -> Prop) (i:monad_impl mstate):
  (prog_state * mstate) -> int -> Prop :=
| final_extend:
    forall ps val ms
      (FINAL: final ps val),
      extend_final final i (ps, ms) val.

(* Loop Semantics given an implem *)
(* prog has the type that the jit_step would be typed with *)
Definition loop_sem {mstate prog_state:Type} (prog:prog_state -> free (prog_state * trace)) (i:monad_impl mstate) (init:prog_state -> Prop) (final:prog_state -> int -> Prop): semantics :=
  Semantics_gen (loop_step prog i) (extend_init init i) (extend_final final i) tt.

(* Forward sim proof *)
Inductive f_match {istate jstate prog_state:Type} (i:monad_impl istate) (j:monad_impl jstate) (R:refines i j): unit -> (prog_state * istate) -> (prog_state * jstate) -> Prop :=
| f_m : forall ps mi mj
          (MATCH: (match_states i j R) mi mj),
    f_match i j R tt (ps, mi) (ps, mj).

Inductive order : unit -> unit -> Prop := .
Lemma wfounded:
  well_founded order.
Proof.
  unfold well_founded. intros. destruct a. constructor. intros. inversion H.
Qed.

Lemma forward_prim:
  forall (A istate jstate R:Type) (i:monad_impl istate) (j:monad_impl jstate) a mi mi' mj
    (Ref: refines i j)
    (p: primitive R)
    (MATCH: match_states i j Ref mi mj)
    (EXEC: exec_prim p i mi = SOK a mi'),
  exists mj', exec_prim p j mj = SOK a mj' /\
         (match_states i j Ref) mi' mj'.
Proof.
  intros A istate jstate R i j a mi mi' mj Ref p MATCH EXEC.
  destruct p; inv EXEC.
  - rename H0 into Hsave. destruct a. (* save *)
    eapply (match_save i j Ref) in Hsave; eauto.
  - rename H0 into Hload. destruct a.       (* load *)
    eapply (match_load i j Ref) in Hload; eauto.
  - rename H0 into Hpusharg. destruct a. (* pusharg *)
    eapply (match_memset i j Ref) in Hpusharg; eauto.
  - rename H0 into Hpoparg. destruct a. (* poparg *)
    eapply (match_memget i j Ref) in Hpoparg; eauto.
  - rename H0 into Hclosesf. destruct a. (* closesf *)
    eapply (match_closesf i j Ref) in Hclosesf; eauto.
  - rename H0 into Hopensf. (* opensf *)
    eapply (match_opensf i j Ref) in Hopensf; eauto.
  - rename H0 into Hpushirsf. destruct a. (* pushirsf *)
    eapply (match_pushirsf i j Ref) in Hpushirsf; eauto.
  - rename H0 into Hinstall_code. destruct a. (* install_code *)
    eapply (match_install_code i j Ref) in Hinstall_code; eauto.
  - rename H0 into Hload_code. destruct a. (* load_call_code *)
    eapply (match_load_code i j Ref) in Hload_code; eauto.
  - rename H0 into Hcheck_compiled.  (* check_compiled *)
    eapply (match_check_compiled i j Ref) in Hcheck_compiled; eauto.
Qed.

Lemma forward_diagram:
  forall {A istate jstate:Type} (i:monad_impl istate) (j:monad_impl jstate) a mi mi' mj
    (R: refines i j)
    (m: free A)
    (MATCH: (match_states i j R) mi mj)
    (EXEC: exec m i mi = SOK a mi'),
  exists mj', exec m j mj = SOK a mj' /\
         (match_states i j R) mi' mj'.
Proof.
  intros A istate jstate i j a mi mi' mj R m MATCH EXEC.
  generalize dependent mi. generalize dependent mi'. generalize dependent mj. generalize dependent a.
  induction m; intros; inversion EXEC; simpl; subst.
  - exists mj. split; auto.          (* ret *)
  - rename H1 into EXEC_CONT. repeat sdo_ok. simpl in EXEC.
    unfold sbind in EXEC. rewrite HDO in EXEC. rewrite EXEC_CONT in EXEC. inv EXEC.
    eapply forward_prim in HDO; eauto. destruct HDO as [j0 [EXEC_PRIM MATCH']].
    specialize (H r a j0 mi' i0 MATCH' EXEC_CONT).
    destruct H as [mj' [EXEC_CONT' MATCH'']].
    exists mj'. unfold sbind. rewrite EXEC_PRIM. split; auto.
Qed.

Theorem loop_refinement:
  forall (prog_state istate jstate:Type) (prog:prog_state -> free (prog_state * trace))  init final
    (i:monad_impl istate) (j:monad_impl jstate)
    (R: refines i j),
    forward_simulation
      (loop_sem prog i init final)
      (loop_sem prog j init final).
Proof.
  intros prog_state istate jstate prog init final i j R.
  eapply Forward_simulation.
  - apply wfounded.
  - intros s1 H. exists tt. simpl in H. inversion H.
    exists (ps, init_state j). split; simpl.
    + constructor. auto.
    + eapply (f_m i j R). apply (match_init i j R).
  - intros tt s1 s2 r H H0. simpl in s1, s2. destruct s1 as [ps1 mi1]. destruct s2 as [ps mi2].
    inversion H. subst. simpl. constructor. inversion H0. auto.
  - intros s1 t s1' H i0 s2 H0. simpl in s1, s1'. destruct s1 as [ps1 mi1]. destruct s1' as [ps1' mi1'].
    inversion H0. subst. exists tt. inversion H. subst.
    eapply forward_diagram in EXEC_STEP; eauto.
    destruct EXEC_STEP as [mj' [EXEC' MATCH']].
    exists (ps1', mj'). split; auto.
    + left. apply plus_one. constructor. auto.
    + constructor. auto.
Qed.

(** * Giving Semantics the Non-Atomic step of a NASM  *)
Record na_spec {state I R:Type}: Type :=
  mk_spec {
      load_: state -> free I;
      step_: I -> free (trace * itret R I);
      ret_ : state -> R -> free state
    }.
(* I defines the type of intermediate states *)
(* R represents the return value type of the internal iteration *)

(** * Unfolded Semantics  *)
Inductive unf_state {S I:Type} :=
| EXT: S -> unf_state       (* when we're executing the main program *)
| INT: S -> I -> unf_state.       (* when we're executing the non-atomic loop. we remember the calling S state *)

Inductive unf_step {state mstate I R:Type} (prog: @nasm_prog state) (impl:monad_impl mstate) (spec: @na_spec state I R):
  unit -> (@unf_state state I * mstate) -> trace -> (@unf_state state I * mstate) -> Prop :=
| ext_step:
    forall (s1 s2:state) t ms1 ms2 symbmon
      (ATOMIC: prog s1 = Ato symbmon)
      (EXEC_STEP: exec symbmon impl ms1 = SOK (t, s2) ms2),
      unf_step prog impl spec tt (EXT s1, ms1) t (EXT s2, ms2)
| loop_start:
    forall s1 ms1 start ms2
      (RUN: prog s1 = LoadAndRun)
      (LOAD: exec (load_ spec s1) impl ms1 = SOK start ms2),
      unf_step prog impl spec tt (EXT s1, ms1) E0 (INT s1 start, ms2)
| int_step:
    forall i1 t i2 ms1 ms2 call_state
      (EXEC_STEP: exec (step_ spec i1) impl ms1 = SOK (t, Halt i2) ms2),
      unf_step prog impl spec tt (INT call_state i1, ms1) t (INT call_state i2, ms2)
| loop_end:
    forall i1 t r s2 ms1 ms2 ms3 call_state
      (EXEC_END: exec (step_ spec i1) impl ms1 = SOK (t, Done r) ms2)
      (EXEC_RET: exec (ret_ spec call_state r) impl ms2 = SOK (s2) ms3),
      unf_step prog impl spec tt (INT call_state i1, ms1) t (EXT s2, ms3).

(* Liftinf initial and final from state to unf_state *)
Inductive init_unf_state {state mstate I:Type} (init:state -> Prop) (impl:monad_impl mstate) : (@unf_state state I  * mstate) -> Prop :=
| init_unf: forall s
              (INIT: init s),
    init_unf_state init impl (EXT s, init_state impl).

Inductive final_unf_state {state mstate I:Type} (final:state -> int -> Prop) (impl:monad_impl mstate) : (@unf_state state I * mstate) -> int -> Prop :=
| final_unf: forall s ms r
               (FINAL: final s r),
    final_unf_state final impl (EXT s, ms) r.

Definition unf_sem {state mstate I R:Type} (prog: @nasm_prog state) (impl:monad_impl mstate) (spec: @na_spec state I R) (init:state->Prop) (final:state->int->Prop): semantics :=
  Semantics_gen (unf_step prog impl spec) (init_unf_state init impl) (final_unf_state final impl) tt.

(** * Refinement Simulation  *)
(* Forward sim proof *)

Theorem refinement:
  forall (state istate jstate I R:Type) (prog: @nasm_prog state) init final
    (i: monad_impl istate) (j:monad_impl jstate) (spec: @na_spec state I R)
    (Ref: refines i j),
    forward_simulation
      (unf_sem prog i spec init final)
      (unf_sem prog j spec init final).
Proof.
  intros state istate jstate I R prog init final i j spec Ref.
  eapply Forward_simulation.
  - apply wfounded.
  - intros s1 H. exists tt. simpl in H. inversion H.
    exists (EXT s, init_state j). split; simpl.
    + constructor. auto.
    + eapply (f_m i j Ref). apply (match_init i j Ref).
  - intros tt s1 s2 r H H0. simpl in s1, s2. destruct s1 as [ps1 mi1]. destruct s2 as [ps mi2].
    inversion H. subst. simpl. inversion H0. subst. constructor. auto.
  - intros s1 t s1' STEP i0 s2 MATCH. simpl in s1, s1'. destruct s1 as [ps1 mi1]. destruct s1' as [ps1' mi1'].
    inversion MATCH. subst. exists tt. inversion STEP; subst.
    + eapply forward_diagram in EXEC_STEP; eauto.
      destruct EXEC_STEP as [mj' [EXEC' MATCH']].
      exists (EXT s2, mj'). split; auto.
      * left. apply plus_one. eapply ext_step; eauto.
      * constructor. auto.
    + eapply forward_diagram in LOAD; eauto.
      destruct LOAD as [mj' [EXEC' MATCH']].
      exists (INT s1 start, mj'). split; auto.
      * left. apply plus_one. eapply loop_start; eauto.
      * constructor. auto.
    + eapply forward_diagram in EXEC_STEP; eauto.
      destruct EXEC_STEP as [mj' [EXEC' MATCH']].
      exists (INT call_state i2, mj'). split; auto.
      * left. apply plus_one. eapply int_step; eauto.
      * constructor. auto.
    + eapply forward_diagram in EXEC_END; eauto.
      destruct EXEC_END as [mj' [EXEC' MATCH']].
      eapply forward_diagram in EXEC_RET; eauto.
      destruct EXEC_RET as [mj'' [EXEC'' MARCH'']].
      exists (EXT s2, mj''). split; auto.
      * left. apply plus_one. eapply loop_end; eauto.
      * constructor. auto.
Qed.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

(* A portion of this file was developed by Le Xuan Bach *)

Require Import msl.base.
Require Import msl.sepalg.
Require Import msl.functors.
Require Import msl.sepalg_functors.

Definition midObj {A} {JA: Join A} (a : A) : Prop := ~identity a /\ ~ full a.

Definition ijoinable A {JA: Join A} : Type := {sh : A & midObj sh}.

Definition ijoin {A} {JA: Join A} (j1 j2 j3 : ijoinable A) : Prop :=
  match (j1, j2, j3) with
  (existT t1 _, existT t2 _, existT t3 _) => join t1 t2 t3
  end.

Lemma ijoin_eq {A} {JA: Join A}{PA: Perm_alg A} : forall j1 j2 j3 j3',
  ijoin j1 j2 j3 ->
  ijoin j1 j2 j3' ->
  j3 = j3'.
Proof.
  intros.
  icase j1; icase j2; icase j3; icase j3'.
  unfold ijoin in *.
  apply existT_ext.
  eapply join_eq; eauto.
Qed.

Lemma ijoin_com {A} {JA: Join A}{PA: Perm_alg A} : forall j1 j2 j3,
  ijoin j1 j2 j3 -> ijoin j2 j1 j3.
Proof with auto.
  intros.
  icase j1; icase j2; icase j3.
  red in H; red.
  apply join_comm...
Qed.

Lemma ijoin_assoc {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A} : forall a b c d e,
  ijoin a b d ->
  ijoin d c e ->
  {f : ijoinable A | ijoin b c f /\ ijoin a f e}.
Proof with auto.
  intros.
  icase a; icase b; icase c; icase d; icase e.
  unfold ijoin in *.
  destruct (join_assoc H H0) as [f [? ?]].
  assert ((~identity f) /\ (~full f)).
    unfold midObj in *.
    split.
    intro.
    generalize (split_identity _ _ H1 H3); intro.
    tauto.
    intro.
    spec H3 x. spec H3. exists x3...
    spec H3 f x3 H2. subst x3.
    apply unit_identity in H2.
    tauto.
  exists (existT midObj f H3).
  split...
Qed.

Lemma ijoin_canc {A}  {JA: Join A}{SA: Sep_alg A}{CA: Canc_alg A}: forall a a' b c,
  ijoin a b c ->
  ijoin a' b c ->
  a = a'.
Proof with auto.
  intros.
  icase a; icase a'; icase b; icase c.
  unfold ijoin in *.
  apply existT_ext.
  eapply join_canc; eauto.
Qed.

Lemma ijoin_identity1 {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}: forall a b,
  ijoin a b b ->
  False.
Proof with auto.
  intros.
  icase a; icase b.
  destruct m. apply n.
  apply (unit_identity x0).
  apply H.
Qed.

Lemma ijoin_identity2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA: Disj_alg A}: forall a b,
  ijoin a a b ->
  False.
Proof with auto.
  intros.
  icase a. icase b.
  destruct m; destruct m0.
  assert (x=x0). apply join_self. apply H. subst x0.
  assert (join x x x) by (apply H).
  apply unit_identity in H0.
  contradiction.
Qed.

Section CombineJoin.

Variable A : Type.
Variable JA: Join A.
Variable pa_A : Perm_alg A.
Variable sa_A : Sep_alg A.
Variable ca_A : Canc_alg A.

(* We either need an explicit top witness or some kind of axiom of choice
    (if not here, then in sa_fun or somesuch).  It is a little ugly this way but
    I don't see any other way around. Aquinas *)
Variable A_top : A.
Variable A_top_full : full A_top.

Variable T1 : Type.
Variable T2 : Type.
Variable J1: Join T1.
Variable pa_T1: Perm_alg T1.
Variable sa_T1: Sep_alg T1.

Variable combjoin : T1 -> T1 -> T2 -> Prop.

Variable combjoin_eq : forall v1 v1' v2 v2',
  combjoin v1 v1' v2 ->
  combjoin v1 v1' v2' ->
  v2 = v2'.

Variable combjoin_assoc : forall v1 v2 v3 v4 v5,
   join v1 v2 v3 ->
   combjoin v3 v4 v5 ->
   {v' : T1 & join v2 v4 v' /\ combjoin v1 v' v5}.

Variable combjoin_com : forall v1 v2 v3,
   combjoin v1 v2 v3 ->
   combjoin v2 v1 v3.

Variable combjoin_canc : forall v1 v1' v2 v3,
    combjoin v1 v2 v3 ->
    combjoin v1' v2 v3 ->
    v1 = v1'.

(* We would really prefer this to be:
       exists top, join (projT1 j1) (projT1 j2) top /\ full top
   but, again, we run into Type/Prop problems and wind up needing
   some form of the axiom of choice somewhere or other. *)
Definition covers (j1 j2 : ijoinable A) : Prop :=
  join (projT1 j1) (projT1 j2) A_top.

Inductive combiner : Type :=
  | CEmpty
  | CPart : forall (sh : ijoinable A) (v : T1), combiner
  | CFull : forall (v : T2), combiner.

Instance Join_combiner : Join combiner :=
  fun c1 c2 c3 =>
  match (c1,c2,c3) with
  | (CEmpty, CEmpty, CEmpty) => True
  | (CEmpty, CPart a v, CPart a' v') => a = a' /\ v = v'
  | (CPart a v, CEmpty, CPart a' v')  => a = a' /\ v = v'
  | (CEmpty, CFull v, CFull v') => v = v'
  | (CFull v, CEmpty, CFull v') => v = v'
  | (CPart a v, CPart a' v', CPart a'' v'') => ijoin a a' a'' /\ join v v' v''
  | (CPart a v, CPart a' v', CFull v'') => combjoin v v' v'' /\ covers a a'
  | _ => False
 end.

Lemma combineJ_eq: forall x y z z' : combiner,
  join x y z -> join x y z' -> z = z'.
Proof with auto.
  intros.
  icase x;icase y;icase z;icase z';try inversion H;try inversion H0;try congruence.

  f_equal.
  eapply ijoin_eq; eauto.
  eapply join_eq; eauto.

  elimtype False; clear - pa_A sa_A H1 H4 A_top_full.
  destruct sh; destruct sh0; destruct sh1.
  red in H1; red in H4; simpl in H4.
  generalize (join_eq H1 H4); intro; subst x1.
  unfold midObj in *.
  tauto.

  elimtype False; clear - pa_A sa_A H2 H3 A_top_full.
  destruct sh;destruct sh0;destruct sh1.
  red in H3; red in H2; simpl in H2.
  generalize (join_eq H2 H3);intro;subst x1.
  unfold midObj in *.
  tauto.

  rewrite (combjoin_eq _ _ _ _ H1 H3)...
Qed.

Lemma combineJ_assoc: forall a b c d e : combiner,
  join a b d -> join d c e ->
                    {f : combiner & join b c f /\ join a f e}.
Proof with auto.
   intros. red in H, H0. unfold join.
   icase a;icase b;icase c;icase d;icase e;inv H;inv H0.

   exists CEmpty;split;red...
   exists (CPart sh0 v0);split;red...
   exists (CFull v0);split;red...
   exists (CPart sh1 v1);split;red...
   exists (CPart sh2 v2);split;red...
   exists (CFull v2);split;red...
   exists (CFull v1);split;red...
   exists CEmpty;split;red...
   exists (CPart sh0 v0);split;red...
   exists (CPart sh0 v0);split;red...
   exists (CPart sh0 v0);split;red...
   exists (CPart sh0 v0);split;red...
   3: exists (CEmpty);split;red...

   destruct (ijoin_assoc _ _ _ _ _ H1 H) as [sh' [? ?]].
   destruct (join_assoc H2 H3) as [fv [? ?]].
   exists (CPart sh' fv); split; red...

   icase sh; icase sh0; icase sh1; icase sh2.
   red in H1, H3. simpl in H1, H3.
   destruct (join_assoc H1 H3) as [sh' [? ?]].
   assert ((~identity sh') /\ (~full sh')).
     split; intro.
     generalize (split_identity _ _ H0 H5); intro.
     unfold midObj in *.
     tauto.
     spec H5 x.
     spec H5. exists A_top...
     spec H5 sh' A_top H4.
     subst sh'.
     apply unit_identity in H4.
     unfold midObj in *.
     tauto.
  destruct (combjoin_assoc _ _ _ _ _ H2 H) as [v' [? ?]].
  exists (CPart (existT _ sh' H5) v').
  split; split...
Qed.

Lemma combineJ_com: forall a b c : combiner,
    join a b c -> join b a c.
Proof with auto.
  intros. unfold join in H|-*.
  icase a; icase b.
  icase c; red in H; red; destruct H;
  split...
  apply ijoin_com...
  apply join_comm...
Qed.

Lemma combineJ_canc {C1: Canc_alg T1}: forall a1 a2 b c : combiner,
       join a1 b c -> join a2 b c -> a1=a2.
Proof with auto.
   intros. unfold join in H,H0.
   icase c;icase b;icase a1;icase a2;inv H;inv H0;auto.

   destruct (ijoin_identity1 _ _ H).
   destruct (ijoin_identity1 _ _ H1).

   generalize (ijoin_canc _ _ _ _ H1 H).
   generalize (join_canc H2 H3); intros.
   subst sh2 v2...

   generalize (join_canc H2 H3).
   generalize (combjoin_canc _ _ _ _ H1 H); intros.
   f_equal...
   icase sh0; icase sh1.
   apply existT_ext...
Qed.

Lemma combineJ_ex_identities: forall a , {e : combiner &  join e a a}.
Proof with auto.
   intros.
   icase a;
   exists CEmpty;
   constructor...
Qed.

Lemma combineJ_self {DA: Disj_alg A}:
        forall a b : combiner, join a a b -> a = b.
Proof.
  intros.
  icase a;icase b; inv H.
  destruct (ijoin_identity2 _ _ H0).
  elimtype False. clear - DA H1 A_top_full.
  icase sh. red in H1. simpl in H1.
  generalize (join_self H1); intro.
  subst x.
  unfold midObj in *.
  tauto.
Qed.

Instance Perm_combiner : Perm_alg combiner.
Proof. constructor.
  apply combineJ_eq.
  apply combineJ_assoc.
  apply combineJ_com.
   (* positivity *)
  intros.
  hnf in H, H0.
  destruct a, a'; try contradiction; destruct b,b'; try contradiction; auto;
  try solve [destruct H; destruct H0; congruence].
  destruct H; destruct H0.
  f_equal.
  destruct sh as [sh i]; destruct sh0 as [sh0 i0];
  destruct sh1 as [sh1 i1]; destruct sh2 as [sh2 i2].
  apply existT_ext. unfold ijoin in H,H0.
  eapply join_positivity; eauto.
  eapply join_positivity; eauto.
Qed.

Instance Sep_combiner: Sep_alg combiner.
Proof.
  apply mkSep with (fun _ => CEmpty).
  intros. hnf.  destruct t; auto.
  auto.
Defined.

Instance Sing_combiner: Sing_alg combiner.
Proof.
  apply (mkSing CEmpty).
  auto.
Defined.

Instance Canc_combiner {C1: Canc_alg T1}: Canc_alg combiner.
Proof.
 repeat intro. eapply combineJ_canc; eauto.
Qed.

Instance Disj_combiner {D1: Disj_alg A}: Disj_alg combiner.
Proof.
 repeat intro. eapply combineJ_self; eauto.
Qed.

(* Usefull facts about combiners *)

Lemma identity_combiner {C1: Canc_alg T1}: forall d : combiner,
  identity d ->
  d = CEmpty.
Proof.
  intros.
  rewrite identity_unit_equiv in H.
  icase d.
  destruct H.
  destruct (ijoin_identity1 _ _ H).
Qed.

Lemma combiner_identity {C1: Canc_alg T1}:
  identity CEmpty.
Proof.
  intros.
  rewrite identity_unit_equiv.
  compute.
  trivial.
Qed.

Lemma combiner_full {C1: Canc_alg T1}: forall t2,
  full (CFull t2).
Proof.
  unfold full.  intros.
  destruct H as [sigma'' ?].
  icase sigma'.
  apply combiner_identity.
Qed.

(* This one is only true under various restrictions. *)
(*
Lemma full_combiner: forall (d : combiner),
  (* we require that As have complements *)
  (forall a : ijoinable, exists a' : ijoinable, join (projT1 a) (projT1 a') A_top) ->
  (* we require that T2 be nonempty *)
  forall (at2 : T2),
  full d ->
  {t2 : T2 | d = DFull t2}.
Proof.
  intros.
  icase d.
  3: exists v; trivial.
  spec H0 (DFull at2) (DFull at2).
  spec H0.
  apply identity_unit.
  apply combiner_identity.
  exists (DFull at2).
  compute. trivial.
  apply identity_combiner in H0.
  inversion H0.

  elimtype False.
  spec H sh.
  destruct H as [sh' ?].
  destruct (join_ex_identities v) as [v0 [? ?]].
  spec H0 ( sh' v0) (DFull .

  ad mit.
  exists v. trivial.
Qed.
*)

End CombineJoin.

Implicit Arguments combiner.
Implicit Arguments Join_combiner.
Implicit Arguments CEmpty.
Implicit Arguments CPart.
Implicit Arguments CFull.
Implicit Arguments identity_combiner.
Implicit Arguments combiner_identity.
Implicit Arguments combiner_full.

Section ParameterizedCombiner.

  Existing Instance Join_combiner.

  Variable S : Type.
  Variable JS : Join S.
  Variable pa_S : Perm_alg S.
  Variable sa_S : Sep_alg S.
  Variable ca_S : Canc_alg S.

  Variable T1 : Type -> Type.
  Variable J1: forall A, Join (T1 A).
  Variable Perm1: forall A, Perm_alg (T1 A).
  Variable Sep1: forall A, Sep_alg (T1 A).
  Variable f_T1 : functor T1.
  Variable T2 : Type -> Type.
  Variable f_T2 : functor T2.

  Definition fcombiner (A : Type) : Type :=
    @combiner S JS (T1 A) (T2 A).

  Definition fcombiner_fmap (A B : Type) (f : A -> B)
    (fa : fcombiner A) : fcombiner B :=
      match fa with
        | CEmpty => CEmpty _ _ _
        | CPart sh rs => CPart _ sh (fmap f rs)
        | CFull trs => CFull _ _ (fmap f trs)
      end.
  Implicit Arguments fcombiner_fmap [A B].

  Lemma ff_combiner : functorFacts fcombiner fcombiner_fmap.
  Proof with auto.
    constructor; intros;
    extensionality pd; unfold fcombiner_fmap.
    icase pd; rewrite fmap_id...
    icase pd; rewrite <- fmap_comp...
  Qed.

  Instance f_combiner : functor fcombiner := Functor ff_combiner.

  Variable top_S : S.
  Variable topS_full : full top_S.
  Variable combjoin : forall A, (T1 A) -> (T1 A) -> (T2 A) -> Prop.
  Variable combjoin_eq : forall A v1 v1' v2 v2',
    combjoin A v1 v1' v2 ->
    combjoin A v1 v1' v2' ->
    v2 = v2'.
  Variable combjoin_assoc : forall A (v1 v2 v3 v4: T1 A) (v5: T2 A),
    join v1 v2 v3 ->
    combjoin A v3 v4 v5 ->
    {v' : (T1 A) & join v2 v4 v' /\ combjoin A v1 v' v5}.
  Variable combjoin_com : forall A v1 v2 v3,
    combjoin A v1 v2 v3 ->
    combjoin A v2 v1 v3.
  Variable combjoin_canc : forall A v1 v1' v2 v3,
    combjoin A v1 v2 v3 ->
    combjoin A v1' v2 v3 ->
    v1 = v1'.
  Variable saf_T1 : pafunctor f_T1.

  Instance Join_fcombiner (A: Type) : Join (fcombiner A) :=
    Join_combiner top_S (J1 A) (combjoin A).

  Instance Perm_fcombiner (A: Type): Perm_alg (fcombiner A).
  Proof. apply Perm_combiner; auto.
     apply combjoin_eq. apply combjoin_assoc.
  Defined.

  Instance Sep_fcombiner (A: Type): Sep_alg (fcombiner A).
  Proof. apply Sep_combiner; auto.
  Defined.

  Instance Canc_fcombiner (A: Type) (CA: Canc_alg (T1 A)): Canc_alg (fcombiner A).
  Proof.  apply Canc_combiner; auto. apply combjoin_canc.
  Qed.

  Definition combjoin_hom (A : Type) (B : Type)
    (f : T1 A -> T1 B) (g : T2 A -> T2 B) : Prop :=
      forall x y z,
        combjoin A x y z ->
        combjoin B (f x) (f y) (g z).
  Implicit Arguments combjoin_hom [A B].

  Variable fmaps_combjoin_hom: forall A B (f : A -> B),
    combjoin_hom (fmap f) (fmap f).

  Lemma fmap_fcombiner_hom: forall A B (f : A -> B),
    join_hom (JA := Join_fcombiner A) (JB := Join_fcombiner B) (fmap f).
  Proof with auto.
    repeat intro. hnf in H|-*.
    icase x; icase y; icase z.
    destruct H.
    split; congruence.
    simpl in H. subst v0. simpl...
    destruct H.
    split; congruence.
    destruct H.
    split...
    apply paf_join_hom...
    destruct H.
    split...
    apply fmaps_combjoin_hom...
    simpl in H. subst v0. simpl...
  Qed.

  Definition combjoin_unmap_left (A B : Type)
    (f : T1 A -> T1 B) (g : T2 A -> T2 B) : Type :=
      forall (x' : T1 B) (y :T1 A) (z : T2 A),
        combjoin B x' (f y) (g z) ->
        {x : T1 A &  {y0 : T1 A | combjoin A x y0 z /\ f x = x' /\ f y0 = f y}}.
  Implicit Arguments combjoin_unmap_left [A B].

  Variable combjoin_preserves_unmap_left : forall A B (f : A -> B),
    combjoin_unmap_left (fmap f) (fmap f).

  Definition combjoin_unmap_right (A B : Type)
    (f : T1 A -> T1 B) (g : T2 A -> T2 B) : Type :=
      forall (x y :T1 A) (z' : T2 B),
        combjoin B (f x) (f y) z' ->
        {y0 : T1 A &  {z : T2 A | combjoin A x y0 z /\ f y0 = f y /\ g z = z'}}.
  Implicit Arguments combjoin_unmap_right [A B].

  Variable combjoin_preserves_unmap_right : forall A B (f : A -> B),
    combjoin_unmap_right (fmap f) (fmap f).

  Lemma fmap_fcombiner_preserves_unmap_left: forall A B (f : A -> B),
    unmap_left (Join_fcombiner A) (Join_fcombiner B) (fmap f).
  Proof with auto.
    repeat intro. simpl in H|-*. unfold join in H|-*. simpl in H|-*.
    icase x'; icase y; icase z.
    exists (CEmpty _ _ _). exists (CEmpty _ _ _). firstorder.
    exists (CEmpty _ _ _). exists (CPart _ sh0 v0).
    destruct H. simpl.
    repeat split; congruence.
    exists (CEmpty _ _ _). exists (CFull _ _ v0).
    simpl in H. simpl.
    repeat split; congruence.
    exists (CPart _ sh v0). exists (CEmpty _ _ _).
    destruct H. simpl.
    repeat split; congruence.
    destruct H.
    generalize (paf_preserves_unmap_left f v v0 v1 H0); intro X.
    destruct X as [x [y0 [? [? ?]]]].
    exists (CPart _ sh x). exists (CPart _ sh0 y0).
    split. split...
    simpl. split; congruence.
    (* combjoin case *)
    destruct H.
    spec combjoin_preserves_unmap_left A B f v v0 v1 H.
    destruct combjoin_preserves_unmap_left as [x [y0 [? [? ?]]]].
    exists (CPart _ sh x). exists (CPart _ sh0 y0).
    split. split...
    simpl. split; congruence.
    (* end combjoin case *)
    exists (CFull _ _ v0). exists (CEmpty _ _ _).
    simpl in H. simpl.
    repeat split; congruence.
  Qed.

  Lemma fmap_fcombiner_preserves_unmap_right: forall A B (f : A -> B),
    unmap_right (Join_fcombiner A) (Join_fcombiner B) (fmap f).
  Proof with auto.
    repeat intro. simpl in H|-*. unfold join in H|-*. simpl in H|-*.
    icase x; icase y; icase z'.
    exists (CEmpty _ _ _). exists (CEmpty _ _ _). firstorder.
    exists (CPart _ sh v). exists (CPart _ sh v).
    destruct H. simpl.
    repeat split; congruence.
    exists (CFull _ _ v). exists (CFull _ _ v).
    simpl in H. simpl.
    repeat split; congruence.
    exists (CEmpty _ _ _). exists (CPart _ sh v).
    destruct H. simpl.
    repeat split; congruence.
    destruct H.
    generalize (paf_preserves_unmap_right f v v0 v1 H0); intro X.
    destruct X as [y0 [z [? [? ?]]]].
    exists (CPart _ sh0 y0). exists (CPart _ sh1 z).
    split. split...
    simpl. split; congruence.
    (* combjoin case *)
    destruct H.
    spec combjoin_preserves_unmap_right A B f v v0 v1 H.
    destruct combjoin_preserves_unmap_right as [y0 [z [? [? ?]]]].
    exists (CPart _ sh0 y0). exists (CFull _ _ z).
    split. split...
    simpl. split; congruence.
    (* end combjoin case *)
    exists (CEmpty _ _ _). exists (CFull _ _ v).
    simpl in H. simpl.
    repeat split; congruence.
  Qed.

 Instance paf_combiner: @pafunctor _ f_combiner Join_fcombiner.
 Proof.
    constructor.
    apply fmap_fcombiner_hom.
    apply fmap_fcombiner_preserves_unmap_left.
    apply fmap_fcombiner_preserves_unmap_right.
 Qed.

End ParameterizedCombiner.

Implicit Arguments fcombiner.
Implicit Arguments combjoin_hom [T1 T2 A B].
Implicit Arguments combjoin_unmap_left [A B T1 T2].
Implicit Arguments combjoin_unmap_right [A B T1 T2].
Implicit Arguments f_combiner [S JS T1 T2].
Implicit Arguments paf_combiner.