Set Implicit Arguments.

Require Import Pattern.PatternImplDef.
Require Import Pattern.PatternImplTheory.
Require Import Pattern.PatternInterface.
Require Import Coq.Lists.List.
Require Import Wildcard.Wildcard.
Require Import Network.NetworkPacket.
Require Import Coq.Classes.Equivalence.

Local Open Scope equiv_scope.

Module Pattern : PATTERN.

  Record pat := Pat {
    raw : pattern;
    valid : ValidPattern raw
  }.

  Definition t := pat.

  Definition beq (p1 p2 : t) :=
    match eq_dec (raw p1) (raw p2) with
      | left _ => true
      | right _ => false
    end.

  Definition inter (p1 p2 : t) :=
    Pat (inter_preserves_valid (valid p1) (valid p2)).

  Lemma all_is_Valid : ValidPattern all.
  Proof.
    apply ValidPat_any.
  Qed.

  Definition all : t := Pat all_is_Valid.

  Lemma empty_is_valid : ValidPattern empty.
  Proof.
    apply ValidPat_None.
    reflexivity.
  Qed.

  Definition empty : t := Pat empty_is_valid.

  Definition exact_pattern pk pt : t :=
    Pat (exact_is_valid pt pk).

  Definition is_empty pat : bool := is_empty (raw pat).

  Definition match_packet pt pk pat : bool :=
    match_packet pt pk (raw pat).

  Definition is_exact pat : bool := is_exact (raw pat).

  Definition to_match pat (H : is_empty pat = false) :=
    to_match (raw pat) H.

  Section Constructors.

    Definition inPort pt : t :=
      @Pat
        (Pattern
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           (WildcardExact pt))
        (ValidPat_any _ _ _ _ _ _).

    Definition dlSrc dlAddr : t :=
      @Pat
        (Pattern
          (WildcardExact dlAddr)
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll)
        (ValidPat_any (WildcardExact dlAddr) _ _ _ _ _).

    Definition dlDst dlAddr : t :=
      @Pat
        (Pattern
           WildcardAll
          (WildcardExact dlAddr)
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll)
        (ValidPat_any _ (WildcardExact dlAddr) _ _ _ _).

    Definition dlTyp typ : t :=
      @Pat
        (Pattern
           WildcardAll
           WildcardAll
           (WildcardExact typ)
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll)
        (ValidPat_any _ _ (WildcardExact typ) _ _ _).

    Definition dlVlan vlan : t :=
      @Pat
        (Pattern
           WildcardAll
           WildcardAll
           WildcardAll
           (WildcardExact vlan)
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll)
        (ValidPat_any _ _ _ (WildcardExact vlan) _ _).

    Definition dlVlanPcp pcp : t :=
      @Pat
        (Pattern
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           (WildcardExact pcp)
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll
           WildcardAll)
        (ValidPat_any _ _ _ _ (WildcardExact pcp) _).

    Definition ipSrc addr : t :=
      @Pat
        (Pattern
          WildcardAll
          WildcardAll
          (WildcardExact Const_0x800)
          WildcardAll
          WildcardAll
          (WildcardExact addr)
          WildcardAll
          WildcardAll
          WildcardAll
          WildcardAll
          WildcardAll
          WildcardAll)
        (ValidPat_IP_any _ _ _ _ (WildcardExact addr) _ _ _ _).

    Definition ipDst addr : t :=
      @Pat
        (Pattern
          WildcardAll
          WildcardAll
          (WildcardExact Const_0x800)
          WildcardAll
          WildcardAll
          WildcardAll
          (WildcardExact addr)
          WildcardAll
          WildcardAll
          WildcardAll
          WildcardAll
          WildcardAll)
        (ValidPat_IP_any _ _ _ _ _ (WildcardExact addr) _ _ _).

    Definition ipProto proto : t :=
      @Pat
        (Pattern
          WildcardAll
          WildcardAll
          (WildcardExact Const_0x800)
          WildcardAll
          WildcardAll
          WildcardAll
          WildcardAll
          (WildcardExact proto)
          WildcardAll
          WildcardAll
          WildcardAll
          WildcardAll)
        (ValidPat_IP_any _ _ _ _ _ _ _ _ (WildcardExact proto)).

    Definition tpSrcPort proto (H : In proto SupportedNwProto) tpPort : t :=
      @Pat
        (Pattern
          WildcardAll
          WildcardAll
          (WildcardExact Const_0x800)
          WildcardAll
          WildcardAll
          WildcardAll
          WildcardAll
          (WildcardExact proto)
          WildcardAll
          (WildcardExact tpPort)
          WildcardAll
          WildcardAll)
        (@ValidPat_TCPUDP _ _ _ _ _ _ _ (WildcardExact tpPort) _ _ _ H).

    Definition tpDstPort proto (H : In proto SupportedNwProto) tpPort : t :=
      @Pat
        (Pattern
          WildcardAll
          WildcardAll
          (WildcardExact Const_0x800)
          WildcardAll
          WildcardAll
          WildcardAll
          WildcardAll
          (WildcardExact proto)
          WildcardAll
          WildcardAll
          (WildcardExact tpPort)
          WildcardAll)
        (@ValidPat_TCPUDP _ _ _ _ _ _ _ _ (WildcardExact tpPort) _ _ H).

    Lemma TCP_is_supported : In Const_0x6 SupportedNwProto.
    Proof with auto with datatypes.
      unfold SupportedNwProto...
    Qed.

    Lemma UDP_is_supported : In Const_0x7 SupportedNwProto.
    Proof with auto with datatypes.
      unfold SupportedNwProto...
    Qed.

    Definition tcpSrcPort := tpSrcPort TCP_is_supported.

    Definition tcpDstPort := tpDstPort TCP_is_supported.

    Definition udpSrcPort := tpSrcPort UDP_is_supported.

    Definition udpDstPort := tpDstPort UDP_is_supported.

  End Constructors.

    Definition equiv (pat1 pat2 : t) : Prop :=
      forall pt pk,
        match_packet pt pk pat1 = match_packet pt pk pat2.

    Lemma equiv_is_Equivalence : Equivalence equiv.
    Proof with auto.
      unfold equiv.
      unfold match_packet.
      split.
      unfold Reflexive...
      unfold Symmetric...
      unfold Transitive...
      intros.
      rewrite -> H...
    Qed.

Instance Pattern_Equivalence : Equivalence equiv.
  apply equiv_is_Equivalence.
Qed.

Section Lemmas.

  Lemma inter_comm : forall (p p0 : pat),  equiv (inter p p0) (inter p0 p).
  Proof with auto.
    unfold equiv.
    unfold match_packet.
    unfold inter.
    intros.
    simpl.
    rewrite -> inter_comm...
  Qed.

  Lemma inter_assoc : forall (p p' p'' : pat),
    equiv (inter p (inter p' p'')) (inter (inter p p') p'').
  Proof with auto.
    unfold equiv.
    unfold match_packet.
    unfold inter.
    intros.
    simpl.
    rewrite -> inter_assoc...
  Qed.

  Hint Unfold inter is_empty is_exact equiv match_packet.

  Lemma is_empty_false_distr_l : forall x y,
    is_empty (inter x y) = false ->
    is_empty x = false .
  Proof with eauto.
    intros.
    autounfold in *.
    eapply is_empty_false_distr_l...
  Qed.

  Lemma is_empty_false_distr_r : forall x y,
    is_empty (inter x y) = false ->
    is_empty y = false.
  Proof with eauto.
    intros.
    autounfold in *.
    eapply is_empty_false_distr_r...
  Qed.

  Lemma is_empty_true_l : forall x y,
    is_empty x = true ->
    is_empty (inter x y) = true.
  Proof with eauto.
    intros.
    autounfold in *.
    eapply is_empty_true_l...
  Qed.

  Lemma is_empty_true_r : forall x y,
    is_empty y = true ->
    is_empty (inter x y) = true.
  Proof with eauto.
    intros.
    autounfold in *.
    eapply is_empty_true_r...
  Qed.

  Lemma is_match_false_inter_l :
    forall pt (pkt : packet) pat1 pat2,
      match_packet pt pkt pat1 = false ->
      match_packet pt pkt (inter pat1 pat2) = false.
  Proof with eauto.
    intros.
    autounfold in *.
    eapply is_match_false_inter_l...
  Qed.

  Lemma is_match_false_inter_r :
    forall pt (pkt : packet) pat1 pat2,
      match_packet pt pkt pat2 = false ->
      match_packet pt pkt (inter pat1 pat2) = false.
  Proof with eauto.
    intros.
    autounfold in *.
    eapply is_match_false_inter_r...
  Qed.

  Lemma no_match_subset_r : forall k n t t',
    match_packet n k t' = false ->
    match_packet n k (inter t t') = false.
  Proof with eauto.
    intros.
    autounfold in *.
    eapply no_match_subset_r...
  Qed.

  Lemma exact_match_inter : forall x y,
    is_exact x = true ->
    is_empty (inter x y) = false ->
    equiv (inter x y) x.
  Proof with eauto.
    intros.
    unfold equiv.
    unfold match_packet.
    intros.
    destruct x.
    destruct y.
    unfold is_exact in *.
    unfold inter in *.
    unfold is_empty in *.
    simpl in H.
    simpl in H0.
    pose (J := PatternImplTheory.exact_match_inter _ _ H H0).
    simpl.
    rewrite -> J...
  Qed.

  Lemma all_spec : forall pt pk,
    match_packet pt pk all = true.
  Proof with auto.
    unfold all.
    unfold match_packet.
    simpl.
    exact all_spec.
  Qed.

  Lemma all_is_not_empty : is_empty all = false.
  Proof.
    reflexivity.
  Qed.

  Lemma exact_match_is_exact : forall pk pt,
    is_exact (exact_pattern pk pt) = true.
  Proof with auto.
    unfold exact_pattern.
    unfold is_exact.
    intros.
    apply exact_match_is_exact.
  Qed.

  Lemma exact_intersect : forall k n t,
    match_packet k n t = true ->
    equiv (inter (exact_pattern n k) t) (exact_pattern n k).
  Proof with auto.
    unfold equiv.
    unfold exact_pattern.
    unfold match_packet.
    unfold inter.
    intros.
    simpl.
    pose (J := exact_intersect k n (raw t0) H).
    rewrite -> J...
  Qed.

  Lemma is_match_true_inter : forall pat1 pat2 pt pk,
    match_packet pt pk pat1 = true ->
    match_packet pt pk pat2 = true ->
    match_packet pt pk (inter pat1 pat2) = true.
  Proof with auto.
    intros.
    unfold match_packet in *.
    unfold inter.
    simpl.
    rewrite -> is_match_true_inter...
  Qed.

  Lemma beq_true_spec : forall p p',
    beq p p' = true ->
    equiv p p'.
  Proof with auto.
    intros.
    unfold equiv.
    unfold match_packet.
    destruct p.
    destruct p'.
    unfold beq in H.
    simpl in H.
    destruct (eq_dec raw0 raw1); subst...
    inversion H.
  Qed.

  Lemma match_packet_spec : forall pt pk pat,
    match_packet pt pk pat =
    negb (is_empty (inter (exact_pattern pk pt) pat)).
  Proof.
    intros.
    destruct pat0.
    unfold match_packet.
    unfold is_empty.
    unfold inter.
    unfold exact_pattern.
    unfold PatternImplDef.match_packet.
    unfold raw.
    reflexivity.
  Qed.

End Lemmas.

End Pattern.

Definition pattern := Pattern.t.


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

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 Zplus_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 Zplus_0_r. eauto.
- inv H0. apply Zdivide_0.
- inv H0. rewrite Zplus_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 inj_S 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 nat_of_Z_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 inj_S 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.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

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

Lemma senv_preserved:
  Senv.equiv ge tge.
Proof (Genv.senv_match TRANSF).

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 TRANSF).

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 TRANSF).

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 fd trs ne,
  find_function ge ros rs = Some fd ->
  eagree rs trs (add_ros_need_all ros ne) ->
  exists cu tfd,
     find_function tge ros trs = Some tfd
  /\ transf_fundef (romem_for cu) fd = OK tfd
  /\ linkorder cu prog.
Proof.
  intros. destruct ros as [r|id]; simpl in *.
- assert (LD: Val.lessdef rs#r trs#r) by eauto with na. inv LD.
  apply functions_translated; auto.
  rewrite <- H2 in H; discriminate.
- rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try discriminate.
  apply function_ptr_translated; auto.
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 f args m ts tf targs tm cu
        (STACKS: list_forall2 match_stackframes s ts)
        (LINK: linkorder cu prog)
        (FUN: transf_fundef (romem_for cu) f = OK tf)
        (ARGS: Val.lessdef_list args targs)
        (MEM: Mem.extends m tm),
      match_states (Callstate s f args m)
                   (Callstate ts tf 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.
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.
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 ge (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 ge (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 ge S1 t S2 ->
  forall S1', match_states S1 S1' -> sound_state prog S1 ->
  exists S2', step 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.

- (* 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 (cu' & tfd & A & B & C).
  econstructor; split.
  eapply exec_Icall; eauto. eapply sig_function_translated; eauto.
  eapply match_call_states with (cu := cu'); 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.
  eauto 2 with na.
  eapply magree_extends; eauto. apply nlive_all.

- (* tailcall *)
  TransfInstr; UseTransfer.
  exploit find_function_translated; eauto 2 with na. intros (cu' & tfd & A & B & L).
  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. eapply sig_function_translated; eauto.
  erewrite stacksize_translated by eauto. eexact C.
  eapply match_call_states with (cu := cu'); eauto 2 with na.
  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 ge 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 senv_preserved.
  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 senv_preserved.
  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 nat_of_Z_eq 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 senv_preserved.
  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 nat_of_Z_eq in H0 by omega. auto.
+ (* annot *)
  destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x1) 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 senv_preserved.
  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) _x1) 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 senv_preserved.
  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 senv_preserved. eauto.
  eapply match_succ_states; eauto. simpl; auto.
  apply eagree_set_res; auto.
  eapply mextends_agree; eauto.

- (* conditional *)
  TransfInstr; UseTransfer.
  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 *)
  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 Zle_refl. apply Zle_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 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. apply senv_preserved.
  econstructor; eauto.

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

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists st2, initial_state tprog st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  exploit function_ptr_translated; eauto. intros (cu & tf & A & B & C).
  exists (Callstate nil tf nil m0); split.
  econstructor; eauto.
  eapply (Genv.init_mem_match TRANSF); eauto.
  replace (prog_main tprog) with (prog_main prog).
  rewrite symbols_preserved. eauto.
  symmetry; eapply match_program_main; eauto.
  rewrite <- H3. eapply sig_function_translated; eauto.
  econstructor; eauto. constructor. apply Mem.extends_refl.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states 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 => sound_state prog s1 /\ match_states s1 s2).
- apply senv_preserved.
- 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.
  assert (sound_state prog s1') by (eapply sound_step; eauto).
  fold ge; fold tge. exploit step_simulation; eauto. intros [st2' [A B]].
  exists st2'; auto.
Qed.

End PRESERVATION.


Require Import compcert.common.Errors.
Require Import compcert.driver.Compiler.
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Events.
Require Import compcert.common.Smallstep.
Require Import compcert.lib.Integers.
(* Here we show that we can turn steps in Cminor into steps in Asm *)

Section sim.

  Variable prog : Cminor.program.

  Variable st : Cminor.state.

  Hypothesis init_state : Cminor.initial_state prog st.

  Variable st' : Cminor.state.

  Variable res : Int.int.

  Hypothesis final_state : Cminor.final_state st' res.

  Variable t : trace.

  Definition ge := Genv.globalenv prog.

  Hypothesis steps : Smallstep.star Cminor.step ge st t st'.

  Variable tprog : Asm.program.

  Hypothesis TRANSF : transf_cminor_program prog = OK tprog.

  Definition compcert_forward_simulation := fst (transf_cminor_program_correct prog tprog TRANSF).

  Definition match_states := fsim_match_states compcert_forward_simulation.

  Definition tge := Genv.globalenv tprog.

  Lemma asm_steps :
    exists ast i,
      match_states i st ast /\
      exists ast' i',
        match_states i' st' ast' /\
        Smallstep.star Asm.step tge ast t ast'.
  Proof.
    eapply (fsim_match_initial_states compcert_forward_simulation) in init_state.
    destruct init_state.
    destruct H.
    destruct H.
    clear init_state.

    assert (HStar : Star (Cminor.semantics prog) st t st').
    {
      apply steps.
    }
    eapply simulation_star in HStar; eauto.
    destruct HStar.
    destruct H1.
    destruct H1.
    unfold match_states.
    remember H2 as H3. clear HeqH3.
    eapply fsim_match_final_states in H2; eauto.
    repeat eexists; eauto.
  Qed.

End sim.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.BinInt.

Open Scope list_scope.
Open Scope Z_scope.

Import ListNotations.

Inductive Direction :=
    | forward (n : Z)
    | down (n : Z)
    | up (n : Z)
    .

Definition example_data := [ forward 5 ; down 5 ; forward 8 ; up 3 ; down 8 ; forward 2 ].
Definition data := [ forward 4 ; forward 6 ; down 8 ; forward 3 ; forward 9 ; down 7 ; down 7 ; down 1 ; forward 1 ; forward 5 ; up 4 ; forward 3 ; forward 9 ; forward 5 ; down 8 ; forward 6 ; forward 8 ; up 4 ; forward 1 ; forward 4 ; up 3 ; down 2 ; down 2 ; up 8 ; forward 9 ; down 5 ; down 6 ; down 4 ; forward 1 ; forward 7 ; down 1 ; forward 2 ; down 7 ; down 6 ; forward 3 ; forward 1 ; down 7 ; forward 3 ; up 7 ; up 1 ; forward 6 ; down 8 ; down 4 ; down 1 ; down 7 ; forward 9 ; down 2 ; forward 9 ; up 4 ; down 7 ; forward 9 ; forward 9 ; up 4 ; up 7 ; up 2 ; forward 1 ; down 9 ; forward 2 ; forward 8 ; forward 5 ; down 9 ; forward 5 ; up 1 ; forward 8 ; down 6 ; down 1 ; down 1 ; down 8 ; down 6 ; down 4 ; down 6 ; forward 7 ; forward 5 ; forward 4 ; up 8 ; up 4 ; forward 6 ; forward 9 ; forward 6 ; down 2 ; up 8 ; forward 3 ; forward 8 ; down 5 ; forward 1 ; down 6 ; down 7 ; up 4 ; down 8 ; forward 6 ; up 4 ; forward 7 ; down 8 ; down 8 ; down 2 ; down 8 ; up 7 ; forward 7 ; forward 6 ; down 2 ; forward 9 ; down 7 ; down 4 ; forward 1 ; up 9 ; down 6 ; up 7 ; down 6 ; down 2 ; down 2 ; forward 3 ; down 8 ; forward 4 ; down 7 ; down 2 ; up 8 ; down 6 ; forward 2 ; forward 2 ; down 6 ; up 6 ; down 7 ; up 5 ; up 4 ; up 9 ; forward 9 ; forward 7 ; down 4 ; down 4 ; up 5 ; down 2 ; forward 3 ; down 9 ; down 5 ; forward 8 ; up 3 ; forward 7 ; forward 9 ; down 3 ; forward 1 ; up 1 ; forward 5 ; down 8 ; down 2 ; forward 3 ; down 6 ; down 8 ; up 9 ; down 9 ; forward 4 ; up 5 ; forward 8 ; forward 7 ; forward 7 ; down 3 ; down 5 ; forward 8 ; down 1 ; down 2 ; forward 2 ; up 9 ; down 3 ; down 9 ; forward 2 ; down 4 ; up 9 ; up 3 ; down 1 ; down 1 ; forward 6 ; down 5 ; down 9 ; forward 2 ; up 5 ; forward 3 ; down 1 ; down 7 ; forward 1 ; forward 1 ; down 7 ; up 3 ; up 1 ; up 6 ; forward 9 ; up 1 ; down 8 ; down 5 ; up 6 ; up 2 ; down 8 ; forward 3 ; forward 1 ; down 7 ; up 1 ; down 9 ; down 9 ; up 8 ; forward 4 ; up 8 ; forward 8 ; down 5 ; forward 5 ; forward 2 ; forward 1 ; forward 5 ; down 8 ; forward 6 ; forward 8 ; down 5 ; forward 8 ; up 1 ; up 9 ; up 7 ; down 5 ; down 9 ; up 4 ; down 7 ; up 8 ; up 3 ; forward 6 ; down 9 ; forward 4 ; down 4 ; forward 2 ; forward 3 ; down 4 ; down 5 ; down 3 ; forward 9 ; forward 5 ; forward 9 ; forward 4 ; down 5 ; down 7 ; down 5 ; forward 8 ; up 5 ; down 2 ; forward 3 ; forward 4 ; down 5 ; up 8 ; forward 5 ; down 2 ; up 4 ; down 5 ; down 2 ; forward 1 ; up 3 ; down 6 ; down 8 ; down 3 ; forward 1 ; up 5 ; forward 1 ; down 3 ; forward 4 ; down 6 ; forward 8 ; forward 4 ; forward 1 ; down 8 ; down 2 ; forward 8 ; down 5 ; forward 2 ; forward 2 ; down 9 ; forward 1 ; forward 8 ; up 1 ; forward 1 ; down 1 ; down 7 ; down 4 ; up 4 ; down 3 ; forward 1 ; forward 9 ; down 9 ; up 6 ; up 8 ; down 2 ; down 2 ; down 3 ; forward 2 ; forward 9 ; down 1 ; up 9 ; down 3 ; down 9 ; down 1 ; down 7 ; forward 9 ; forward 7 ; down 5 ; down 2 ; down 9 ; down 2 ; down 7 ; up 7 ; down 2 ; up 3 ; up 5 ; forward 8 ; up 7 ; forward 1 ; down 9 ; down 9 ; down 1 ; forward 6 ; down 7 ; up 4 ; up 4 ; down 9 ; up 5 ; up 8 ; down 3 ; down 5 ; forward 6 ; up 3 ; down 8 ; down 5 ; forward 9 ; up 6 ; forward 9 ; forward 5 ; up 6 ; up 9 ; down 2 ; up 5 ; forward 9 ; down 1 ; up 1 ; down 9 ; forward 4 ; forward 4 ; forward 8 ; down 5 ; down 3 ; down 7 ; forward 5 ; down 6 ; forward 3 ; down 5 ; down 5 ; up 5 ; forward 8 ; forward 1 ; forward 2 ; forward 6 ; up 1 ; down 5 ; down 4 ; up 5 ; forward 3 ; forward 2 ; forward 2 ; forward 2 ; forward 7 ; forward 8 ; down 2 ; up 8 ; forward 4 ; down 4 ; forward 7 ; down 6 ; down 7 ; forward 5 ; down 5 ; forward 1 ; down 8 ; forward 6 ; down 1 ; forward 3 ; up 3 ; down 7 ; down 2 ; up 4 ; down 3 ; up 2 ; up 8 ; down 2 ; forward 5 ; forward 3 ; down 9 ; down 9 ; up 2 ; forward 6 ; forward 9 ; down 1 ; forward 6 ; down 4 ; up 2 ; down 7 ; down 3 ; down 3 ; forward 2 ; down 5 ; down 9 ; down 7 ; forward 7 ; forward 9 ; up 8 ; down 8 ; down 3 ; up 5 ; down 9 ; forward 8 ; forward 8 ; down 1 ; forward 5 ; forward 2 ; forward 7 ; down 9 ; down 7 ; forward 6 ; up 9 ; forward 3 ; forward 5 ; up 7 ; down 9 ; forward 9 ; forward 4 ; forward 5 ; forward 9 ; forward 8 ; forward 1 ; forward 2 ; forward 8 ; down 7 ; forward 3 ; up 2 ; up 7 ; forward 1 ; forward 3 ; forward 9 ; up 3 ; down 2 ; forward 3 ; forward 6 ; forward 3 ; forward 3 ; forward 3 ; forward 1 ; forward 1 ; up 5 ; down 5 ; up 5 ; down 5 ; down 5 ; forward 8 ; forward 1 ; down 4 ; forward 7 ; down 6 ; down 1 ; down 2 ; down 2 ; down 6 ; up 8 ; forward 3 ; forward 2 ; up 8 ; up 2 ; forward 1 ; forward 6 ; forward 5 ; forward 6 ; forward 7 ; down 8 ; forward 1 ; down 4 ; forward 2 ; up 4 ; forward 4 ; down 1 ; forward 5 ; down 7 ; forward 7 ; up 7 ; forward 1 ; down 2 ; forward 8 ; forward 5 ; up 8 ; up 8 ; up 2 ; down 9 ; forward 2 ; down 4 ; down 3 ; down 5 ; down 5 ; down 2 ; up 5 ; forward 6 ; up 7 ; forward 8 ; up 7 ; down 4 ; forward 1 ; down 3 ; forward 2 ; forward 1 ; down 2 ; up 7 ; forward 5 ; up 8 ; up 1 ; down 4 ; forward 6 ; down 4 ; up 9 ; forward 5 ; down 2 ; down 7 ; down 7 ; forward 4 ; forward 4 ; forward 9 ; down 1 ; forward 6 ; forward 1 ; up 9 ; forward 4 ; forward 4 ; forward 8 ; forward 3 ; forward 4 ; down 3 ; up 5 ; up 1 ; forward 3 ; down 6 ; down 4 ; down 2 ; forward 3 ; forward 8 ; up 6 ; up 3 ; forward 8 ; down 3 ; down 6 ; forward 1 ; up 7 ; down 4 ; down 5 ; up 7 ; forward 3 ; up 4 ; forward 9 ; forward 6 ; down 3 ; forward 4 ; down 6 ; forward 1 ; forward 6 ; forward 4 ; forward 2 ; forward 1 ; forward 3 ; forward 1 ; down 1 ; down 9 ; down 5 ; down 7 ; down 4 ; down 8 ; up 1 ; down 6 ; down 1 ; forward 4 ; down 9 ; up 9 ; down 6 ; forward 6 ; forward 8 ; up 7 ; forward 4 ; down 3 ; forward 9 ; forward 6 ; forward 8 ; down 1 ; up 2 ; down 2 ; down 8 ; forward 4 ; down 9 ; down 3 ; forward 5 ; down 9 ; down 4 ; up 5 ; down 8 ; down 4 ; down 9 ; up 4 ; down 5 ; down 7 ; down 3 ; up 1 ; up 1 ; down 4 ; down 6 ; forward 8 ; down 8 ; down 6 ; forward 6 ; forward 9 ; forward 3 ; forward 3 ; down 2 ; down 4 ; forward 3 ; up 5 ; up 3 ; down 5 ; down 1 ; forward 5 ; forward 7 ; forward 1 ; forward 4 ; forward 5 ; forward 1 ; down 7 ; down 8 ; up 9 ; down 8 ; down 5 ; up 3 ; down 5 ; down 5 ; forward 8 ; down 2 ; forward 7 ; forward 7 ; down 1 ; forward 2 ; forward 7 ; forward 5 ; down 6 ; forward 5 ; down 5 ; forward 4 ; down 8 ; forward 7 ; up 5 ; forward 5 ; down 7 ; down 7 ; up 4 ; forward 8 ; up 1 ; forward 3 ; forward 7 ; down 2 ; forward 1 ; down 4 ; up 8 ; forward 3 ; forward 1 ; forward 6 ; forward 3 ; up 4 ; forward 3 ; down 3 ; forward 7 ; forward 9 ; forward 8 ; down 6 ; down 8 ; up 6 ; down 9 ; forward 7 ; forward 1 ; up 4 ; forward 5 ; forward 8 ; down 7 ; down 9 ; up 6 ; up 6 ; forward 9 ; down 1 ; forward 8 ; down 9 ; down 5 ; forward 6 ; forward 1 ; down 4 ; forward 8 ; down 9 ; down 4 ; forward 5 ; forward 7 ; forward 3 ; down 2 ; forward 6 ; forward 3 ; forward 8 ; down 1 ; down 5 ; up 6 ; down 2 ; down 1 ; up 3 ; down 7 ; up 1 ; forward 8 ; down 6 ; down 6 ; forward 8 ; up 3 ; forward 8 ; up 3 ; forward 3 ; forward 7 ; forward 1 ; down 1 ; up 5 ; forward 5 ; forward 9 ; forward 5 ; forward 1 ; forward 4 ; down 8 ; forward 2 ; up 3 ; forward 3 ; down 9 ; forward 2 ; forward 6 ; forward 3 ; up 8 ; up 1 ; down 6 ; forward 3 ; down 4 ; down 5 ; forward 6 ; forward 9 ; down 4 ; down 9 ; down 7 ; down 1 ; up 3 ; up 6 ; forward 4 ; forward 5 ; down 1 ; forward 3 ; up 5 ; forward 7 ; down 9 ; forward 5 ; down 5 ; down 1 ; down 1 ; down 1 ; up 8 ; down 4 ; down 9 ; forward 5 ; down 5 ; up 5 ; up 3 ; forward 1 ; forward 7 ; down 2 ; forward 6 ; forward 5 ; up 4 ; up 4 ; forward 1 ; down 7 ; down 8 ; up 3 ; down 3 ; up 4 ; forward 2 ; up 4 ; up 4 ; forward 8 ; forward 1 ; forward 2 ; forward 7 ; down 6 ; forward 8 ; forward 9 ; forward 6 ; forward 9 ; down 3 ; up 3 ; forward 5 ; down 1 ; forward 1 ; forward 4 ; forward 2 ; down 6 ; up 7 ; forward 9 ; down 2 ; up 5 ; forward 6 ; down 9 ; down 6 ; down 8 ; forward 2 ; down 7 ; forward 6 ; down 8 ; forward 3 ; forward 7 ; forward 6 ; down 7 ; down 6 ; forward 5 ; up 8 ; forward 6 ; down 1 ; up 9 ; forward 6 ; down 6 ; down 5 ; down 6 ; up 2 ; down 3 ; down 7 ; down 3 ; forward 4 ; up 9 ; up 2 ; forward 1 ; forward 7 ; forward 7 ; forward 9 ; forward 8 ; forward 7 ; down 3 ; forward 4 ; forward 8 ; down 9 ; forward 2 ; forward 2 ; up 9 ; up 7 ; forward 2 ; down 8 ; down 3 ; down 1 ; forward 1 ; forward 3 ; down 2 ; forward 7 ; up 4 ; down 7 ; down 1 ; forward 8 ; forward 2 ; up 1 ; down 5 ; forward 8 ; up 5 ; up 7 ; forward 4 ; forward 7 ; up 4 ; up 3 ; forward 5 ; forward 9 ; forward 1 ; forward 3 ; down 9 ; up 2 ; forward 8 ; down 3 ; forward 3 ; forward 2 ; down 8 ; down 2 ; down 3 ; forward 1 ; up 7 ; down 1 ; forward 3 ; forward 8 ; down 3 ; down 9 ; up 1 ; down 9 ; up 7 ; up 7 ; forward 7 ; forward 7 ; up 8 ; down 2 ; down 7 ; down 1 ; forward 5 ; forward 5 ; forward 7 ; down 8 ; forward 5 ; down 9 ; down 8 ; forward 3 ; up 9 ; forward 3 ; up 6 ; forward 7 ; up 7 ; forward 3 ; forward 2 ; down 1 ; down 4 ; forward 1 ; forward 8 ; up 5 ; down 5 ; up 1 ; down 5 ; up 1 ; up 6 ; forward 5 ; forward 5 ; down 3 ; down 3 ; forward 2 ; up 3 ; up 2 ; down 6 ; down 5 ; down 1 ; down 1 ; up 6 ; forward 2 ; forward 2 ; up 4 ; up 6 ; up 6 ; down 8 ; up 2 ; forward 4 ; down 3 ; forward 3 ; up 4 ; down 5 ; forward 6 ; forward 7 ; up 6 ; down 3 ; down 7 ; up 4 ; down 2 ; up 2 ; forward 1 ; down 8 ; down 1 ; down 1 ; up 9 ; down 1 ; down 1 ; up 1 ; forward 8 ; forward 4 ; down 4 ; forward 1 ; down 4 ; up 7 ; forward 7 ; forward 3 ; down 4 ; forward 9 ; forward 1 ; down 3 ; down 2 ; forward 7 ; up 1 ; forward 3 ; up 3 ; down 3 ; down 7 ; up 3 ; up 4 ; forward 7 ; down 2 ; up 2 ; down 9 ; up 1 ; forward 3 ; up 8 ; up 8 ; down 8 ; down 1 ; up 8 ; up 4 ; down 6 ; forward 8 ].

Fixpoint position (x y : Z) (data : list Direction) :=
    match data with
    | [] => x * y
    | (forward n) :: l => position (x + n) y l
    | (down n) :: l => position x (y + n) l
    | (up n) :: l => position x (y - n) l
    end.

Definition part1 := position 0 0 data.

Fixpoint position_aim (x y aim : Z) (data : list Direction) :=
    match data with
    | [] => x * y
    | (forward n) :: l => position_aim (x + n) (y + n*aim) aim l
    | (down n) :: l => position_aim x y (aim + n) l
    | (up n) :: l => position_aim x y (aim - n) l
    end.

Definition part2 := position_aim 0 0 0 data.

Compute part1.
Compute part2.


From iris.proofmode Require Import tactics.
From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri.lang Require Import lang.
From HypVeri Require Import big_sepFM machine_extra.
From HypVeri.algebra Require Import base base_extra mem mailbox trans.
From HypVeri.logrel Require Import big_sepSS.
Import uPred.

Section slice_trans.
  Context `{hypconst:HypervisorConstants}.
  Context `{vmG: !gen_VMG Σ}.
  Context (Φ : (gmap Addr transaction) -> VMID -> VMID -> iProp Σ).

  Definition trans_preserve_slice i j (trans trans': (gmap Addr transaction)):=
    filter (λ kv, kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) trans
                        = filter (λ kv, kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) trans'.

  Class SliceTransWf :=
    {
      slice_trans_valid : ∀ i j trans trans',
        trans_preserve_slice i j trans trans'-> (Φ trans i j ⊣⊢ Φ trans' i j)
    }.

End slice_trans.

Global Arguments SliceTransWf {_} {_} _.
Global Arguments slice_trans_valid {_} {_} _ {_} {_} {_} {_} {_} _.
Global Hint Mode SliceTransWf + + ! : typeclass_instances.

Section slice_rxs.
  Context `{hypconst:HypervisorConstants}.
  Context `{vmG: !gen_VMG Σ}.
  Context (Φ :VMID -> option (Word * VMID)-> VMID -> iProp Σ).

  Class SliceRxsWf :=
    {
      slice_rxs_empty : ∀ i j, Φ i None j ⊣⊢ True;
      slice_rxs_sym : ∀ i os k k',
        (match os with
         | None => True
         | Some (_,j) => j ≠ V0 ->  Φ i os k ⊣⊢ Φ i os k'
         end);
    }.

End slice_rxs.

Global Arguments SliceRxsWf {_} {_} _.
Global Arguments slice_rxs_empty {_} {_} _ {_} _ _.
Global Arguments slice_rxs_sym {_} {_} _ {_} {_} {_} _ _.
Global Hint Mode SliceRxsWf + + ! : typeclass_instances.

(**  unary logical relation **)
Section logrel.
  Context `{hypconst:HypervisorConstants}.
  Context `{hypparams:!HypervisorParameters}.
  Context `{vmG: !gen_VMG Σ}.

  Definition set_of_vmids : gset VMID := (list_to_set list_of_vmids).
  Definition lift_option_gmap`{Countable K} {V: Type} (m: gmap K V) := (λ v, Some v) <$> m.
  Definition pages_in_trans (trans: gmap Word transaction) : gset PID :=
    pages_in_trans' (lift_option_gmap trans).

  Definition trans_ps_disj trans := inv_trans_ps_disj' (lift_option_gmap trans).

  Definition pgt (ps: gset PID) q (vo: VMID) (be: bool) : iProp Σ :=
    [∗ set] p ∈ ps, p -@{q}O> vo ∗ p -@{q}E> be.

  Definition pgt_full ps vo be := pgt ps 1 vo be.
  Definition pgt_3_4 ps vo be : iProp Σ := pgt ps (1/4) vo be ∗ pgt ps (1/2) vo be.
  Definition pgt_1_4 ps vo be : iProp Σ := pgt ps (1/4) vo be.

  (** definitions **)

   (* [transaction_pagetable_entries_transferred] : For donation, the half of transaction entries that are kept by sender in case
      of sharing and lending are also be passed around between the sender and the receiver, as retrieval in this case also requires
      full entries.
      Pagetable entries are transferred along as both sender and receiver could be the exclusive owner of those pages. *)
  Definition transaction_pagetable_entries_transferred i (trans: gmap Addr transaction) : iProp Σ:=
    big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i) ∧ kv.2.1.2 = Donation) (λ k v, k -{1/4}>t v.1 ∗ pgt_1_4 v.1.1.2 v.1.1.1.1 true)%I.

  (* [retrieval entries]: half of all retrieval entries of i-related transactions are required.
     For transactions where i is the sender, we need the corresponding retrieval entries to check if it is allowed for i to reclaim,
     for the cases when i is the receiver, they are required so that i can retrieve or relinquish *)
  (* There are also some cases when we need the second half, as in those cases we may update/remove the retrival state *)
  (* XXX: How to relate retrieval and transaction entries? Using option(frac_agree transaction,option bool)? or is it unnecessary? *)
  Definition retrievable_transaction_transferred i (trans: gmap Addr transaction) : iProp Σ:=
    (big_sepFM trans (λ kv, kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i) (λ k v, k -{1/2}>re v.2 )%I) ∗
    (big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i) ∧ kv.2.2 = false) (λ k v, k -{1/4}>t v.1 ∗ k -{1/2}>re v.2)%I).

  (* [transaction_pagetable_entries_owned]: transaction and page table entries that are owned initially by i,
     i.e. they are not transferred by VMProp, so we doesn't need to take care of them when reasoning the primary VM.
     As the invoker of sharing and lending transactions, i always has the ownership of involved pages.
     Therefore, i ownes these pagetable entries even if they are in some transactions.
     Furthermore, since it is suffice for the receiver to retrieve or relinquish with half of transacitons entries,
     while the sender needs full to reclaim, we let i always own half and only pass the otner half around with VMProp*)
  (* [TODO] relation to [pagetable_entries_excl_owned] *)
  Definition transaction_pagetable_entries_owned i (trans: gmap Addr transaction) : iProp Σ:=
    big_sepFM trans (λ kv, kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation) (λ k v, k -{1/4}>t v.1 ∗ pgt_1_4 v.1.1.2 v.1.1.1.1 (bool_decide (v.1.2 ≠ Sharing)))%I.

  Context (i : (leibnizO VMID)).

  (* [TODO] *)
  Definition retrieved_transaction_owned i (trans: gmap Addr transaction) : iProp Σ:=
    (big_sepFM trans (λ kv, kv.2.1.1.1.2 = i ∧ kv.2.2 = true) (λ k v, k -{1/4}>t v.1 ∗ k -{1/2}>re v.2)%I).

  Program Definition interp_execute: iPropO Σ :=
   (⌜i ≠ V0⌝ -∗
        (VMProp_holds i (1/2)%Qp -∗ WP ExecI @ i {{(λ _, True )}}))%I.

  (* [pagetable_entries_excl_owned]: For pages that are exclusively accessible and owned by i, i keeps the entries. *)
  Definition pagetable_entries_excl_owned (i:VMID) (ps: gset PID) := pgt ps 1 i true.

  (* [transaction_hpool_global_transferred]: All of half of transactions, as we don't know which one would be used by i. *)
  (* We need the pure proposition to ensure all transaction entries are transferred.
     Only half is needed so that the invokers can remember transactions by keeping the other half.*)
  Definition transaction_hpool_global_transferred (trans: gmap Addr transaction) : iProp Σ:=
    ∃ hpool,  ⌜hpool ∪ dom trans = valid_handles⌝ ∗ fresh_handles 1 hpool
       ∗ ([∗ map] h ↦ tran ∈ trans, h -{1/2}>t tran.1 ∗ pgt_3_4 tran.1.1.2 tran.1.1.1.1 (bool_decide (tran.1.2 ≠ Sharing))).

  (* [transferred_memory_pages]: some memory points-to predicates are transferred by VMProp.
      NOTE: we exclude the case when the type of transaction is lending and has been retrieved,
      as the associated memory pages in this case is exclusively owned by the receiver*)
  Definition transferred_memory_pages (trans : gmap Word transaction) :=
    pages_in_trans (filter (λ kv, (kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i) ∧ ¬(kv.2.2 = true ∧ kv.2.1.2 = Lending)) trans).

  (* [retrieved_lending_memory_pages]: the memory of these pages are owned by the receiver *)
  Definition retrieved_lending_memory_pages (trans : gmap Word transaction) :=
    pages_in_trans (filter (λ kv, kv.2.1.1.1.2 = i ∧ (kv.2.2 = true ∧ kv.2.1.2 = Lending)) trans).

  (* [accessible_in_trans_memory_pages] (maybe) accessible memory pages associated with transactions *)
  Definition accessible_in_trans_memory_pages (trans : gmap Word transaction) :=
    pages_in_trans (filter (λ kv, (kv.2.1.1.1.1 = i ∧ ¬(kv.2.2 = true ∧ kv.2.1.2 = Lending)) ∨ kv.2.1.1.1.2 = i) trans).

  (* [currently_accessible_in_trans_memory_pages] currently accessible memory pages associated with transactions *)
  Definition currently_accessible_in_trans_memory_pages (trans : gmap Word transaction) :=
    pages_in_trans (filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 = Sharing) ∨ (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans).

  Definition trans_rel_wand (P : gmap Word transaction -d> iPropO Σ) (trans trans': gmap Word transaction ): iProp Σ:=
    □(P trans -∗ P trans').

  Definition trans_rel_eq (P : gmap Word transaction -> gset PID) (trans trans': gmap Word transaction ): Prop:=
    P trans = P trans'.

  Definition rx_state_match i os : iProp Σ :=
    match os with
    | None => RX_state@i := None ∗ ∃p_rx, RX@ i := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx)
    | Some s => RX_state{1/2}@i := Some(s)
    end.

  Definition rx_states_global (rxs: gmap VMID (option (Word*VMID))) : iProp Σ :=
    [∗ map]i ↦ os ∈ rxs, rx_state_match i os.

  Definition rx_state_get (i:VMID) (rxs: gmap VMID (option (Word*VMID))) :iProp Σ:=
    ∀ rs, ⌜rxs !! i = Some rs⌝ -∗ RX_state@i := rs.

  (* (* [TODO] *) *)
  (* Definition return_reg_rx i (rs : option (Word * VMID)) (rxs :gmap VMID (option(Word*VMID))): iProp Σ:= *)
  (*   ((R0 @@ V0 ->r encode_hvc_func(Yield) ∨ *)
  (*     R0 @@ V0 ->r encode_hvc_func(Wait) ∗ ⌜rs = None⌝) *)
  (*    ∗ rx_states_global (delete i rxs) *)
  (*    ∗ R1 @@ V0 ->r encode_vmid(i) ∗ ∃ r2, R2 @@ V0 ->r r2) ∨ *)
  (*   (R0 @@ V0 ->r encode_hvc_func(Send) *)
  (*     ∗ ∃ l j, RX_state{1/2}@j := Some(l,i) ∗ (∃ p_rx, RX@ j := p_rx ∗ ∃ mem_rx, memory_page p_rx mem_rx) *)
  (*     ∗ rx_states_global (<[j:=Some(l,i)]>(delete i rxs)) ∗ ⌜rxs !! j = Some None⌝ *)
  (*     ∗ (∃r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some j⌝) ∗  R2 @@ V0 ->r l). *)

  Definition only (trans: gmap Word transaction) := (filter (λ (kv :Word*transaction), (kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i)) trans).

  Definition except (trans: gmap Word transaction) := (filter (λ (kv :Word*transaction), ¬(kv.2.1.1.1.1 = i ∨ kv.2.1.1.1.2 = i)) trans).

  (* [trans_rel_secondary] relates [trans], the transactions at the beginning of the proof, and
                [trans'], those at the point of switching to i. These assumptions are (I believe) necessary to prove FTLR.
                Moreover, they are provable because of that fact that i as the invoker is the only vm can manipulate
                the state of some transactions, and since, i is not scheduled during the time between starting pvm
                and switching to i, states of those transactions are immutable. *)
  Definition trans_rel_secondary (i:VMID) (trans trans': gmap Word transaction): Prop :=
    (λ tran, tran.1) <$> filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation)) trans' =
    (λ tran, tran.1) <$> filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation)) trans
    ∧
    (filter (λ kv, (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans') =
    (filter (λ kv, (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans).
  (* Definition trans_rel_pre (i:VMID) (trans trans': gmap Word transaction): Prop := *)
  (*   dom (filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation)) trans') *)
  (*     ⊆ dom (filter (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.2 ≠ Donation)) trans) *)
  (*   ∧ *)
  (*   dom (filter (λ kv, (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans') *)
  (*   ⊆ dom (filter (λ kv, (kv.2.1.1.1.2 = i ∧ kv.2.2 = true)) trans). *)

(* Section vmprop. *)
(*   Context `{HypervisorConstants}. *)
(*   Context `{!HypervisorParameters}. *)
(*   Context `{vmG: !gen_VMG Σ}. *)
  (* Context (i : VMID). *)
  Context (Φ_t : (gmap Addr transaction) -> VMID -> VMID -> iProp Σ).
  Context (Φ_r : VMID -> option (Word * VMID)-> VMID -> iProp Σ).

  Definition rx_states_transferred (rxs: gmap VMID (option (Word*VMID))) : iProp Σ :=
    [∗ map]i ↦ os ∈ rxs, match os with
                           | None => True
                           | Some s => Φ_r i os V0
                          end.

  Definition rx_states_owned (rxs: gmap VMID (option (Word*VMID))) : iProp Σ :=
    [∗ map]i ↦ os ∈ rxs, match os with
                           | None => True
                           | Some s => if bool_decide (s.2 = V0) then Φ_r i os i else True
                          end.

  Definition return_reg_rx i (rs : option (Word * VMID)) (rxs :gmap VMID (option(Word*VMID))): iProp Σ:=
    ((R0 @@ V0 ->r encode_hvc_func(Yield) ∨
      R0 @@ V0 ->r encode_hvc_func(Wait) ∗ ⌜rs = None⌝)
     ∗ rx_states_global (delete i rxs)
     ∗ R1 @@ V0 ->r encode_vmid(i) ∗ ∃ r2, R2 @@ V0 ->r r2) ∨
    (R0 @@ V0 ->r encode_hvc_func(Send)
      ∗ ∃ l j, Φ_r j (Some (l,i)) V0
      ∗ rx_states_global (<[j:=Some(l,i)]>(delete i rxs)) ∗ ⌜rxs !! j = Some None⌝
      ∗ (∃r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some j⌝) ∗  R2 @@ V0 ->r l).

  Definition vmprop_zero_pre (Ψ: (gmap Word transaction) -d> iPropO Σ) : (gmap Word transaction) -d> (gmap VMID (option(Word * VMID))) -d> iPropO Σ :=
    λ trans rxs, (∃ (trans' :gmap Word transaction) rs',
                     let trans_ret := (only trans') ∪ (except trans) in
                           ⌜dom (only trans') ## dom (except trans)⌝ ∗
                           ⌜∀ x, x ≠ i -> trans_rel_secondary x trans trans_ret⌝ ∗
                           transaction_hpool_global_transferred (trans_ret) ∗
                           big_sepSS_singleton set_of_vmids i (Φ_t trans_ret) ∗
                           rx_state_match i rs' ∗ Φ_r i rs' V0 ∗
                           return_reg_rx i rs' rxs ∗
                           VMProp i (Ψ trans_ret) (1/2)%Qp)%I.

  Definition vmprop_unknown_pre
    (Ψ :(gmap Word transaction) -d> iPropO Σ) : (gmap Word transaction) -d> iPropO Σ :=
   λ trans, (∃ (trans' : gmap Word transaction) (rxs : gmap VMID (option(Word * VMID))),
               ⌜trans_rel_secondary i trans trans'⌝ ∗
               (* transaction and pagetable entries *)
               transaction_hpool_global_transferred trans' ∗
               big_sepSS_singleton set_of_vmids i (Φ_t trans') ∗
               (∃ r0, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗ (∃ r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝)∗ (∃ r2, R2 @@ V0 ->r r2) ∗
               (∀ rs : option (Addr * VMID), ⌜rxs !! i = Some rs⌝ -∗ rx_state_match i rs ∗ Φ_r i rs i) ∗
               (* rx pages for all other VMs *)
               (rx_states_global (delete i rxs)) ∗ ⌜is_total_gmap rxs⌝ ∗
               (* if i yielding, we give following resources back to pvm *)
               VMProp V0 (vmprop_zero_pre Ψ trans' rxs) (1/2)%Qp)%I.

  Local Instance vmprop_unknown_pre_contractive : Contractive (vmprop_unknown_pre).
  Proof.
    rewrite /vmprop_unknown_pre => n vmprop_unknown vmprop_unknown' Hvmprop_unknown trans /=.
    do 13 f_equiv.
    rewrite /VMProp /=.
    do 6 f_equiv.
    f_contractive.
    rewrite /vmprop_zero_pre.
    do 10 f_equiv.
    rewrite /VMProp.
    repeat f_equiv.
  Qed.

  Definition vmprop_unknown:= fixpoint (vmprop_unknown_pre).

  Definition vmprop_zero := vmprop_zero_pre vmprop_unknown.

  Lemma vmprop_unknown_eq trans: vmprop_unknown trans ⊣⊢
    (∃ (trans' : gmap Word transaction) (rxs : gmap VMID (option(Word * VMID))),
               ⌜trans_rel_secondary i trans trans'⌝ ∗
               (* transaction and pagetable entries *)
               transaction_hpool_global_transferred trans' ∗
               big_sepSS_singleton set_of_vmids i (Φ_t trans') ∗
               (∃ r0, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗ (∃ r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝)∗ (∃ r2, R2 @@ V0 ->r r2) ∗
               (∀ rs : option (Addr * VMID), ⌜rxs !! i = Some rs⌝ -∗ rx_state_match i rs ∗ Φ_r i rs i) ∗
               (* rx pages for all other VMs *)
               (rx_states_global (delete i rxs)) ∗ ⌜is_total_gmap rxs⌝ ∗
               (* if i yielding, we give following resources back to pvm *)
          VMProp V0 (vmprop_zero trans' rxs) (1/2)%Qp)%I.
  Proof.
    rewrite /vmprop_unknown.
    apply (fixpoint_unfold vmprop_unknown_pre).
  Qed.

  (* Definition vmprop_zero_pre (Ψ: (gmap Word transaction) -d> iPropO Σ) : (gmap Word transaction) -d> (gmap VMID (option(Word*VMID))) -d> iPropO Σ := *)
  (*   λ trans rxs, (∃ trans' rs', *)
  (*                    let trans_ret := (only trans') ∪ (except trans) in *)
  (*                          ⌜dom (only trans') ## dom (except trans)⌝ ∗ *)
  (*                          ⌜∀ x, x ≠ i -> trans_rel_secondary x trans trans_ret⌝ ∗ *)
  (*                          (* transaction and pagetable entries *) *)
  (*                          transaction_hpool_global_transferred trans_ret ∗ *)
  (*                          transaction_pagetable_entries_transferred i trans_ret ∗ *)
  (*                          retrievable_transaction_transferred i trans_ret ∗ *)
  (*                          (* memory *) *)
  (*                          (∃ mem_trans, memory_pages (transferred_memory_pages trans_ret) mem_trans) ∗ *)
  (*                          (RX_state@i:= rs') ∗ (∃p_rx, RX@i := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx)) ∗ *)
  (*                          return_reg_rx i rs' rxs ∗ *)
  (*                          VMProp i (Ψ trans_ret) (1/2)%Qp)%I. *)

  (* Definition vmprop_unknown_pre (Φ: (gmap Word transaction) -d> iPropO Σ) : (gmap Word transaction) -d> iPropO Σ := *)
  (*  λ trans, (∃ (trans' : gmap Word transaction) (rxs : gmap VMID (option(Word * VMID))), *)
  (*              ⌜trans_rel_secondary i trans trans'⌝ ∗ *)
  (*              (* transaction and pagetable entries *) *)
  (*              transaction_hpool_global_transferred trans' ∗ *)
  (*              transaction_pagetable_entries_transferred i trans' ∗ *)
  (*              retrievable_transaction_transferred i trans' ∗ *)
  (*              (* memory *) *)
  (*              (∃ mem_trans, memory_pages (transferred_memory_pages trans') mem_trans) ∗ *)
  (*              (∃ r0, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗ (∃ r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝)∗ (∃ r2, R2 @@ V0 ->r r2) ∗ *)
  (*              (rx_state_get i rxs ∗ (∃p_rx, RX@i := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx))) ∗ *)
  (*              (* rx pages for all other VMs *) *)
  (*              rx_states_global (delete i rxs) ∗ ⌜is_total_gmap rxs⌝ ∗ *)
  (*              (* if i yielding, we give following resources back to pvm *) *)
  (*              VMProp V0 (vmprop_zero_pre Φ trans' rxs) (1/2)%Qp)%I. *)

  (* Local Instance vmprop_unknown_pre_contractive : Contractive (vmprop_unknown_pre). *)
  (* Proof. *)
  (*   rewrite /vmprop_unknown_pre => n vmprop_unknown vmprop_unknown' Hvmprop_unknown trans /=. *)
  (*   do 15 f_equiv. *)
  (*   rewrite /VMProp /=. *)
  (*   do 6 f_equiv. *)
  (*   f_contractive. *)
  (*   rewrite /vmprop_zero_pre. *)
  (*   do 12 f_equiv. *)
  (*   rewrite /VMProp. *)
  (*   repeat f_equiv. *)
  (*   (* apply Hvmprop_unknown. *) *)
  (* Qed. *)

  (* Definition vmprop_unknown := fixpoint (vmprop_unknown_pre). *)

  (* Definition vmprop_zero := vmprop_zero_pre vmprop_unknown. *)

  (* Lemma vmprop_unknown_eq trans : vmprop_unknown trans ⊣⊢ *)
  (*   (∃ (trans' : gmap Word transaction) (rxs : gmap VMID (option(Word * VMID))), *)
  (*              ⌜trans_rel_secondary i trans trans'⌝ ∗ *)
  (*              (* transaction and pagetable entries *) *)
  (*              transaction_hpool_global_transferred trans' ∗ *)
  (*              transaction_pagetable_entries_transferred i trans' ∗ *)
  (*              retrievable_transaction_transferred i trans' ∗ *)
  (*              (* memory *) *)
  (*              (∃ mem_trans, memory_pages (transferred_memory_pages trans') mem_trans) ∗ *)
  (*              (∃ r0, R0 @@ V0 ->r r0 ∗ ⌜decode_hvc_func r0 = Some Run⌝) ∗ (∃ r1, R1 @@ V0 ->r r1 ∗ ⌜decode_vmid r1 = Some i⌝)∗ (∃ r2, R2 @@ V0 ->r r2) ∗ *)
  (*              (rx_state_get i rxs ∗ (∃p_rx, RX@i := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx))) ∗ *)
  (*              (* rx pages for all other VMs *) *)
  (*              rx_states_global (delete i rxs) ∗ ⌜is_total_gmap rxs⌝ ∗ *)
  (*              (* if i yielding, we give following resources back to pvm *) *)
  (*              VMProp V0 (vmprop_zero trans' rxs) (1/2)%Qp)%I. *)
  (*   Proof. *)
  (*     rewrite /vmprop_unknown. *)
  (*     apply (fixpoint_unfold vmprop_unknown_pre). *)
  (*   Qed. *)

  Definition transferred_memory_slice (trans : gmap Addr transaction) (i: VMID) (j:VMID): iProp Σ:=
    big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) ∧ ¬(kv.2.2 = true ∧ kv.2.1.2 = Lending)) (λ _ tran, (∃ mem , memory_pages tran.1.1.2 mem)%I).

  Definition retrievable_transaction_transferred_slice (trans : gmap Addr transaction) (i:VMID) (j: VMID) : iProp Σ :=
    (big_sepFM trans (λ kv, kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) (λ k v, k -{1/2}>re v.2 )%I) ∗
    (big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) ∧ kv.2.2 = false) (λ k v, k -{1/4}>t v.1 ∗ k -{1/2}>re v.2)%I).

  Definition transaction_pagetable_entries_transferred_slice (trans: gmap Addr transaction) (i: VMID) (j: VMID) : iProp Σ :=
    big_sepFM trans (λ kv, (kv.2.1.1.1.1 = i ∧ kv.2.1.1.1.2 = j) ∧ kv.2.1.2 = Donation) (λ k v, k -{1/4}>t v.1 ∗ pgt_1_4 v.1.1.2 v.1.1.1.1 true)%I.

  Definition slice_transfer_all :=
    (λ trans i j, transaction_pagetable_entries_transferred_slice trans i j
                ∗ retrievable_transaction_transferred_slice trans i j
                ∗ transferred_memory_slice trans i j)%I.

  Definition slice_rx_state (j : VMID) (os : option (Word * VMID)) : iProp Σ :=
    (RX_state{1/2}@j := os) ∗ ∃ p_rx, RX@ j := p_rx ∗ (∃ mem_rx, memory_page p_rx mem_rx).

  Definition interp_access p_tx p_rx ps_acc trans: iPropO Σ:=
    (
      (* exclusively owned pages are pages i has access to, but ain't in any transactions related to i. *)
      (* [ps_oea], we exclude all pages involved in in-flight transactions,
       NOTE: it has to be (currently_accessible_in_trans_memory_pages)*)
      let ps_oea := ps_acc ∖ {[p_rx;p_tx]} ∖ (currently_accessible_in_trans_memory_pages trans) in
      ⌜∀ k j trans, (k = i ∨ j = i) -> Φ_t trans k j ⊣⊢ slice_transfer_all trans k j⌝ ∗
      ⌜∀ os, (match os with
                 | None => True
                 | _ => Φ_r i os i ⊣⊢ slice_rx_state i os
                end)⌝ ∗
      ⌜∀ os, (match os with
                 | None => True
                 | _ => Φ_r i os V0 ⊣⊢ slice_rx_state i os
                end)⌝ ∗
      ⌜∀ k os, (match os with
          | None => True
          | Some (_, j) => j = i -> Φ_r k os V0 ⊣⊢ slice_rx_state k os
          end)⌝ ∗
      ⌜∀ i j, Φ_r i None j ⊣⊢ True⌝ ∗
      (* registers *)
      (∃ regs, ⌜is_total_gmap regs⌝ ∗ [∗ map] r ↦ w ∈ regs, r @@ i ->r w) ∗
      (* TX page and its memory *)
      (tx_page i p_tx ∗ ∃ mem_tx, memory_page p_tx mem_tx) ∗
      rx_page i p_rx ∗
      (* access *)
      i -@A> ps_acc ∗
      ⌜{[p_tx;p_rx]} ⊆ ps_acc⌝ ∗ ⌜currently_accessible_in_trans_memory_pages trans ⊆ ps_acc ∖ {[p_tx;p_rx]}⌝ ∗
      pagetable_entries_excl_owned i ps_oea ∗
      transaction_pagetable_entries_owned i trans ∗
      retrieved_transaction_owned i trans ∗
      (∃ mem_oea, memory_pages (ps_oea ∪ (retrieved_lending_memory_pages trans)) mem_oea) ∗
      VMProp i (vmprop_unknown trans) (1/2)%Qp
    )%I.

End logrel.


Set Warnings "-notation-overridden".

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.
Require Import Category.Instance.Coq.

Require Import Embed.Theory.Functor.Void.
Require Import Embed.Theory.Functor.Refined.Def.
Require Import Embed.Theory.Functor.Refined.Iso.

Require Import Embed.Theory.Btree.
Require Import Embed.Theory.Btree.Functor.
Require Import Embed.Theory.Btree.Monad.

Require Import Embed.Theory.Btree.Refined.Iso.
Require Import Embed.Theory.Btree.Refined.Leaves.
Require Import Embed.Theory.Btree.Refined.Join.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Lemma iso_refined_btree_void_ret {A} (x : @btree A)
  (pf : iso_refined (void[btree_Functor] x) (bnil ())) :
    { y | ret y = x}.
destruct x.
exact (exist _ a eq_refl).
unfold void in pf.
simpl in pf.
unfold ret_btree in pf.
rewrite fmap_btree_equation_2 in pf.
pose (not_iso_refined_bcons_bnil (fmap_btree (λ _ : A, ()) x1) (fmap_btree (λ _ : A, ()) x2)).
destruct (f pf).
Qed.

Lemma iso_refined_btree_void_ret_join {A} (x : @btree (@btree A))
  (pf : iso_refined (void x) (ret tt)) :
  ret (join x) = x.
destruct x.

reflexivity.

rewrite join_btree_equation_2.
destruct (iso_refined_btree_void_ret (bcons x1 x2) pf).
simpl in e.
unfold ret_btree in e.
discriminate.
Qed.

Lemma iso_refined_btree_void_join (x : @btree (@btree 1)) (y : @btree 1)
  (pf : iso_refined (join[btree_Functor] x) y) (A : Type) :
    @refined (Compose btree_Functor btree_Functor) x A ≅ refined y A.
pose (pf A).
exact (iso_compose _ (piso_refined_btree x)).
Defined.


Set Implicit Arguments.

Require Import AutoSep.

Definition NameNotInImports name imports :=
  fold_left
    (fun (b : bool) (p : string * string * assert) =>
       let '(m, _, _) := p in
       (b || (if string_dec m name then true else false))%bool)
    imports false = false.

Definition fst_2 A B C (x : A * B * C) := fst (fst x).
Notation fst2 := (@fst_2 _ _ _).

Lemma NotIn_NameNotInImports : forall imps mn, ~ In mn (map fst2 imps) -> NameNotInImports mn imps.
  clear.
  unfold NameNotInImports.
  induction imps; simpl; intros.
  eauto.
  destruct a; destruct p; simpl in *.
  destruct (string_dec s mn).
  contradict H.
  eauto.
  eapply IHimps.
  intuition.
Qed.

Definition f mod_name (mOpt : option (LabelMap.t unit))
           (p : string * assert *
                (forall imports : LabelMap.t assert,
                   importsGlobal imports -> cmd imports mod_name)) :=
  let '(modl, _, _) := p in
  match mOpt with
    | Some m =>
      let k := (modl, Local 0) in
      if LabelMap.mem (elt:=unit) k m
      then None
      else Some (LabelMap.add k tt m)
    | None => None
  end.

Definition NoDupFuncNames' init mod_name funcs :=
  match fold_left (@f mod_name) funcs (Some init)
  with
    | Some _ => True
    | None => False
  end.

Definition NoDupFuncNames := NoDupFuncNames' (LabelMap.empty unit).

Lemma NoDup_NoDupFuncNames' :
  forall mod_name funcs init,
    let names := map (fun f => fst (fst f)) funcs in
    NoDup names ->
    (forall x, List.In x names -> LabelMap.mem (elt := unit) (x, Local 0) init = false) ->
    @NoDupFuncNames' init mod_name funcs.
Proof.
  induction funcs; simpl; intuition.
  compute; eauto.
  unfold NoDupFuncNames' in *; simpl in *.
  erewrite H0 by eauto.
  eapply IHfuncs.
  inversion H; subst; eauto.
  intros.
  erewrite LabelFacts.add_neq_b.
  eapply H0.
  eauto.
  intuition.
  injection H2; intros.
  subst.
  inversion H; subst.
  contradiction.
Qed.

Lemma NoDup_NoDupFuncNames : forall mod_name funcs, NoDup (map (fun f => fst (fst f)) funcs) -> @NoDupFuncNames mod_name funcs.
  intros.
  eapply NoDup_NoDupFuncNames'.
  eauto.
  intros.
  eauto.
Qed.