Require Import CoqlibC.
Require Import Simulation.
Require Import LinkingC.
Require Import Skeleton.
Require Import Values.
Require Import JMeq.
Require Import SmallstepC.
Require Import Integers.
Require Import Events.

Require Import Skeleton ModSem Mod Sem.
Require Import SimSymb SimMem SimMod SimModSem SimProg SimProg.
Require Import ModSemProps SemProps Ord.
Require Import Sound Preservation AdequacySound.
Require Import Program RUSC.

Set Implicit Arguments.

Section SIMGE.

  Context `{SM: SimMem.class}.
  Context `{SU: Sound.class}.
  Context {SS: SimSymb.class SM}.
  Inductive sim_ge (sm0: SimMem.t): Ge.t -> Ge.t -> Prop :=
  | sim_ge_src_stuck
      ge_tgt skenv_link_src skenv_link_tgt:
      sim_ge sm0 ([], skenv_link_src) (ge_tgt, skenv_link_tgt)
  | sim_ge_intro
      msps ge_src ge_tgt skenv_link_src skenv_link_tgt
      (SIMSKENV: List.Forall (fun msp => ModSemPair.sim_skenv msp sm0) msps)
      (SIMMSS: List.Forall (ModSemPair.sim) msps)
      (GESRC: ge_src = (map (ModSemPair.src) msps))
      (GETGT: ge_tgt = (map (ModSemPair.tgt) msps))
      (SIMSKENVLINK: exists ss_link, SimSymb.sim_skenv sm0 ss_link skenv_link_src skenv_link_tgt)
      (MFUTURE: List.Forall (fun msp => SimMem.future msp.(ModSemPair.sm) sm0) msps)
      (SESRC: List.Forall (fun ms => (ModSem.to_semantics ms).(symbolenv) = skenv_link_src) ge_src)
      (SETGT: List.Forall (fun ms => (ModSem.to_semantics ms).(symbolenv) = skenv_link_tgt) ge_tgt):
      sim_ge sm0 (ge_src, skenv_link_src) (ge_tgt, skenv_link_tgt).

  Lemma find_fptr_owner_fsim
        sm0 ge_src ge_tgt fptr_src fptr_tgt ms_src
        (SIMGE: sim_ge sm0 ge_src ge_tgt)
        (SIMFPTR: SimMem.sim_val sm0 fptr_src fptr_tgt)
        (FINDSRC: Ge.find_fptr_owner ge_src fptr_src ms_src):
      exists msp,
        <<SRC: msp.(ModSemPair.src) = ms_src>>
        /\ <<FINDTGT: Ge.find_fptr_owner ge_tgt fptr_tgt msp.(ModSemPair.tgt)>>
        /\ <<SIMMS: ModSemPair.sim msp>>
        /\ <<SIMSKENV: ModSemPair.sim_skenv msp sm0>>
        /\ <<MFUTURE: SimMem.future msp.(ModSemPair.sm) sm0>>.
  Proof.
    inv SIMGE.
    { inv FINDSRC; ss. }
    rewrite Forall_forall in *. inv FINDSRC. ss.
    rewrite in_map_iff in MODSEM. des. rename x into msp. esplits; eauto. clarify.
    specialize (SIMMSS msp). exploit SIMMSS; eauto. clear SIMMSS. intro SIMMS.
    specialize (SIMSKENV msp). exploit SIMSKENV; eauto. clear SIMSKENV. intro SIMSKENV.

    exploit SimSymb.sim_skenv_func_bisim; try apply SIMSKENV. intro SIMFUNC; des.
    inv SIMFUNC. exploit FUNCFSIM; eauto. i; des. clear_tac. inv SIM. econs; eauto.
    apply in_map_iff. esplits; eauto.

  Qed.

  Theorem mfuture_preserves_sim_ge
          sm0 ge_src ge_tgt sm1
          (SIMGE: sim_ge sm0 ge_src ge_tgt)
          (MFUTURE: SimMem.future sm0 sm1):
      <<SIMGE: sim_ge sm1 ge_src ge_tgt>>.
  Proof.
    inv SIMGE.
    { econs; eauto. }
    econs 2; try reflexivity; eauto.
    - rewrite Forall_forall in *. ii. eapply ModSemPair.mfuture_preserves_sim_skenv; eauto.
    - des. esplits; eauto. eapply SimSymb.mfuture_preserves_sim_skenv; eauto.
    - rewrite Forall_forall in *. ii. etrans; eauto.
  Qed.

  Lemma sim_ge_cons
        sm_init tl_src tl_tgt msp skenv_link_src skenv_link_tgt
        (SAFESRC: tl_src <> [])
        (SIMMSP: ModSemPair.sim msp)
        (SIMGETL: sim_ge sm_init (tl_src, skenv_link_src) (tl_tgt, skenv_link_tgt))
        (SIMSKENV: ModSemPair.sim_skenv msp sm_init)
        (MFUTURE: SimMem.future (ModSemPair.sm msp) sm_init)
        (SESRC: (symbolenv (ModSemPair.src msp)) = skenv_link_src)
        (SETGT: (symbolenv (ModSemPair.tgt msp)) = skenv_link_tgt):
      <<SIMGE: sim_ge sm_init (msp.(ModSemPair.src) :: tl_src, skenv_link_src)
                      (msp.(ModSemPair.tgt) :: tl_tgt, skenv_link_tgt)>>.
  Proof. red. inv SIMGETL; ss. econstructor 2 with (msps := msp :: msps); eauto. Qed.

  Lemma to_msp_tgt: forall skenv_tgt skenv_src pp sm_init,
          map ModSemPair.tgt (map (ModPair.to_msp skenv_src skenv_tgt sm_init) pp) =
          map (fun md => Mod.modsem md skenv_tgt) (ProgPair.tgt pp).
  Proof. i. ginduction pp; ii; ss. f_equal. erewrite IHpp; eauto. Qed.

  Lemma to_msp_src: forall skenv_tgt skenv_src pp sm_init,
      map ModSemPair.src (map (ModPair.to_msp skenv_src skenv_tgt sm_init) pp) =
      map (fun md => Mod.modsem md skenv_src) (ProgPair.src pp).
  Proof. i. ginduction pp; ii; ss. f_equal. erewrite IHpp; eauto. Qed.

  Lemma to_msp_sim_skenv
        sm_init mp skenv_src skenv_tgt ss_link
        (WFSRC: SkEnv.wf skenv_src)
        (WFTGT: SkEnv.wf skenv_tgt)
        (INCLSRC: SkEnv.includes skenv_src (Mod.sk mp.(ModPair.src)))
        (INCLTGT: SkEnv.includes skenv_tgt (Mod.sk mp.(ModPair.tgt)))
        (SIMMP: ModPair.sim mp)
        (LESS: SimSymb.le (ModPair.ss mp) ss_link)
        (SIMSKENV: SimSymb.sim_skenv sm_init ss_link skenv_src skenv_tgt):
        <<SIMSKENV: ModSemPair.sim_skenv (ModPair.to_msp skenv_src skenv_tgt sm_init mp) sm_init>>.
  Proof.
    u. econs; ss; eauto; cycle 1.
    { rewrite ! Mod.get_modsem_skenv_link_spec. eauto. }
    inv SIMMP.
    eapply SimSymb.sim_skenv_monotone; revgoals; try rewrite SKSRC; try rewrite SKTGT; try eapply Mod.get_modsem_skenv_spec; try eapply SIMMP; ss; eauto.
  Qed.

  Theorem init_sim_ge_strong
          pp p_src p_tgt ss_link skenv_link_src skenv_link_tgt m_src
          (NOTNIL: pp <> [])
          (SIMPROG: ProgPair.sim pp)
          (PSRC: p_src = (ProgPair.src pp))
          (PTGT: p_tgt = (ProgPair.tgt pp))
          (SSLE: Forall (fun mp => SimSymb.le (ModPair.ss mp) ss_link) pp)
          (SIMSK: SimSymb.wf ss_link)
          (SKSRC: link_sk p_src = Some ss_link.(SimSymb.src))
          (SKTGT: link_sk p_tgt = Some ss_link.(SimSymb.tgt))
          (SKENVSRC: Sk.load_skenv ss_link.(SimSymb.src) = skenv_link_src)
          (SKENVTGT: Sk.load_skenv ss_link.(SimSymb.tgt) = skenv_link_tgt)
          (WFSKSRC: forall mp (IN: In mp pp), Sk.wf (ModPair.src mp))
          (WFSKTGT: forall mp (IN: In mp pp), Sk.wf (ModPair.tgt mp))
          (LOADSRC: Sk.load_mem ss_link.(SimSymb.src) = Some m_src):
      exists sm_init, <<SIMGE: sim_ge sm_init
                                      (load_genv p_src (Sk.load_skenv ss_link.(SimSymb.src)))
                                      (load_genv p_tgt (Sk.load_skenv ss_link.(SimSymb.tgt)))>>
         /\ <<MWF: SimMem.wf sm_init>>
         /\ <<LOADTGT: Sk.load_mem ss_link.(SimSymb.tgt) = Some sm_init.(SimMem.tgt)>>
         /\ <<MSRC: sm_init.(SimMem.src) = m_src>>
         /\ (<<SIMSKENV: SimSymb.sim_skenv sm_init ss_link skenv_link_src skenv_link_tgt>>)
         /\ (<<INCLSRC: forall mp (IN: In mp pp), SkEnv.includes skenv_link_src (Mod.sk mp.(ModPair.src))>>)
         /\ (<<INCLTGT: forall mp (IN: In mp pp), SkEnv.includes skenv_link_tgt (Mod.sk mp.(ModPair.tgt))>>)
         /\ (<<SSLE: forall mp (IN: In mp pp), SimSymb.le mp.(ModPair.ss) ss_link>>)
         /\ (<<MAINSIM: SimMem.sim_val sm_init (Genv.symbol_address skenv_link_src ss_link.(SimSymb.src).(prog_main) Ptrofs.zero)
                                             (Genv.symbol_address skenv_link_tgt ss_link.(SimSymb.tgt).(prog_main) Ptrofs.zero)>>).
  Proof.
    assert(INCLSRC: forall mp (IN: In mp pp), SkEnv.includes skenv_link_src (Mod.sk mp.(ModPair.src))).
    { ii. clarify. eapply link_includes; eauto.
      unfold ProgPair.src. rewrite in_map_iff. esplits; et. }
    assert(INCLTGT: forall mp (IN: In mp pp), SkEnv.includes skenv_link_tgt (Mod.sk mp.(ModPair.tgt))).
    { ii. clarify. eapply link_includes; eauto.
      unfold ProgPair.tgt. rewrite in_map_iff. esplits; et. }
    clarify. exploit SimSymb.wf_load_sim_skenv; eauto. i; des. rename sm into sm_init. clarify.
    esplits; eauto; cycle 1.
    { rewrite Forall_forall in *. eauto. }
    unfold load_genv in *. ss. bar.
    assert(exists msp_sys,
              (<<SYSSRC: msp_sys.(ModSemPair.src) = System.modsem (Sk.load_skenv ss_link.(SimSymb.src))>>)
              /\ (<<SYSTGT: msp_sys.(ModSemPair.tgt) = System.modsem (Sk.load_skenv ss_link.(SimSymb.tgt))>>)
              /\ <<SYSSIM: ModSemPair.sim msp_sys>> /\ <<SIMSKENV: ModSemPair.sim_skenv msp_sys sm_init>>
              /\ (<<MFUTURE: SimMem.future msp_sys.(ModSemPair.sm) sm_init>>)).
    { exploit SimSymb.system_sim_skenv; eauto. i; des.
      eexists (ModSemPair.mk _ _ ss_link sm_init). ss. esplits; eauto.
      - exploit system_local_preservation. intro SYSSU; des. econs.
        { ss. eauto. }
        { instantiate (2:= Empty_set). ii; ss. }
        ii. inv SIMSKENV0. ss.
        split; cycle 1.
        { ii; des. inv SAFESRC. inv SIMARGS; ss. esplits; eauto. econs; eauto. }
        ii. sguard in SAFESRC. des. inv INITTGT.
        inv SIMARGS; ss. clarify.
        esplits; eauto.
        { refl. }
        { econs; eauto. }
        pfold.
        econs; eauto.
        i.
        econs; ss; cycle 2.
        { eapply System.modsem_receptive; et. }
        { u. esplits; ii; des; ss; eauto. inv H0. }
        ii. inv STEPSRC.
        exploit SimSymb.system_axiom; eauto; swap 1 3; swap 2 4.
        { econs; eauto. }
        { ss. instantiate (1:= Retv.mk _ _). ss. eauto. }
        { ss. }
        { ss. }
        i; des.
        assert(SIMGE: SimSymb.sim_skenv sm_arg ss_link (System.globalenv (Sk.load_skenv ss_link.(SimSymb.src)))
                                        (System.globalenv (Sk.load_skenv ss_link.(SimSymb.tgt)))).
        { eapply SimSymb.mfuture_preserves_sim_skenv; eauto. }
        hexpl SimSymb.sim_skenv_func_bisim SIMGE0.
        inv SIMGE0. exploit FUNCFSIM; eauto. i; des. clarify.
        esplits; eauto.
        { left. apply plus_one. econs.
          - eapply System.modsem_determinate; et.
          - ss. econs; eauto. }
        left. pfold.
        econs 4.
        { refl. }
        { eauto. }
        { econs; eauto. }
        { econs; eauto. }
        { inv RETV; ss. unfold Retv.mk in *. clarify. econs; ss; eauto. }
    }
    des. rewrite <- SYSSRC. rewrite <- SYSTGT. eapply sim_ge_cons; ss.
    - ii. destruct pp; ss.
    - clear_until_bar. clear TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT.
      ginduction pp; ii; ss. unfold link_sk in *. ss. rename a into mp. destruct (classic (pp = [])).
      { clarify. ss. clear IHpp. inv SSLE. inv H2. cbn in *. clarify.
        rename H0 into SKSRC. rename H2 into SKTGT.
        rewrite <- SKSRC in *. rewrite <- SKTGT in *.
        set (skenv_src := (Sk.load_skenv (ModPair.src mp))) in *.
        set (skenv_tgt := (Sk.load_skenv (ModPair.tgt mp))) in *.
        inv SIMPROG. inv H3. rename H2 into SIMMP. inv SIMMP.
        econstructor 2 with (msps := (map (ModPair.to_msp skenv_src skenv_tgt sm_init) [mp])); eauto; ss; revgoals; econs; eauto.
        - u. erewrite Mod.get_modsem_skenv_link_spec; ss.
        - u. erewrite Mod.get_modsem_skenv_link_spec; ss.
        -  eapply SIMMS; eauto; eapply SkEnv.load_skenv_wf; et.
        - econs; ss; eauto; cycle 1.
          { unfold Mod.modsem. rewrite ! Mod.get_modsem_skenv_link_spec. eauto. }
          r. ss. eapply SimSymb.sim_skenv_monotone; try rewrite SKSRC0; try rewrite SKTGT0;
                   try apply SIMSKENV; try eapply SkEnv.load_skenv_wf; try eapply Mod.get_modsem_skenv_spec; eauto.
      }
      rename H into NNIL.
      apply link_list_cons_inv in SKSRC; cycle 1. { destruct pp; ss. } des. rename restl into sk_src_tl.
      apply link_list_cons_inv in SKTGT; cycle 1. { destruct pp; ss. } des. rename restl into sk_tgt_tl.
      inv SIMPROG. rename H1 into SIMMP. rename H2 into SIMPROG. inv SSLE. rename H1 into SSLEHD. rename H2 into SSLETL. unfold flip.
      set (skenv_src := (Sk.load_skenv (SimSymb.src ss_link))) in *.
      set (skenv_tgt := (Sk.load_skenv (SimSymb.tgt ss_link))) in *.
      assert(WFSRC: SkEnv.wf skenv_src).
      { eapply SkEnv.load_skenv_wf; et.
        eapply (link_list_preserves_wf_sk ((ModPair.src mp) :: (ProgPair.src pp))); et.
        - unfold link_sk. ss. eapply link_list_cons; et.
        - ii; ss. des; clarify; et. unfold ProgPair.src in *. rewrite in_map_iff in *. des. clarify. et.
      }
      assert(WFTGT: SkEnv.wf skenv_tgt).
      { eapply SkEnv.load_skenv_wf; et.
        eapply (link_list_preserves_wf_sk ((ModPair.tgt mp) :: (ProgPair.tgt pp))); et.
        - unfold link_sk. ss. eapply link_list_cons; et.
        - ii; ss. des; clarify; et. unfold ProgPair.tgt in *. rewrite in_map_iff in *. des. clarify. et.
      }
      econstructor 2 with
          (msps := (map (ModPair.to_msp skenv_src skenv_tgt sm_init) (mp :: pp))); eauto; revgoals.
      + rewrite Forall_forall in *. i. ss. des; clarify.
        { u. erewrite Mod.get_modsem_skenv_link_spec; ss. }
        u in H. rewrite in_map_iff in H. des; clarify.
        { u. erewrite Mod.get_modsem_skenv_link_spec; ss. }
      + rewrite Forall_forall in *. i. ss. des; clarify.
        { u. erewrite Mod.get_modsem_skenv_link_spec; ss. }
        u in H. rewrite in_map_iff in H. des; clarify.
        { u. erewrite Mod.get_modsem_skenv_link_spec; ss. }
      + ss. econs; eauto. rewrite Forall_forall in *. ii. rewrite in_map_iff in H. des. clarify. ss. refl.
      + ss. f_equal. rewrite to_msp_tgt; ss.
      + ss. f_equal. rewrite to_msp_src; ss.
      + ss. econs; ss; eauto.
        * eapply SIMMP; eauto.
        * rewrite Forall_forall in *. i. apply in_map_iff in H. des.
          specialize (SIMPROG x0). special SIMPROG; ss. clarify. eapply SIMPROG; eauto.
      + ss. econs; ss; eauto.
        * eapply to_msp_sim_skenv; eauto.
        * rewrite Forall_forall in *. i. rewrite in_map_iff in *. des. clarify. eapply to_msp_sim_skenv; eauto.
    - rewrite SYSSRC. ss.
    - rewrite SYSTGT. ss.
  Unshelve.
    all: try apply idx_bot.
    all: try (by ii; ss).
  Qed.

End SIMGE.

Section ADQMATCH.

  Context `{SM: SimMem.class}.
  Context {SS: SimSymb.class SM}.
  Context `{SU: Sound.class}.

  Variable pp: ProgPair.t.
  Let p_src := (ProgPair.src pp).
  Let p_tgt := (ProgPair.tgt pp).

  Variable sk_link_src sk_link_tgt: Sk.t.
  Hypothesis LINKSRC: (link_sk p_src) = Some sk_link_src.
  Hypothesis LINKTGT: (link_sk p_tgt) = Some sk_link_tgt.
  Let sem_src := Sem.sem p_src.
  Let sem_tgt := Sem.sem p_tgt.

  Let skenv_link_src := (Sk.load_skenv sk_link_src).
  Let skenv_link_tgt := (Sk.load_skenv sk_link_tgt).

  Inductive lxsim_stack: SimMem.t ->
                         list Frame.t -> list Frame.t -> Prop :=
  | lxsim_stack_nil
      sm0:
      lxsim_stack sm0 [] []
  | lxsim_stack_cons
      tail_src tail_tgt tail_sm ms_src lst_src0 ms_tgt lst_tgt0 sm_at sm_arg sm_arg_lift sm_init sidx
      (STACK: lxsim_stack tail_sm tail_src tail_tgt)
      (MWF: SimMem.wf sm_arg)
      (GE: sim_ge sm_at sem_src.(globalenv) sem_tgt.(globalenv))
      (MLE: SimMem.le tail_sm sm_at)
      (MLE: SimMem.le sm_at sm_arg)
      (MLELIFT: SimMem.lepriv sm_arg sm_arg_lift)
      (MLE: SimMem.le sm_arg_lift sm_init)
      (sound_states_local: sidx -> Sound.t -> Memory.Mem.mem -> ms_src.(ModSem.state) -> Prop)
      (PRSV: forall si, local_preservation_noguarantee ms_src (sound_states_local si))
      (K: forall sm_ret retv_src retv_tgt lst_src1
          (MLE: SimMem.le sm_arg_lift sm_ret)
          (MWF: SimMem.wf sm_ret)
          (SIMRETV: SimMem.sim_retv retv_src retv_tgt sm_ret)
          (SU: forall si, exists su m_arg, (sound_states_local si) su m_arg lst_src0)
          (AFTERSRC: ms_src.(ModSem.after_external) lst_src0 retv_src lst_src1),
          exists lst_tgt1 sm_after i1,
            (<<AFTERTGT: ms_tgt.(ModSem.after_external) lst_tgt0 retv_tgt lst_tgt1>>)
            /\ (<<MLEPUB: SimMem.le sm_at sm_after>>)
            /\ (<<LXSIM: lxsim ms_src ms_tgt (fun st => forall si, exists su m_arg, (sound_states_local si) su m_arg st)
                            i1 lst_src1 lst_tgt1 sm_after>>))
      (SESRC: (ModSem.to_semantics ms_src).(symbolenv) = skenv_link_src)
      (SETGT: (ModSem.to_semantics ms_tgt).(symbolenv) = skenv_link_tgt):
      lxsim_stack sm_init
                  ((Frame.mk ms_src lst_src0) :: tail_src)
                  ((Frame.mk ms_tgt lst_tgt0) :: tail_tgt).

  Lemma lxsim_stack_le
        sm0 frs_src frs_tgt sm1
        (SIMSTACK: lxsim_stack sm0 frs_src frs_tgt)
        (MLE: SimMem.le sm0 sm1):
      <<SIMSTACK: lxsim_stack sm1 frs_src frs_tgt>>.
  Proof.
    inv SIMSTACK.
    { econs 1; eauto. }
    econs 2; eauto. etransitivity; eauto.
  Qed.

  Inductive lxsim_lift: idx -> sem_src.(Smallstep.state) -> sem_tgt.(Smallstep.state) -> SimMem.t -> Prop :=
  | lxsim_lift_intro
      sm0 tail_src tail_tgt tail_sm i0 ms_src lst_src ms_tgt lst_tgt sidx
      (GE: sim_ge sm0 sem_src.(globalenv) sem_tgt.(globalenv))

      (STACK: lxsim_stack tail_sm tail_src tail_tgt)
      (MLE: SimMem.le tail_sm sm0)
      (sound_states_local: sidx -> Sound.t -> Memory.Mem.mem -> ms_src.(ModSem.state) -> Prop)
      (PRSV: forall si, local_preservation_noguarantee ms_src (sound_states_local si))
      (TOP: lxsim ms_src ms_tgt (fun st => forall si, exists su m_arg, (sound_states_local si) su m_arg st)
                  i0 lst_src lst_tgt sm0)
      (SESRC: (ModSem.to_semantics ms_src).(symbolenv) = skenv_link_src)
      (SETGT: (ModSem.to_semantics ms_tgt).(symbolenv) = skenv_link_tgt):
      lxsim_lift i0 (State ((Frame.mk ms_src lst_src) :: tail_src)) (State ((Frame.mk ms_tgt lst_tgt) :: tail_tgt)) sm0
  | lxsim_lift_callstate
       sm_arg tail_src tail_tgt tail_sm args_src args_tgt
       (GE: sim_ge sm_arg sem_src.(globalenv) sem_tgt.(globalenv))
       (STACK: lxsim_stack tail_sm tail_src tail_tgt)
       (MLE: SimMem.le tail_sm sm_arg)
       (MWF: SimMem.wf sm_arg)
       (SIMARGS: SimMem.sim_args args_src args_tgt sm_arg):
      lxsim_lift idx_bot (Callstate args_src tail_src) (Callstate args_tgt tail_tgt) sm_arg.

End ADQMATCH.

Section ADQINIT.

  Context `{SM: SimMem.class}.
  Context {SS: SimSymb.class SM}.
  Context `{SU: Sound.class}.

  Variable pp: ProgPair.t.
  Hypothesis NOTNIL: pp <> [].
  Hypothesis SIMPROG: ProgPair.sim pp.
  Let p_src := (ProgPair.src pp).
  Let p_tgt := (ProgPair.tgt pp).

  Variable sk_link_src sk_link_tgt: Sk.t.
  Hypothesis LINKSRC: (link_sk p_src) = Some sk_link_src.
  Hypothesis LINKTGT: (link_sk p_tgt) = Some sk_link_tgt.

  Let lxsim_lift := (lxsim_lift pp).
  Hint Unfold lxsim_lift.
  Let sem_src := Sem.sem p_src.
  Let sem_tgt := Sem.sem p_tgt.

  Let skenv_link_src := (Sk.load_skenv sk_link_src).
  Let skenv_link_tgt := (Sk.load_skenv sk_link_tgt).

  Theorem init_lxsim_lift_forward
          st_init_src
          (INITSRC: sem_src.(Smallstep.initial_state) st_init_src):
      exists idx st_init_tgt sm_init,
        <<INITTGT: sem_tgt.(Dinitial_state) st_init_tgt>>
        /\ (<<SIM: lxsim_lift sk_link_src sk_link_tgt idx st_init_src st_init_tgt sm_init>>)
        /\ (<<INCLSRC: forall mp (IN: In mp pp), SkEnv.includes skenv_link_src (Mod.sk mp.(ModPair.src))>>)
        /\ (<<INCLTGT: forall mp (IN: In mp pp), SkEnv.includes skenv_link_tgt (Mod.sk mp.(ModPair.tgt))>>).
  Proof.
    ss. inv INITSRC; ss. clarify. rename INITSK into INITSKSRC. rename INITMEM into INITMEMSRC.

    exploit sim_link_sk; eauto. i; des. fold p_tgt in LOADTGT.
    assert(WFTGT: forall md, In md p_tgt -> <<WF: Sk.wf md >>).
    { clear - SIMPROG WF. i. subst_locals. u in *. rewrite in_map_iff in *. des. clarify.
      rewrite Forall_forall in *. exploit SIMPROG; et. intro SIM. inv SIM.
      unfold Mod.sk in *. rewrite <- SKTGT in *.
      eapply SimSymb.wf_preserves_wf; et. rewrite SKSRC in *. eapply WF; et. rewrite in_map_iff. esplits; et.
    }
    rewrite <- SKSRC in *. rewrite <- SKTGT in *.
    exploit init_sim_ge_strong; eauto.
    { ii. eapply WF; et. unfold p_src. unfold ProgPair.src. rewrite in_map_iff. et. }
    { ii. eapply WFTGT; et. unfold p_tgt. unfold ProgPair.tgt. rewrite in_map_iff. et. }
    i; des. clarify. ss. des_ifs.

    set(Args.mk (Genv.symbol_address (Sk.load_skenv (SimSymb.src ss_link)) (prog_main (SimSymb.src ss_link)) Ptrofs.zero)
                [] sm_init.(SimMem.src)) as args_src in *.
    set(Args.mk (Genv.symbol_address (Sk.load_skenv (SimSymb.tgt ss_link)) (prog_main (SimSymb.tgt ss_link)) Ptrofs.zero)
                [] sm_init.(SimMem.tgt)) as args_tgt in *.
    assert(SIMARGS: SimMem.sim_args args_src args_tgt sm_init).
    { econs; ss; eauto.
      - rewrite <- SimMem.sim_val_list_spec. econs; eauto. }

    esplits; eauto.
    - econs; ss; cycle 1.
      { ii. eapply initial_state_determ; ss; eauto. }
      econs; eauto; cycle 1.
      apply_all_once SimSymb.sim_skenv_func_bisim. des. inv SIMSKENV.
      exploit FUNCFSIM; eauto.
      i; des. clarify.
    - econs; eauto.
      + ss. folder. des_ifs.
      + hnf. econs; eauto.
      + reflexivity.
  Qed.

End ADQINIT.

Section ADQSTEP.

  Context `{SM: SimMem.class}.
  Context {SS: SimSymb.class SM}.
  Context `{SU: Sound.class}.

  Variable pp: ProgPair.t.
  Hypothesis SIMPROG: ProgPair.sim pp.
  Let p_src := (ProgPair.src pp).
  Let p_tgt := (ProgPair.tgt pp).

  Variable sk_link_src sk_link_tgt: Sk.t.
  Hypothesis LINKSRC: (link_sk p_src) = Some sk_link_src.
  Hypothesis LINKTGT: (link_sk p_tgt) = Some sk_link_tgt.

  Let lxsim_lift := (lxsim_lift pp).
  Hint Unfold lxsim_lift.
  Let sem_src := Sem.sem p_src.
  Let sem_tgt := Sem.sem p_tgt.

  Let skenv_link_src := (Sk.load_skenv sk_link_src).
  Let skenv_link_tgt := (Sk.load_skenv sk_link_tgt).
  Variable ss_link: SimSymb.t.
  Hypothesis (SIMSKENV: exists sm, SimSymb.sim_skenv sm ss_link skenv_link_src skenv_link_tgt).

  Hypothesis (INCLSRC: forall mp (IN: In mp pp), SkEnv.includes skenv_link_src (Mod.sk mp.(ModPair.src))).
  Hypothesis (INCLTGT: forall mp (IN: In mp pp), SkEnv.includes skenv_link_tgt (Mod.sk mp.(ModPair.tgt))).
  Hypothesis (SSLE: forall mp (IN: In mp pp), SimSymb.le mp.(ModPair.ss) ss_link).

  Hypothesis (WFKSSRC: forall md (IN: In md (ProgPair.src pp)), <<WF: Sk.wf md >>).
  Hypothesis (WFKSTGT: forall md (IN: In md (ProgPair.tgt pp)), <<WF: Sk.wf md >>).

  Theorem lxsim_lift_xsim
          i0 st_src0 st_tgt0 sm0
          (LXSIM: lxsim_lift sk_link_src sk_link_tgt i0 st_src0 st_tgt0 sm0)
    :
      <<XSIM: xsim sem_src sem_tgt ord (sound_state pp) top1 i0 st_src0 st_tgt0>>
  .
  Proof.
    generalize dependent sm0. generalize dependent st_src0. generalize dependent st_tgt0. generalize dependent i0.
    pcofix CIH. i. pfold. inv LXSIM; ss; cycle 1.
    { (* init *)
      folder. des_ifs. right. econs; eauto.
      i. econs; eauto; cycle 1.
      { ii. specialize (SAFESRC _ (star_refl _ _ _ _)). des; ss.
        - inv SAFESRC.
        - des_ifs. right. inv SAFESRC.
          exploit find_fptr_owner_fsim; eauto. { eapply SimMem.sim_args_sim_fptr; eauto. } i; des. clarify.
          inv SIMMS.
          inv MSFIND. inv FINDTGT.
          exploit SIM; eauto. i; des.
          exploit INITPROGRESS; eauto. i; des.
          esplits; eauto. econs; eauto. econs; eauto.
      }
      { i. ss. inv FINALTGT. }
      i. inv STEPTGT.
      specialize (SAFESRC _ (star_refl _ _ _ _)). des.
      { inv SAFESRC. }
      bar. inv SAFESRC. ss. des_ifs.
      bar.
      exploit find_fptr_owner_fsim; eauto. { eapply SimMem.sim_args_sim_fptr; eauto. } i; des. clarify.
      exploit find_fptr_owner_determ; ss; eauto.
      { rewrite Heq. apply FINDTGT. }
      { rewrite Heq. apply MSFIND. }
      i; des. clarify.

      inv SIMMS.
      specialize (SIM sm0).
      inv MSFIND. inv MSFIND0.
      exploit SIM; eauto. i; des.

      exploit INITBSIM; eauto. i; des.
      clears st_init0; clear st_init0. esplits; eauto.
      - left. apply plus_one. econs; eauto. econs; eauto.
      - right. eapply CIH.
        instantiate (1:= sm_init). econs; try apply SIM0; eauto.
        + ss. folder. des_ifs. eapply mfuture_preserves_sim_ge; eauto. apply rtc_once. et.
        + etrans; eauto.
        + ss. inv GE. folder. rewrite Forall_forall in *. eapply SESRC; et.
        + ss. inv GE. folder. rewrite Forall_forall in *. eapply SETGT; et.

    }

    sguard in SESRC. sguard in SETGT. folder. rewrite LINKSRC in *. rewrite LINKTGT in *.
    punfold TOP. rr in TOP. ii. hexploit1 TOP; eauto.
    { ii. exploit SSSRC. { eapply lift_star; eauto. } intro SUST0; des. inv SUST0. des.
      simpl_depind. clarify. hexploit FORALLSU; eauto. i; des.
      specialize (H (sound_states_local si)). esplits; eauto. eapply H; eauto. }
    inv TOP.

    - (* fstep *)
      left. exploit SU0.
      { ss. }
      i; des. clear SU0. right. econs; ss; eauto.
      + rename H into FSTEP. inv FSTEP.
        * econs 1; cycle 1.
          { ii. des. inv FINALSRC; ss. exfalso. eapply SAFESRC0. u. eauto. }
          ii. ss. rewrite LINKSRC in *. des. inv STEPSRC; ss; ModSem.tac; swap 2 3.
          { exfalso. eapply SAFESRC; eauto. }
          { exfalso. eapply SAFESRC0. u. eauto. }
          exploit STEP; eauto. i; des_safe.
          exists i1, (State ((Frame.mk ms_tgt st_tgt1) :: tail_tgt)). esplits; eauto.
          { assert(T: DPlus ms_tgt lst_tgt tr st_tgt1 \/ (lst_tgt = st_tgt1 /\ tr = E0 /\ ord i1 i0)).
            { des; et. inv STAR; et. left. econs; et. }
            clear H. des.
            - left. split; cycle 1.
              { eapply lift_receptive_at; eauto. unsguard SESRC. s. des_ifs. }
              eapply lift_dplus; eauto.
              { unsguard SETGT. ss. des_ifs. }
            - right. esplits; eauto. clarify.
          }
          pclearbot. right. eapply CIH with (sm0 := sm1); eauto.
          econs; eauto.
          { ss. folder. des_ifs. eapply mfuture_preserves_sim_ge; eauto. apply rtc_once; eauto. }
          { etransitivity; eauto. }
        * des. pclearbot. econs 2.
          { esplits; eauto. eapply lift_dplus; eauto. { unsguard SETGT. ss. des_ifs. } }
          right. eapply CIH; eauto. instantiate (1:=sm1). econs; eauto.
          { folder. ss; des_ifs. eapply mfuture_preserves_sim_ge; eauto.
            eapply rtc_once; eauto. }
          { etrans; eauto. }

    - (* bstep *)
      right. ss. hexploit1 SU0; ss.
      assert(SAFESTEP: safe sem_src (State ({| Frame.ms := ms_src; Frame.st := lst_src |} :: tail_src))
                       -> safe_modsem ms_src lst_src).
      { eapply safe_implies_safe_modsem; eauto. }
      econs; ss; eauto.
      i. exploit SU0; eauto. intro T. clear SU0. inv T.
      + econs 1; eauto; revgoals.
        { ii. des. clear - FINALTGT PROGRESS. inv FINALTGT. ss. ModSem.tac. }
        { ii. right. des. esplits; eauto. eapply lift_step; eauto. }
        ii. inv STEPTGT; ModSem.tac. ss. exploit STEP; eauto. i; des_safe.
        exists i1, (State ((Frame.mk ms_src st_src1) :: tail_src)).
        esplits; eauto.
        { des.
          - left. eapply lift_plus; eauto.
          - right. esplits; eauto. eapply lift_star; eauto.
        }
        pclearbot. right. eapply CIH with (sm0 := sm1); eauto.
        econs; eauto.
        { folder. ss; des_ifs. eapply mfuture_preserves_sim_ge; eauto. apply rtc_once; eauto. }
        etransitivity; eauto.
      + des. pclearbot. econs 2.
        { esplits; eauto. eapply lift_star; eauto. }
        right. eapply CIH; eauto.
        instantiate (1:=sm1). econs; eauto.
        { folder. ss; des_ifs. eapply mfuture_preserves_sim_ge; eauto. eapply rtc_once; eauto. }
        { etrans; eauto. }

    - (* call *)
      left. right. econs; eauto. econs; eauto; cycle 1.
      { ii. inv FINALSRC. ss. ModSem.tac. }
      i. inv STEPSRC; ss; ModSem.tac. des_ifs. hexploit1 SU0.
      { ss. }
      rename SU0 into CALLFSIM.

      exploit CALLFSIM; eauto. i; des. esplits; eauto.
      + left. split; cycle 1.
        { eapply lift_receptive_at. { unsguard SESRC. ss. des_ifs. } eapply at_external_receptive_at; et. }
        apply plus_one. econs; ss; eauto.
        { eapply lift_determinate_at; et. { unsguard SETGT. ss. des_ifs. } eapply at_external_determinate_at; et. }
        des_ifs. econs 1; eauto.
      + right. eapply CIH; eauto.
        { instantiate (1:= sm_arg). econs 2; eauto.
          * ss. folder. des_ifs. eapply mfuture_preserves_sim_ge; eauto. econs 2; et.
          * instantiate (1:= sm_arg). econs; [eassumption|..]; revgoals; ss.
            { ii. exploit K; eauto. i; des_safe. pclearbot. esplits; try apply LXSIM; eauto. }
            { reflexivity. }
            { et. }
            { refl. }
            { et. }
            { ss. folder. des_ifs. }
            { eauto. }
          * reflexivity.
        }

    - (* return *)
      left. right. econs; eauto.
      econs; eauto; cycle 1.
      { ii. ss. inv FINALSRC0. ss. determ_tac ModSem.final_frame_dtm. clear_tac.
        inv STACK.
        econs; ss; eauto.
        - econs; ss; eauto.
          inv SIMRETV; ss.
          eapply SimMem.sim_val_int; et.
        - i. inv FINAL0; inv FINAL1; ss.
          exploit ModSem.final_frame_dtm; [apply FINAL|apply FINAL0|..]. i; clarify. congruence.
        - ii. des_ifs. inv H; ss; ModSem.tac.
      }
      i. ss. des_ifs. inv STEPSRC; ModSem.tac. ss.
      inv STACK; ss. folder. sguard in SESRC0. sguard in SETGT0. des_ifs.
      determ_tac ModSem.final_frame_dtm. clear_tac.
      exploit K; try apply SIMRETV; eauto.
      { etransitivity; eauto. etrans; eauto. }
      { exploit SSSRC. { eapply star_refl. } intro T; des. inv T. des. simpl_depind. clarify.
        inv TL. simpl_depind. clarify. des.
        exploit FORALLSU0; eauto. i; des. esplits; eauto. eapply HD; eauto.
      }
      i; des. esplits; eauto.
      + left. split; cycle 1.
        { eapply lift_receptive_at. { unsguard SESRC. ss. des_ifs. } eapply final_frame_receptive_at; et. }
        apply plus_one. econs; eauto.
        { eapply lift_determinate_at. { unsguard SETGT. ss. des_ifs. } eapply final_frame_determinate_at; et. }
        econs 4; ss; eauto.
      + right. eapply CIH; eauto.
        instantiate (1:= sm_after). econs; ss; cycle 3; eauto.
        { folder. des_ifs. eapply mfuture_preserves_sim_ge; et. econs 2; et. }
        { etrans; eauto. }
  Qed.

End ADQSTEP.

Require Import BehaviorsC SemProps.

Section ADQ.

  Context `{SM: SimMem.class}.
  Context {SS: SimSymb.class SM}.
  Context `{SU: Sound.class}.

  Variable pp: ProgPair.t.
  Hypothesis SIMPROG: ProgPair.sim pp.
  Let p_src := (ProgPair.src pp).
  Let p_tgt := (ProgPair.tgt pp).
  Let sem_src := Sem.sem p_src.
  Let sem_tgt := Sem.sem p_tgt.

  Variable sk_link_src sk_link_tgt: Sk.t.
  Hypothesis LINKSRC: (link_sk p_src) = Some sk_link_src.
  Hypothesis LINKTGT: (link_sk p_tgt) = Some sk_link_tgt.

  Let lxsim_lift := (lxsim_lift pp).
  Hint Unfold lxsim_lift.

  Let skenv_link_src := (Sk.load_skenv sk_link_src).
  Let skenv_link_tgt := (Sk.load_skenv sk_link_tgt).
  Variable ss_link: SimSymb.t.
  Hypothesis (SIMSKENV: exists sm, SimSymb.sim_skenv sm ss_link skenv_link_src skenv_link_tgt).

  Hypothesis (INCLSRC: forall mp (IN: In mp pp), SkEnv.includes skenv_link_src (Mod.sk mp.(ModPair.src))).
  Hypothesis (INCLTGT: forall mp (IN: In mp pp), SkEnv.includes skenv_link_tgt (Mod.sk mp.(ModPair.tgt))).
  Hypothesis (SSLE: forall mp (IN: In mp pp), SimSymb.le mp.(ModPair.ss) ss_link).

  Hypothesis (WFSKSRC: forall md (IN: In md (ProgPair.src pp)), <<WF: Sk.wf md >>).
  Hypothesis (WFSKTGT: forall md (IN: In md (ProgPair.tgt pp)), <<WF: Sk.wf md >>).

  Theorem adequacy_local_aux: mixed_simulation sem_src sem_tgt.
  Proof.
    subst_locals. econstructor 1 with (order := ord); eauto. generalize wf_ord; intro WF.
    econstructor; eauto.
    - eapply preservation; eauto.
    - eapply preservation_top.
    - econs 1; ss; eauto. ii.
      exploit init_lxsim_lift_forward; eauto. { destruct pp; ss. } i; des.
      assert(WFTGT: forall md, In md (ProgPair.tgt pp) -> <<WF: Sk.wf md >>).
      { inv INITTGT. inv INIT. ss. }
      hexploit lxsim_lift_xsim; eauto.
    - ss. i; des. inv SAFESRC.
      exploit sim_link_sk; eauto. i; des. des_ifs.
      exploit SimSymb.wf_load_sim_skenv; eauto. i; des. clarify.
      symmetry. exploit SimSymb.sim_skenv_public_symbols; et. intro T. s. rewrite T. ss.
  Unshelve.
    all: ss.
  Qed.

End ADQ.

Section BEH.

  Context `{SM: SimMem.class}.
  Context {SS: SimSymb.class SM}.
  Context `{SU: Sound.class}.

  Variable pp: ProgPair.t.
  Hypothesis SIMPROG: ProgPair.sim pp.
  Let p_src := (ProgPair.src pp).
  Let p_tgt := (ProgPair.tgt pp).
  Let sem_src := Sem.sem p_src.
  Let sem_tgt := Sem.sem p_tgt.

  Theorem adequacy_local: BehaviorsC.improves sem_src sem_tgt.
  Proof.
    eapply improves_free_theorem; i.
    eapply bsim_improves; eauto. eapply mixed_to_backward_simulation; eauto.

    des. inv INIT. ss. exploit sim_link_sk; eauto. i; des. clarify.
    exploit init_lxsim_lift_forward; eauto. { destruct pp; ss. } { econs; eauto. } i; des.
    exploit SimSymb.wf_load_sim_skenv; eauto. i; des. clarify.
    eapply adequacy_local_aux; ss; eauto.
    { rewrite Forall_forall in *. ss. }
    { inv INITTGT. inv INIT. ss. }
  Qed.

End BEH.

Program Definition mkPR (MR: SimMem.class) (SR: SimSymb.class MR) (MP: Sound.class)
  : program_relation.t := program_relation.mk
                            (fun (p_src p_tgt: program) =>
                               forall (WF: forall x (IN: In x p_src), Sk.wf x),
                               exists pp,
                                 (<<SIMS: @ProgPair.sim MR SR MP pp>>)
                                 /\ (<<SRCS: (ProgPair.src pp) = p_src>>)
                                 /\ (<<TGTS: (ProgPair.tgt pp) = p_tgt>>)) _ _ _.
Next Obligation.
(* horizontal composition *)
  exploit REL0; eauto. { i. eapply WF. rewrite in_app_iff. eauto. } intro T0; des.
  exploit REL1; eauto. { i. eapply WF. rewrite in_app_iff. eauto. } intro T1; des.
  clarify. unfold ProgPair.sim in *. rewrite Forall_forall in *. eexists (_ ++ _). esplits; eauto.
  - rewrite Forall_forall in *. i. rewrite in_app_iff in *. des; [apply SIMS|apply SIMS0]; eauto.
  - unfold ProgPair.src. rewrite map_app. ss.
  - unfold ProgPair.tgt. rewrite map_app. ss.
Qed.
Next Obligation.
(* adequacy *)
  destruct (classic (forall x (IN: In x p_src), Sk.wf x)) as [WF|NWF]; cycle 1.
  { eapply sk_nwf_improves; auto. }
  specialize (REL WF). des. clarify.
  eapply (@adequacy_local MR SR MP). auto.
Qed.
Next Obligation. exists []. splits; ss. Qed.
Arguments mkPR: clear implicits.

Definition relate_single (MR: SimMem.class) (SR: SimSymb.class MR) (MP: Sound.class)
           (p_src p_tgt: Mod.t) : Prop :=
  forall (WF: Sk.wf p_src),
  exists mp,
    (<<SIM: @ModPair.sim MR SR MP mp>>)
    /\ (<<SRC: mp.(ModPair.src) = p_src>>)
    /\ (<<TGT: mp.(ModPair.tgt) = p_tgt>>).
Arguments relate_single : clear implicits.

Lemma relate_single_program MR SR MP p_src p_tgt
      (REL: relate_single MR SR MP p_src p_tgt):
    (mkPR MR SR MP) [p_src] [p_tgt].
Proof.
  unfold relate_single. ss. i.
  exploit REL; [ss; eauto|]. i. des. clarify.
  exists [mp]. esplits; ss; eauto.
Qed.
Arguments relate_single_program : clear implicits.

Lemma relate_each_program MR SR MP
      (p_src p_tgt: program)
      (REL: Forall2 (relate_single MR SR MP) p_src p_tgt):
    (mkPR MR SR MP) p_src p_tgt.
Proof.
  revert p_tgt REL. induction p_src; ss; i.
  - inv REL. exists []; splits; ss.
  - inv REL. exploit IHp_src; eauto. i. des.
    exploit H1; eauto. i. des. clarify.
    exists (mp :: pp); splits; ss. econs; eauto.
Qed.
Arguments relate_each_program : clear implicits.

Lemma relate_single_rtc_rusc (R: program_relation.t -> Prop) MR SR MP
      (p_src p_tgt: Mod.t)
      (REL: rtc (relate_single MR SR MP) p_src p_tgt)
      (RELIN: R (mkPR MR SR MP)):
    rusc R [p_src] [p_tgt].
Proof.
  induction REL; try refl.
  - etrans; eauto. eapply rusc_incl; eauto. eapply relate_single_program; eauto.
Qed.
Arguments relate_single_program : clear implicits.

Lemma relate_single_rusc (R: program_relation.t -> Prop) MR SR MP
      (p_src p_tgt: Mod.t)
      (REL: (relate_single MR SR MP) p_src p_tgt)
      (RELIN: R (mkPR MR SR MP)):
    rusc R [p_src] [p_tgt].
Proof.
  eapply relate_single_rtc_rusc; eauto. eapply rtc_once. eauto.
Qed.
Arguments relate_single_program : clear implicits.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.common.AST.
Require Import compcert.lib.Integers.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Events.
Require Import compcert.common.Smallstep.
Require Import VST.ccc26x86.Op.
Require Import VST.ccc26x86.Locations.
Require Import VST.ccc26x86.Conventions.
Require VST.ccc26x86.Stacklayout.

Require Import VST.sepcomp.mem_lemmas.
Require Import VST.sepcomp.semantics.
Require Import VST.sepcomp.semantics_lemmas.
Require Import VST.sepcomp.val_casted.
Require Import VST.ccc26x86.BuiltinEffects.
Require Import VST.sepcomp.structured_injections.
Require Import VST.sepcomp.effect_properties.
Require Import VST.sepcomp.reach.
Require Import VST.msl.Axioms.

Definition load_stack (m: mem) (sp: val) (ty: typ) (ofs: int) :=
  Mem.loadv (chunk_of_type ty) m (Val.add sp (Vint ofs)).

Definition store_stack (m: mem) (sp: val) (ty: typ) (ofs: int) (v: val) :=
  Mem.storev (chunk_of_type ty) m (Val.add sp (Vint ofs)) v.

(*NOTE [store_args_simple] is used to model program loading of
  initial arguments.  Cf. NOTE [loader] below. *)

Fixpoint store_args0 (m: mem) (sp: val) (ofs: Z) (args: list val) (tys: list typ)
         : option mem :=
  match args,tys with
    | nil,nil => Some m
    | a::args',ty::tys' =>
      match store_stack m sp ty (Int.repr (Stacklayout.fe_ofs_arg + 4*ofs)) a with
        | None => None
        | Some m' => store_args0 m' sp (ofs+typesize ty) args' tys'
      end
    | _,_ => None
  end.

(* [store_args_rec] is more complicated, but more precise than,
   [store_args (encode_longs args) (encode_typs tys)]. Still, it's not totally
   satisfactory that argument encoding code is duplicated like this. *)

Fixpoint store_args_rec m sp ofs args tys : option mem :=
  let vsp := Vptr sp Int.zero in
  match tys, args with
    | nil, nil => Some m
    | ty'::tys',a'::args' =>
      match ty', a' with
        | Tlong, Vlong n =>
          match store_stack m vsp Tint (Int.repr (Stacklayout.fe_ofs_arg + 4*(ofs+1)))
                            (Vint (Int64.hiword n)) with
            | None => None
            | Some m' =>
              match store_stack m' vsp Tint (Int.repr (Stacklayout.fe_ofs_arg + 4*ofs))
                                (Vint (Int64.loword n)) with
                | None => None
                | Some m'' => store_args_rec m'' sp (ofs+2) args' tys'
              end
          end
        | Tlong, _ => None
        | _,_ =>
          match store_stack m vsp ty' (Int.repr (Stacklayout.fe_ofs_arg + 4*ofs)) a' with
            | None => None
            | Some m' => store_args_rec m' sp (ofs+typesize ty') args' tys'
          end
      end
    | _, _ => None
  end.

Lemma store_stack_fwd m sp t i a m' :
  store_stack m sp t i a = Some m' ->
  mem_forward m m'.
Proof.
unfold store_stack, Mem.storev.
destruct (Val.add sp (Vint i)); try solve[inversion 1].
apply store_forward.
Qed.

Lemma store_args_fwd sp ofs args tys m m' :
  store_args_rec m sp ofs args tys = Some m' ->
  mem_forward m m'.
Proof.
revert args ofs m; induction tys.
simpl. destruct args. intros ofs. inversion 1; subst.
solve[apply mem_forward_refl].
intros ofs m. simpl. inversion 1.
destruct args; try solve[inversion 1].
destruct a; simpl; intros ofs m.
- case_eq (store_stack m (Vptr sp Int.zero) Tint
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. apply store_stack_fwd in EQ. intros H.
eapply mem_forward_trans; eauto. intros; congruence.
- case_eq (store_stack m (Vptr sp Int.zero) Tfloat
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. apply store_stack_fwd in EQ. intros H.
eapply mem_forward_trans; eauto. intros; congruence.
- destruct v; try solve[congruence].
case_eq (store_stack m (Vptr sp Int.zero) Tint
           (Int.repr match ofs+1 with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                      | Z.neg y' => Z.neg y'~0~0 end)
        (Vint (Int64.hiword i))).
intros m0 EQ. apply store_stack_fwd in EQ.
case_eq (store_stack m0 (Vptr sp Int.zero) Tint
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end)
        (Vint (Int64.loword i))). intros m1 H H2.
eapply mem_forward_trans; eauto.
eapply mem_forward_trans; eauto.
eapply store_stack_fwd; eauto. intros; congruence. intros; congruence.
- case_eq (store_stack m (Vptr sp Int.zero) Tsingle
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. apply store_stack_fwd in EQ. intros H.
eapply mem_forward_trans; eauto. intros; congruence.
- case_eq (store_stack m (Vptr sp Int.zero) Tany32
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. apply store_stack_fwd in EQ. intros H.
eapply mem_forward_trans; eauto. intros; congruence.
- case_eq (store_stack m (Vptr sp Int.zero) Tany64
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. apply store_stack_fwd in EQ. intros H.
eapply mem_forward_trans; eauto. intros; congruence.

Qed.

Lemma store_stack_unch_on stk z t i a m m' :
  store_stack m (Vptr stk z) t i a = Some m' ->
  Mem.unchanged_on (fun b ofs => b<>stk) m m'.
Proof.
unfold store_stack, Mem.storev.
case_eq (Val.add (Vptr stk z) (Vint i)); try solve[inversion 1].
intros b i0 H H2. eapply Mem.store_unchanged_on in H2; eauto.
intros i2 H3 H4. inv H. apply H4; auto.
Qed.

Lemma store_args_unch_on stk ofs args tys m m' :
  store_args_rec m stk ofs args tys = Some m' ->
  Mem.unchanged_on (fun b ofs => b<>stk) m m'.
Proof.
revert args ofs m; induction tys.
simpl. destruct args. intros ofs. inversion 1; subst.
  solve[apply Mem.unchanged_on_refl].
intros ofs m. simpl. inversion 1.
destruct args; try solve[inversion 1].
destruct a; simpl; intros ofs m.
- case_eq (store_stack m (Vptr stk Int.zero) Tint
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. generalize EQ as EQ'. intro. apply store_stack_unch_on in EQ. intros H.
eapply unchanged_on_trans with (m2 := m0); eauto.
solve[eapply store_stack_fwd; eauto]. intros; congruence.
- case_eq (store_stack m (Vptr stk Int.zero) Tfloat
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. generalize EQ as EQ'. intro. apply store_stack_unch_on in EQ. intros H.
eapply unchanged_on_trans with (m2 := m0); eauto.
solve[eapply store_stack_fwd; eauto]. intros; congruence.
- destruct v; try solve[inversion 1].
case_eq (store_stack m (Vptr stk Int.zero) Tint
           (Int.repr match ofs+1 with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                      | Z.neg y' => Z.neg y'~0~0 end)
        (Vint (Int64.hiword i))).
intros m0 EQ. generalize EQ as EQ'. intro. apply store_stack_unch_on in EQ.
case_eq (store_stack m0 (Vptr stk Int.zero) Tint
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end)
        (Vint (Int64.loword i))).
intros m1 EQ2. generalize EQ2 as EQ2'. intro. apply store_stack_unch_on in EQ2. intros H.
eapply unchanged_on_trans with (m2 := m0); eauto.
eapply unchanged_on_trans with (m2 := m1); eauto.
eapply store_stack_fwd; eauto. eapply store_stack_fwd; eauto.
intros; congruence. intros; congruence.
- case_eq (store_stack m (Vptr stk Int.zero) Tsingle
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. generalize EQ as EQ'. intro. apply store_stack_unch_on in EQ. intros H.
eapply unchanged_on_trans with (m2 := m0); eauto.
solve[eapply store_stack_fwd; eauto]. intros; congruence.
- case_eq (store_stack m (Vptr stk Int.zero) Tany32
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. generalize EQ as EQ'. intro. apply store_stack_unch_on in EQ. intros H.
eapply unchanged_on_trans with (m2 := m0); eauto.
solve[eapply store_stack_fwd; eauto]. intros; congruence.
- case_eq (store_stack m (Vptr stk Int.zero) Tany64
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
intros m0 EQ. generalize EQ as EQ'. intro. apply store_stack_unch_on in EQ. intros H.
eapply unchanged_on_trans with (m2 := m0); eauto.
solve[eapply store_stack_fwd; eauto]. intros; congruence.
Qed.

Fixpoint args_len_rec args tys : option Z :=
  match tys, args with
    | nil, nil => Some 0
    | ty'::tys',a'::args' =>
      match ty', a' with
        | Tlong, Vlong n =>
          match args_len_rec args' tys' with
            | None => None
            | Some z => Some (2+z)
          end
        | Tlong, _ => None
        | Tfloat,_ =>
          match args_len_rec args' tys' with
            | None => None
            | Some z => Some (2+z)
          end
        | _,_ =>
          match args_len_rec args' tys' with
            | None => None
            | Some z => Some (1+z)
          end
      end
    | _, _ => None
  end.

Lemma args_len_rec_succeeds args tys
      (VALSDEF: val_casted.vals_defined args=true)
      (HASTY: Val.has_type_list args tys) :
  exists z, args_len_rec args tys = Some z.
Proof.
rewrite val_casted.val_has_type_list_func_charact in HASTY.
revert args VALSDEF HASTY; induction tys. destruct args; auto.
simpl. exists 0; auto. simpl. intros; congruence.
destruct args. simpl. intros; congruence.
unfold val_has_type_list_func; rewrite andb_true_iff. intros VD [H H2].
fold val_has_type_list_func in H2.
apply IHtys in H2. destruct H2 as [z H2]. simpl.
destruct a; try solve [rewrite H2; eexists; eauto].
destruct v; simpl in H; try solve [simpl in VD; congruence].
rewrite H2. eexists; eauto.
simpl in VD. destruct v; auto. congruence.
Qed.

Lemma range_perm_shift m b lo sz n k p :
  0 <= lo -> 0 <= sz -> 0 <= n ->
  Mem.range_perm m b lo (lo+sz+n) k p ->
  Mem.range_perm m b (lo+n) (lo+sz+n) k p.
Proof. intros A B C RNG ofs [H H2]; apply RNG; omega. Qed.

Inductive only_stores (sp: block) : list val -> mem -> mem -> Type :=
| only_stores_nil m : only_stores sp nil m m
| only_stores_cons m ch ofs v m'' m' l :
    Mem.store ch m sp ofs v = Some m'' ->
    only_stores sp l m'' m' ->
    only_stores sp (v::l) m m'.

Lemma only_stores_fwd sp m m' l :
  only_stores sp l m m' -> mem_forward m m'.
Proof.
induction 1. apply mem_forward_refl.
eapply mem_forward_trans. eapply store_forward; eauto. apply IHX.
Qed.

Lemma store_args_rec_only_stores m sp args tys z m' :
  store_args_rec m sp z args tys = Some m' ->
  only_stores sp (encode_longs tys args) m m'.
Proof.
revert args z m. induction tys. destruct args; simpl.
intros ? ?; inversion 1. constructor.
intros ? ? ?; congruence.
destruct args; simpl. intros; congruence. intros z m.
generalize
 (Int.repr match z with
             | 0 => 0 | Z.pos y' => Z.pos y'~0~0
             | Z.neg y' => Z.neg y'~0~0 end) as z'.
generalize
 (Int.repr match z+1 with
             | 0 => 0 | Z.pos y' => Z.pos y'~0~0
             | Z.neg y' => Z.neg y'~0~0 end) as z''.
intros z'' z'. destruct a.
- case_eq (store_stack m (Vptr sp Int.zero) Tint z' v);
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE H.
solve[eapply only_stores_cons; eauto].
- case_eq (store_stack m (Vptr sp Int.zero) Tfloat z' v);
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE H.
solve[eapply only_stores_cons; eauto].
- destruct v; try solve[intros; congruence].
case_eq (store_stack m (Vptr sp Int.zero) Tint z'' (Vint (Int64.hiword i)));
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE.
case_eq (Mem.store Mint32 m0 sp (Int.unsigned (Int.add Int.zero z'))
                   (Vint (Int64.loword i)));
  try solve[intros; congruence].
intros m1 STORE' H.
eapply only_stores_cons; eauto.
solve[eapply only_stores_cons; eauto].
- case_eq (store_stack m (Vptr sp Int.zero) Tsingle z' v);
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE H.
solve[eapply only_stores_cons; eauto].
- case_eq (store_stack m (Vptr sp Int.zero) Tany32 z' v);
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE H.
solve[eapply only_stores_cons; eauto].
- case_eq (store_stack m (Vptr sp Int.zero) Tany64 z' v);
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE H.
solve[eapply only_stores_cons; eauto].
Qed.

Lemma args_len_recD: forall v args tp tys sz,
     args_len_rec (v :: args) (tp :: tys) = Some sz ->
     exists z1 z2, sz = z1+z2 /\ args_len_rec args tys = Some z2 /\
        match tp with Tlong => z1=2 | Tfloat => z1=2 | _ => z1=1 end.
Proof.
simpl. intros.
destruct tp; simpl in *.
destruct (args_len_rec args tys); inv H.
  exists 1, z; repeat split; trivial.
destruct (args_len_rec args tys); inv H.
  exists 2, z; repeat split; trivial.
destruct v; inv H.
  destruct (args_len_rec args tys); inv H1.
  exists 2, z; repeat split; trivial.
destruct (args_len_rec args tys); inv H.
  exists 1, z; repeat split; trivial.
destruct (args_len_rec args tys); inv H.
  exists 1, z; repeat split; trivial.
destruct (args_len_rec args tys); inv H.
  exists 1, z; repeat split; trivial.
Qed.

Lemma args_len_rec_nonneg: forall tys args sz,
     args_len_rec args tys = Some sz -> 0 <= sz.
Proof.
intros tys; induction tys; intros.
  destruct args; inv H. omega.
destruct args; inv H.
  destruct a; specialize (IHtys args).
+ destruct (args_len_rec args tys); inv H1.
    specialize (IHtys _ (eq_refl _)).
    destruct z. omega. destruct p; xomega.
    xomega.
+ destruct (args_len_rec args tys); inv H1.
    specialize (IHtys _ (eq_refl _)).
    destruct z. omega. destruct p; xomega.
    xomega.
+ destruct v; inv H1.
    destruct (args_len_rec args tys); inv H0.
    specialize (IHtys _ (eq_refl _)).
    destruct z. omega. destruct p; xomega.
    xomega.
+ destruct (args_len_rec args tys); inv H1.
    specialize (IHtys _ (eq_refl _)).
    destruct z. omega. destruct p; xomega.
    xomega.
+ destruct (args_len_rec args tys); inv H1.
    specialize (IHtys _ (eq_refl _)).
    destruct z. omega. destruct p; xomega.
    xomega.
+ destruct (args_len_rec args tys); inv H1.
    specialize (IHtys _ (eq_refl _)).
    destruct z. omega. destruct p; xomega.
    xomega.
Qed.

Lemma args_len_rec_pos: forall v args tp tys sz,
     args_len_rec (v :: args) (tp :: tys) = Some sz -> 0 < sz.
Proof. intros.
apply args_len_recD in H. destruct H as [? [? [? [? ?]]]]; subst.
apply args_len_rec_nonneg in H0.
destruct tp; omega.
Qed.

Definition store_arg m sp ofs ty' a' :=
      match ty', a' with
        | Tlong, Vlong n =>
          match store_stack m (Vptr sp Int.zero) Tint
                  (Int.repr (Stacklayout.fe_ofs_arg + 4*(ofs+1)))
                            (Vint (Int64.hiword n)) with
            | None => None
            | Some m' =>
                match  store_stack m' (Vptr sp Int.zero) Tint
                      (Int.repr (Stacklayout.fe_ofs_arg + 4*ofs))
                                (Vint (Int64.loword n)) with
                | None => None
                | Some m'' => Some (m'',ofs+2)
                end
          end
        | Tlong, _ => None
        | _,_ =>
          match store_stack m (Vptr sp Int.zero) ty'
                 (Int.repr (Stacklayout.fe_ofs_arg + 4*ofs)) a' with
            | None => None
            | Some m' => Some (m', ofs+typesize ty')
          end
      end.

Lemma store_argSZ m sp z ty v m' ofs:
      store_arg m sp z ty v = Some(m',ofs) -> ofs = z + typesize ty.
Proof. destruct ty; simpl; intros.
+ remember (store_stack m (Vptr sp Int.zero) Tint
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs in H. clear Heqs.
    destruct s; inv H. trivial.
+ remember (store_stack m (Vptr sp Int.zero) Tfloat
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs in H. clear Heqs.
    destruct s; inv H. trivial.
+ destruct v; inv H.
  - remember (store_stack m (Vptr sp Int.zero) Tint
                  (Int.repr (Stacklayout.fe_ofs_arg + 4*(z+1)))
                            (Vint (Int64.hiword i))) as s1.
    unfold Stacklayout.fe_ofs_arg in Heqs1. simpl in Heqs1.
    rewrite <- Heqs1 in *. clear Heqs1.
    destruct s1; inv H1.
    remember (store_stack m0 (Vptr sp Int.zero) Tint
                  (Int.repr (Stacklayout.fe_ofs_arg + 4*z))
                            (Vint (Int64.loword i))) as s2.
    unfold Stacklayout.fe_ofs_arg in Heqs2. simpl in Heqs2.
    rewrite <- Heqs2 in *. clear Heqs2.
    destruct s2; inv H0. trivial.
+ remember (store_stack m (Vptr sp Int.zero) Tsingle
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs in *. clear Heqs.
    destruct s; inv H. trivial.
+ remember (store_stack m (Vptr sp Int.zero) Tany32
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs in *. clear Heqs.
    destruct s; inv H. trivial.
+ remember (store_stack m (Vptr sp Int.zero) Tany64
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs in *. clear Heqs.
    destruct s; inv H. trivial.
Qed.

Lemma store_args_cons m sp z v args ty tys m1 z1:
  store_arg m sp z ty v = Some(m1, z1) ->
  (exists m', store_args_rec m1 sp z1 args tys = Some m') ->
  exists m', store_args_rec m sp z (v :: args) (ty :: tys) = Some m'.
Proof. intros.
simpl. unfold store_arg in H.
destruct ty.
+ remember (store_stack m (Vptr sp Int.zero) Tint
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs. clear Heqs.
    destruct s; inv H. simpl. assumption.
+ remember (store_stack m (Vptr sp Int.zero) Tfloat
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs. clear Heqs.
    destruct s; inv H. simpl. assumption.
+ destruct v; inv H.
  - remember (store_stack m (Vptr sp Int.zero) Tint
                  (Int.repr (Stacklayout.fe_ofs_arg + 4*(z+1)))
                            (Vint (Int64.hiword i))) as s1.
    unfold Stacklayout.fe_ofs_arg in Heqs1. simpl in Heqs1.
    rewrite <- Heqs1 in *. clear Heqs1.
    destruct s1; inv H2.
    remember (store_stack m0 (Vptr sp Int.zero) Tint
                  (Int.repr (Stacklayout.fe_ofs_arg + 4*z))
                            (Vint (Int64.loword i))) as s2.
    unfold Stacklayout.fe_ofs_arg in Heqs2. simpl in Heqs2.
    rewrite <- Heqs2 in *. clear Heqs2.
    destruct s2; inv H1. assumption.
+ remember (store_stack m (Vptr sp Int.zero) Tsingle
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs. clear Heqs.
    destruct s; inv H. simpl. assumption.
+ remember (store_stack m (Vptr sp Int.zero) Tany32
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs. clear Heqs.
    destruct s; inv H. simpl. assumption.
+ remember (store_stack m (Vptr sp Int.zero) Tany64
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    unfold Stacklayout.fe_ofs_arg in Heqs. simpl in Heqs.
    rewrite <- Heqs. clear Heqs.
    destruct s; inv H. simpl. assumption.
Qed.

Lemma store_arg_perm1: forall m sp z ty v mm zz
      (STA: store_arg m sp z ty v = Some (mm, zz)),
       forall (b' : block) (ofs' : Z) (k : perm_kind) (p : permission),
       Mem.perm m b' ofs' k p -> Mem.perm mm b' ofs' k p.
Proof. intros.
simpl. unfold store_arg in STA.
destruct ty.
+ remember (store_stack m (Vptr sp Int.zero) Tint
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    destruct s; inv STA. apply eq_sym in Heqs.
    unfold store_stack in Heqs; simpl in Heqs.
    eapply Mem.perm_store_1; eassumption.
+ remember (store_stack m (Vptr sp Int.zero) Tfloat
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    destruct s; inv STA. apply eq_sym in Heqs.
    unfold store_stack in Heqs; simpl in Heqs.
    eapply Mem.perm_store_1; eassumption.
+ destruct v; inv STA.
  - remember (store_stack m (Vptr sp Int.zero) Tint
                  (Int.repr (Stacklayout.fe_ofs_arg + 4*(z+1)))
                            (Vint (Int64.hiword i))) as s1.
    unfold Stacklayout.fe_ofs_arg in Heqs1. simpl in Heqs1.
    rewrite <- Heqs1 in *. apply eq_sym in Heqs1.
    destruct s1; inv H1.
    remember (store_stack m0 (Vptr sp Int.zero) Tint
                  (Int.repr (Stacklayout.fe_ofs_arg + 4*z))
                            (Vint (Int64.loword i))) as s2.
    unfold Stacklayout.fe_ofs_arg in Heqs2. simpl in Heqs2.
    rewrite <- Heqs2 in *. apply eq_sym in Heqs2.
    destruct s2; inv H2.
    unfold store_stack in *; simpl in *.
    eapply Mem.perm_store_1; try eassumption.
    eapply Mem.perm_store_1; eassumption.
+ remember (store_stack m (Vptr sp Int.zero) Tsingle
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    destruct s; inv STA. apply eq_sym in Heqs.
    unfold store_stack in Heqs; simpl in Heqs.
    eapply Mem.perm_store_1; eassumption.
+ remember (store_stack m (Vptr sp Int.zero) Tany32
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    destruct s; inv STA. apply eq_sym in Heqs.
    unfold store_stack in Heqs; simpl in Heqs.
    eapply Mem.perm_store_1; eassumption.
+ remember (store_stack m (Vptr sp Int.zero) Tany64
          (Int.repr (Stacklayout.fe_ofs_arg + 4 * z)) v) as s.
    destruct s; inv STA. apply eq_sym in Heqs.
    unfold store_stack in Heqs; simpl in Heqs.
    eapply Mem.perm_store_1; eassumption.
Qed.

Lemma store_args_rec_succeeds_aux sp:
  forall tys args
      (VALSDEF: val_casted.vals_defined args=true)
      (HASTY: Val.has_type_list args tys) sz
      (ALR: args_len_rec args tys = Some sz)
      z (POS: 0 <= z)
      (REP: 4*(z+sz) < Int.modulus) m
      (RP: Mem.range_perm m sp (4*z) (4*z + 4*sz) Cur Writable),
  exists m', store_args_rec m sp z args tys = Some m'.
Proof.
intros tys. induction tys.
+ intros.
  destruct args; simpl in *; inv ALR. rewrite Zplus_0_r in *.
     eexists; reflexivity.
+ destruct args. intros. inv ALR.
  intros. destruct HASTY.
  assert (ArgsDef: vals_defined args = true).
    destruct v; try inv VALSDEF; trivial.
 apply args_len_recD in ALR.
 destruct ALR as [sizeA [sz' [SZ [AL SzA]]]].
 assert (sizeA = typesize a).
 { clear - SzA H. destruct a; try solve[trivial]. simpl. admit. (*TODO (Gordon?): In CompCert 2.6, this assert is not true any longer*) }
 clear SzA.
 subst sz sizeA.
 assert (STARG: exists mm zz, store_arg m sp z a v = Some(mm,zz)).
 { clear IHtys H0.
   destruct (typ_eq a Tlong). subst a.
   { simpl. destruct v; try solve[simpl in VALSDEF; congruence | inv H].
     assert (H1: sz' >= 0) by (apply args_len_rec_nonneg in AL; omega).
     destruct (Mem.valid_access_store m (chunk_of_type Tint) sp (4*(z+1)) (Vint (Int64.hiword i)))
       as [mm ST].
      split. red; intros. eapply RP; clear RP.
        split. omega.
        assert (1 + size_chunk (chunk_of_type Tint) <= 4 * (typesize Tlong + sz')).
         { clear - AL. apply args_len_rec_nonneg in AL.
           unfold typesize. simpl size_chunk. omega. }
        destruct H0. simpl size_chunk in H3. simpl typesize. clear - H1 H3. omega.
        clear - POS. rewrite Zmult_comm. solve[simpl align_chunk; eapply Zdivide_intro; eauto].
     destruct (Mem.valid_access_store mm (chunk_of_type Tint) sp (4*z) (Vint (Int64.loword i)))
       as [mm' ST'].
      split. red; intros.
        eapply Mem.perm_store_1; eauto.
        eapply RP; eauto. clear RP. split. omega.
        assert (size_chunk (chunk_of_type Tint) <= 4 * (typesize Tlong + sz')).
         { clear - AL. apply args_len_rec_nonneg in AL.
           unfold typesize. simpl size_chunk. omega. }
        destruct H0. simpl size_chunk in H3. simpl typesize. clear - H1 H3. omega.
        clear - POS. rewrite Zmult_comm. solve[simpl align_chunk; eapply Zdivide_intro; eauto].
     unfold store_stack. simpl. simpl in ST, ST'.
     assert (A: 0 <= 4*(z+1) <= Int.max_unsigned).
     { split. omega. simpl typesize in REP.
       assert (1 + sz' >= 0) by (apply args_len_rec_nonneg in AL; omega).
       unfold Int.max_unsigned. omega. }
     assert (B: 0 <= 4*z <= Int.max_unsigned) by omega.
     rewrite !Int.add_zero_l, !Int.unsigned_repr, ST, ST'.
       exists mm', (z+2); trivial. solve[apply B]. solve[apply A]. }
   destruct (Mem.valid_access_store m (chunk_of_type a) sp (4*z) v) as [mm ST].
    split. red; intros. eapply RP; clear RP.
        split. omega.
        assert (size_chunk (chunk_of_type a) <= 4 * (typesize a + sz')).
         { clear - AL. apply args_len_rec_nonneg in AL.
            unfold typesize. destruct a; simpl in *.
               destruct sz'; xomega. destruct sz'. xomega.
               destruct p; xomega. xomega.
               destruct sz'; try xomega. destruct p; xomega.
               destruct sz'; try xomega.
               destruct sz'; try xomega.
               destruct sz'; try xomega.
               destruct p; try xomega.  }
         remember (size_chunk (chunk_of_type a)) as p1.
         remember (typesize a + sz') as p2. clear - H0 H1. omega.
      clear - POS n. rewrite Zmult_comm.
      destruct a; simpl align_chunk; eapply Zdivide_intro; eauto. congruence.
   clear RP.
   destruct a; simpl in ST; simpl.
    - unfold store_stack. simpl.
       rewrite Int.add_zero_l, Int.unsigned_repr, ST.
       exists mm, (z+1); trivial.
       assert (A: 0 <= 4*z <= Int.max_unsigned).
       { split. omega. simpl typesize in REP.
         assert (1 + sz' >= 0) by (apply args_len_rec_nonneg in AL; omega).
         unfold Int.max_unsigned. omega. }
       solve[apply A].
    - unfold store_stack. simpl.
       rewrite Int.add_zero_l, Int.unsigned_repr, ST.
       exists mm, (z+2); trivial.
       clear - POS REP AL.
       apply args_len_rec_nonneg in AL.
       destruct z; try xomega.
         unfold Int.max_unsigned; simpl; omega.
         assert (0 < typesize Tfloat + sz').
           simpl. destruct sz'. omega. xomega. xomega.
         remember (typesize Tfloat + sz') as q. clear  AL Heqq sz'.
           unfold Int.max_unsigned. xomega.
    - congruence.
    - unfold store_stack. simpl.
       rewrite Int.add_zero_l, Int.unsigned_repr, ST.
       exists mm, (z+1); trivial.
       clear - POS REP AL.
       apply args_len_rec_nonneg in AL.
       destruct z; try xomega.
         unfold Int.max_unsigned; simpl; omega.
         assert (0 < typesize Tsingle + sz').
           simpl. destruct sz'. omega. xomega. xomega.
         remember (typesize Tsingle + sz') as q. clear  AL Heqq sz'.
           unfold Int.max_unsigned. xomega.
    - unfold store_stack. simpl.
       rewrite Int.add_zero_l, Int.unsigned_repr, ST.
       exists mm, (z+1); trivial.
       clear - POS REP AL.
       apply args_len_rec_nonneg in AL.
       destruct z; try xomega.
         unfold Int.max_unsigned; simpl; omega.
         assert (0 < typesize Tany32 + sz').
           simpl. destruct sz'. omega. xomega. xomega.
         remember (typesize Tany32 + sz') as q. clear  AL Heqq sz'.
           unfold Int.max_unsigned. xomega.
    - unfold store_stack. simpl.
       rewrite Int.add_zero_l, Int.unsigned_repr, ST.
       exists mm, (z+2); trivial.
       clear - POS REP AL.
       apply args_len_rec_nonneg in AL.
       destruct z; try xomega.
         unfold Int.max_unsigned; simpl; omega.
         assert (0 < typesize Tany64 + sz').
           simpl. destruct sz'. omega. xomega. xomega.
         remember (typesize Tany64 + sz') as q. clear  AL Heqq sz'.
           unfold Int.max_unsigned. xomega.
 }
 specialize (IHtys _ ArgsDef H0 _ AL).
 rewrite Zplus_assoc in REP.
 assert (POS' : 0 <= z+typesize a). destruct a; simpl; omega.
 specialize (IHtys _ POS' REP).
 destruct STARG as [mm [zz STARG]].
 specialize (store_argSZ _ _ _ _ _ _ _ STARG). intros ZZ; subst zz.
 eapply store_args_cons. eassumption.
 apply IHtys; clear IHtys.
 red; intros. eapply store_arg_perm1; eauto.
 clear STARG. eapply RP; clear RP.
 specialize (typesize_pos a); intros. omega.
(*FIXME: *) Grab Existential Variables. refine (0).
Admitted. (*TODO: (End of proof containing the now incorrect typesize assertion)*)

Lemma store_args_rec_succeeds sz m sp args tys
      (VALSDEF: val_casted.vals_defined args=true)
      (HASTY: Val.has_type_list args tys)
      (REP: 4*sz < Int.modulus) m'' :
  args_len_rec args tys = Some sz ->
  Mem.alloc m 0 (4*sz) = (m'',sp) ->
  exists m', store_args_rec m'' sp 0 args tys = Some m'.
Proof.
intros H H2. exploit store_args_rec_succeeds_aux; eauto. omega. omega.
intros ofs [H3 H4]. apply Mem.perm_alloc_2 with (ofs := ofs) (k := Cur) in H2; auto.
eapply Mem.perm_implies; eauto. constructor.
Qed.

Definition store_args m sp args tys := store_args_rec m sp 0 args tys.

Require Import VST.ccc26x86.Conventions1.

(*Fixpoint agree_args_contains_aux m' sp' ofs args tys : Prop :=
  match args,tys with
    | nil,nil => True
    | a::args',ty::tys' =>
        Mem.load (chunk_of_type ty) m' sp' (fe_ofs_arg + 4*ofs) = Some a
        /\ agree_args_contains_aux m' sp' (ofs+1) args' tys'
    | _,_ => False
  end.*)

Fixpoint agree_args_contains_aux m' sp' ofs args tys : Prop :=
  let vsp := Vptr sp' Int.zero in
  match tys with
    | nil => args=nil
    | ty'::tys' =>
      match args with
        | nil => False
        | a'::args' =>
          match ty' with
            | Tlong =>
              match a' with
                | Vlong n =>
                  load_stack m' vsp Tint (Int.repr (4*(ofs+1)))
                  = Some (Vint (Int64.hiword n))
                  /\ load_stack m' vsp Tint (Int.repr (4*ofs))
                     = Some (Vint (Int64.loword n))
                  /\ agree_args_contains_aux m' sp' (ofs+2) args' tys'
                | _ => False
              end
            | _ =>
              load_stack m' vsp ty' (Int.repr (4*ofs)) = Some a'
              /\ agree_args_contains_aux m' sp' (ofs+typesize ty') args' tys'
          end
      end
  end.

Lemma agree_args_contains_aux_invariant:
  forall tys m sp ofs args m',
  agree_args_contains_aux m sp ofs args tys ->
  Mem.unchanged_on (fun b ofs => b=sp) m m' ->
  agree_args_contains_aux m' sp ofs args tys.
Proof.
induction tys. destruct args; simpl; auto.
intros m'; destruct args; simpl; auto. destruct a.
+ generalize
     (Int.repr
        match ofs with
        | 0 => 0
        | Z.pos y' => Z.pos y'~0~0
        | Z.neg y' => Z.neg y'~0~0
        end) as z.
  intros z [H H2] [H3 H4]. split; eauto.
  unfold load_stack, Mem.loadv in H3|-*.
  revert H3; case_eq (Val.add (Vptr sp Int.zero) (Vint z));
    try solve[inversion 1].
  simpl; intros ? ?; inversion 1; subst.
  eapply Mem.load_unchanged_on. eapply H0. intros. solve[simpl; auto].
+ generalize
     (Int.repr
        match ofs with
        | 0 => 0
        | Z.pos y' => Z.pos y'~0~0
        | Z.neg y' => Z.neg y'~0~0
        end) as z.
  intros z [H H2] [H3 H4]. split; eauto.
  unfold load_stack, Mem.loadv in H3|-*.
  revert H3; case_eq (Val.add (Vptr sp Int.zero) (Vint z));
    try solve[inversion 1].
  simpl; intros ? ?; inversion 1; subst.
  eapply Mem.load_unchanged_on. eapply H0. intros. solve[simpl; auto].
+ generalize
     (Int.repr
        match ofs with
        | 0 => 0
        | Z.pos y' => Z.pos y'~0~0
        | Z.neg y' => Z.neg y'~0~0
        end) as z.
  generalize
     (Int.repr
        match ofs + 1 with
        | 0 => 0
        | Z.pos y' => Z.pos y'~0~0
        | Z.neg y' => Z.neg y'~0~0
        end) as z1.
  destruct v; try inversion 3.
  intros z1 z [H H2] [H3 [H4 H5]]. split; eauto.
  unfold load_stack, Mem.loadv in H3|-*.
  revert H3; case_eq (Val.add (Vptr sp Int.zero) (Vint z));
    try solve[inversion 1].
  simpl; intros ? ?; inversion 1; subst.
  eapply Mem.load_unchanged_on. eapply H0. intros. solve[simpl; auto].
  split. eapply Mem.load_unchanged_on; eauto. intros. solve[simpl; auto].
  solve[eapply IHtys; eauto].
+ generalize
     (Int.repr
        match ofs with
        | 0 => 0
        | Z.pos y' => Z.pos y'~0~0
        | Z.neg y' => Z.neg y'~0~0
        end) as z.
  intros z [H H2] [H3 H4]. split; eauto.
  unfold load_stack, Mem.loadv in H3|-*.
  revert H3; case_eq (Val.add (Vptr sp Int.zero) (Vint z));
    try solve[inversion 1].
  simpl; intros ? ?; inversion 1; subst.
  eapply Mem.load_unchanged_on. eapply H0. intros. solve[simpl; auto].
+ generalize
     (Int.repr
        match ofs with
        | 0 => 0
        | Z.pos y' => Z.pos y'~0~0
        | Z.neg y' => Z.neg y'~0~0
        end) as z.
  intros z [H H2] [H3 H4]. split; eauto.
  unfold load_stack, Mem.loadv in H3|-*.
  revert H3; case_eq (Val.add (Vptr sp Int.zero) (Vint z));
    try solve[inversion 1].
  simpl; intros ? ?; inversion 1; subst.
  eapply Mem.load_unchanged_on. eapply H0. intros. solve[simpl; auto].
+ generalize
     (Int.repr
        match ofs with
        | 0 => 0
        | Z.pos y' => Z.pos y'~0~0
        | Z.neg y' => Z.neg y'~0~0
        end) as z.
  intros z [H H2] [H3 H4]. split; eauto.
  unfold load_stack, Mem.loadv in H3|-*.
  revert H3; case_eq (Val.add (Vptr sp Int.zero) (Vint z));
    try solve[inversion 1].
  simpl; intros ? ?; inversion 1; subst.
  eapply Mem.load_unchanged_on. eapply H0. intros. solve[simpl; auto].
Qed.

Lemma args_len_rec_bound args tys z :
  args_len_rec args tys = Some z -> z <= 2*Zlength args.
Proof.
  revert args z. induction tys. destruct args. simpl. inversion 1; omega.
  simpl. inversion 1. destruct args. inversion 1. intros z H.
  apply args_len_recD in H. destruct H as [z1 [z2 [Zeq [? H2]]]]. subst z.
  specialize (IHtys _ _ H). destruct a; subst z1; rewrite Zlength_cons; omega.
Qed.

Lemma store_args_inject args args' tys j m m' m2 m2' b b' z :
  Val.inject_list j args args' ->
  Mem.inject j m m' ->
  j b = Some (b',0) ->
  store_args_rec m b z args tys = Some m2 ->
  store_args_rec m' b' z args' tys = Some m2' ->
  Mem.inject j m2 m2'.
Proof.
intros A B C D E.
revert args args' m m' z A B D E. induction tys.
intros args args' m m' z H. inv H. simpl.
  inversion 2; subst. solve[inversion 1; subst; auto].
intros ? ?; inversion 1.
intros ? ? ? ? ?. intros H. inv H. solve[inversion 2]. simpl. intros H.
generalize
 (Int.repr match z with
             | 0 => 0 | Z.pos y' => Z.pos y'~0~0
             | Z.neg y' => Z.neg y'~0~0 end) as z'.
generalize
 (Int.repr match z+1 with
             | 0 => 0 | Z.pos y' => Z.pos y'~0~0
             | Z.neg y' => Z.neg y'~0~0 end) as z''.
intros z'' z'. destruct a.
- case_eq (store_stack m (Vptr b Int.zero) Tint z' v);
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE H2.
exploit Mem.store_mapped_inject; try eassumption.
intros [m0' [STORE' INJ]].
rewrite Zplus_0_r in STORE'. rewrite STORE'. intros H3.
eapply IHtys; eauto.
- case_eq (store_stack m (Vptr b Int.zero) Tfloat z' v);
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE H2.
exploit Mem.store_mapped_inject; try eassumption.
intros [m0' [STORE' INJ]].
rewrite Zplus_0_r in STORE'. rewrite STORE'. intros H3.
eapply IHtys; eauto.
- inv H0; try solve[inversion 1].
case_eq (store_stack m (Vptr b Int.zero) Tint z'' (Vint (Int64.hiword i)));
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE H2.
exploit Mem.store_mapped_inject; eauto.
intros [m0' [STORE' INJ]].
rewrite Zplus_0_r in STORE'. rewrite STORE'.
revert H2. rewrite Int.add_zero_l.
case_eq (Mem.store Mint32 m0 b (Int.unsigned z') (Vint (Int64.loword i)));
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m1 STORE1 H3.
exploit Mem.store_mapped_inject; eauto.
intros [m1' [STORE1' INJ']]. rewrite Zplus_0_r in STORE1'. rewrite STORE1'.
eapply IHtys; eauto.
- case_eq (store_stack m (Vptr b Int.zero) Tsingle z' v);
  try solve[intros; congruence].
unfold store_stack, Mem.storev. simpl. intros m0 STORE H2.
exploit Mem.store_mapped_inject; try eassumption. eauto.
intros [m0' [STORE' INJ]].
rewrite Zplus_0_r in STORE'. rewrite STORE'. intros H3.
eapply IHtys; eauto.
- case_eq (store_stack m (Vptr b Int.zero) Tany32 z' v);
  try solve[intros; congruence].
  unfold store_stack, Mem.storev. simpl. intros m0 STORE H2.
  exploit Mem.store_mapped_inject; try eassumption.
  intros [m0' [STORE' INJ]].
  rewrite Zplus_0_r in STORE'. rewrite STORE'. intros H3.
  eapply IHtys; eauto.
- case_eq (store_stack m (Vptr b Int.zero) Tany64 z' v);
  try solve[intros; congruence].
  unfold store_stack, Mem.storev. simpl. intros m0 STORE H2.
  exploit Mem.store_mapped_inject; try eassumption.
  intros [m0' [STORE' INJ]].
  rewrite Zplus_0_r in STORE'. rewrite STORE'. intros H3.
  eapply IHtys; eauto.
Qed.

Lemma args_len_rec_inject j args args' tys z z' :
  Val.inject_list j args args' ->
  args_len_rec args tys = Some z ->
  args_len_rec args' tys = Some z' ->
  z=z'.
Proof.
intros.
revert tys z z' H0 H1.
induction H.
simpl. destruct tys; inversion 1. inversion 1; subst; auto.
destruct tys; inversion 1. simpl. destruct t.
+ inv H1.
revert H3 H4.
case_eq (args_len_rec vl tys); try solve[intros; congruence]. intros.
revert H2. case_eq (args_len_rec vl' tys); try solve[intros; congruence]. intros.
exploit IHinject_list; eauto.
intros. subst z0. inv H3; inv H4; inv H5. omega.
+ inv H1.
revert H3 H4.
case_eq (args_len_rec vl tys); try solve[intros; congruence]. intros.
revert H2. case_eq (args_len_rec vl' tys); try solve[intros; congruence]. intros.
exploit IHinject_list; eauto.
intros. subst z0. inv H3; inv H4; inv H5. omega.
+ inv H1.
revert H3 H4.
destruct v; try solve[inversion 1].
destruct v'; try solve[inversion 3].
case_eq (args_len_rec vl tys); try solve[inversion 2].
case_eq (args_len_rec vl' tys); try solve[intros; congruence]. intros.
exploit IHinject_list; eauto.
intros. subst z0. inv H3; inv H4; inv H5. omega.
+ inv H1.
revert H3 H4.
case_eq (args_len_rec vl tys); try solve[intros; congruence]. intros.
revert H2. case_eq (args_len_rec vl' tys); try solve[intros; congruence]. intros.
exploit IHinject_list; eauto.
intros. subst z0. inv H3; inv H4; inv H5. omega.
+ inv H1.
revert H3 H4.
case_eq (args_len_rec vl tys); try solve[intros; congruence]. intros.
revert H2. case_eq (args_len_rec vl' tys); try solve[intros; congruence]. intros.
exploit IHinject_list; eauto.
intros. subst z0. inv H3; inv H4; inv H5. omega.
+ inv H1.
revert H3 H4.
case_eq (args_len_rec vl tys); try solve[intros; congruence]. intros.
revert H2. case_eq (args_len_rec vl' tys); try solve[intros; congruence]. intros.
exploit IHinject_list; eauto.
intros. subst z0. inv H3; inv H4; inv H5. omega.
Qed.

Lemma sm_locally_allocated_only_stores1 mu mu' b1 l1 m1 m2 m1' m2' m1'' :
  mem_forward m1 m1' ->
  sm_locally_allocated mu mu' m1 m2 m1' m2' ->
  only_stores b1 l1 m1' m1'' ->
  sm_locally_allocated mu mu' m1 m2 m1'' m2'.
Proof.
intros.
revert m2 m2' mu mu' H H0. induction X; auto. intros.
apply IHX.
eapply mem_forward_trans; eauto. apply store_forward in e. auto. auto.
rewrite sm_locally_allocatedChar in H0|-*.
destruct H0 as [? [? [? [? [? ?]]]]].
intuition.
generalize e as e'. intro.
apply store_freshloc in e. rewrite H0.
extensionality b. destruct (DomSrc mu b); auto. simpl.
symmetry. rewrite <-freshloc_trans with (m'':= m); auto. rewrite e.
  solve[rewrite orb_comm; auto].
apply store_forward in e'. eauto.
rewrite H2. extensionality b. destruct (locBlocksSrc mu b); simpl; auto.
generalize e as e'. intro.
apply store_freshloc in e.
symmetry. rewrite <-freshloc_trans with (m'':= m); auto. rewrite e.
  solve[rewrite orb_comm; auto].
apply store_forward in e'. eauto.
Qed.

Lemma sm_locally_allocated_only_stores2 mu mu' b2 l2 m1 m2 m1' m2' m2'' :
  mem_forward m2 m2' ->
  sm_locally_allocated mu mu' m1 m2 m1' m2' ->
  only_stores b2 l2 m2' m2'' ->
  sm_locally_allocated mu mu' m1 m2 m1' m2''.
Proof.
intros.
revert m1 m1' mu mu' H H0. induction X; auto. intros.
apply IHX; auto.
eapply mem_forward_trans; eauto. apply store_forward in e. auto.
rewrite sm_locally_allocatedChar in H0|-*.
destruct H0 as [? [? [? [? [? ?]]]]].
intuition.
generalize e as e'. intro.
apply store_freshloc in e. rewrite H1.
extensionality b. destruct (DomTgt mu b); auto. simpl.
symmetry. rewrite <-freshloc_trans with (m'':= m); auto. rewrite e.
  solve[rewrite orb_comm; auto].
apply store_forward in e'. eauto.
rewrite H3. extensionality b. destruct (locBlocksTgt mu b); simpl; auto.
generalize e as e'. intro.
apply store_freshloc in e.
symmetry. rewrite <-freshloc_trans with (m'':= m); auto. rewrite e.
  solve[rewrite orb_comm; auto].
apply store_forward in e'. eauto.
Qed.

Lemma sm_locally_allocated_only_stores mu mu' b1 b2 l1 l2 m1 m2 m1' m2' m1'' m2'' :
  mem_forward m1 m1' ->
  mem_forward m2 m2' ->
  sm_locally_allocated mu mu' m1 m2 m1' m2' ->
  only_stores b1 l1 m1' m1'' ->
  only_stores b2 l2 m2' m2'' ->
  sm_locally_allocated mu mu' m1 m2 m1'' m2''.
Proof.
intros.
eapply sm_locally_allocated_only_stores1; eauto.
eapply sm_locally_allocated_only_stores2; eauto.
Qed.

Lemma sm_valid_only_stores mu b1 b2 l1 l2 m1 m2 m1' m2' :
  sm_valid mu m1 m2 ->
  only_stores b1 l1 m1 m1' ->
  only_stores b2 l2 m2 m2' ->
  sm_valid mu m1' m2'.
Proof.
revert m2 m2' b2 l2 mu; induction 2. induction 1; auto.
apply Mem.nextblock_store in e.
apply IHX. unfold sm_valid. unfold Mem.valid_block. rewrite e.
destruct H. split; auto.
intros. apply IHX; auto. apply Mem.nextblock_store in e.
destruct H. unfold sm_valid, Mem.valid_block. rewrite e. auto.
Qed.

Lemma REACH_only_stores b l m m' roots :
  only_stores b l m m' ->
  roots b = true ->
  (forall b' : block,
     getBlocks l b' = true -> roots b' = true) ->
  REACH_closed m roots ->
  REACH_closed m' roots.
Proof.
induction 1; auto. intros H H2 H3. apply IHX; auto.
intros. apply H2. rewrite getBlocksD. destruct v; auto.
  solve[rewrite orb_true_iff; auto].
eapply REACH_Store; eauto.
intros. eapply H2. rewrite getBlocksD in H0|-*.
destruct v; auto; try solve[rewrite getBlocksD_nil in H0; congruence].
rewrite getBlocksD_nil, orb_comm in H0; simpl in H0.
rewrite H0; auto.
Qed.

Lemma store_stack_mem m sp ty ofs v m'
        (ST: store_stack m sp ty ofs v = Some m'):
      mem_step m m'.
Proof. intros.
 unfold store_stack in ST. destruct sp; simpl in ST; inv ST.
 eapply mem_step_store; eassumption.
Qed.

Lemma store_args_mem sp ofs args tys m m' :
  store_args_rec m sp ofs args tys = Some m' ->
  mem_step m m'.
Proof.
revert args ofs m; induction tys.
+ destruct args.
  - intros ofs. inversion 1; subst. apply mem_step_refl.
  - intros ofs m. simpl. inversion 1.
+ destruct args; try solve[inversion 1].
  destruct a; simpl; intros ofs m.
  - case_eq (store_stack m (Vptr sp Int.zero) Tint
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
    * intros.
      eapply mem_step_trans.
       apply (store_stack_mem _ _ _ _ _ _ H).
       eapply IHtys; eassumption.
    * intros; congruence.
  - case_eq (store_stack m (Vptr sp Int.zero) Tfloat
           (Int.repr match ofs with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                    | Z.neg y' => Z.neg y'~0~0 end) v).
    * intros.
      eapply mem_step_trans.
       apply (store_stack_mem _ _ _ _ _ _ H).
       eapply IHtys; eassumption.
    * intros; congruence.
  - destruct v; try solve[congruence].
    case_eq (store_stack m (Vptr sp Int.zero) Tint
           (Int.repr match ofs+1 with | 0 => 0 | Z.pos y' => Z.pos y'~0~0
                                      | Z.neg y' => Z.neg y'~0~0 end)
        (Vint (Int64.hiword i))).
    * intros.
       remember (store_stack m0 (Vptr sp Int.zero) Tint
        (Int.repr
           match ofs with
           | 0 => 0
           | Z.pos y' => Z.pos y'~0~0
           | Z.neg y' => Z.neg y'~0~0
           end) (Vint (Int64.loword i))).
       symmetry in Heqo; destruct o; inv H0.
      eapply mem_step_trans.
       apply (store_stack_mem _ _ _ _ _ _ H).
      eapply mem_step_trans.
       apply (store_stack_mem _ _ _ _ _ _ Heqo).
      eapply IHtys; eassumption.
    * intros; congruence.
  - intros.
    remember (store_stack m (Vptr sp Int.zero) Tsingle
        (Int.repr
           match ofs with
           | 0 => 0
           | Z.pos y' => Z.pos y'~0~0
           | Z.neg y' => Z.neg y'~0~0
           end) v).
       symmetry in Heqo; destruct o; inv H.
      eapply mem_step_trans.
       apply (store_stack_mem _ _ _ _ _ _ Heqo).
       eapply IHtys; eassumption.
  - intros.
    remember (store_stack m (Vptr sp Int.zero) Tany32
        (Int.repr
           match ofs with
           | 0 => 0
           | Z.pos y' => Z.pos y'~0~0
           | Z.neg y' => Z.neg y'~0~0
           end) v).
       symmetry in Heqo; destruct o; inv H.
      eapply mem_step_trans.
       apply (store_stack_mem _ _ _ _ _ _ Heqo).
       eapply IHtys; eassumption.
  - intros.
    remember (store_stack m (Vptr sp Int.zero) Tany64
        (Int.repr
           match ofs with
           | 0 => 0
           | Z.pos y' => Z.pos y'~0~0
           | Z.neg y' => Z.neg y'~0~0
           end) v).
       symmetry in Heqo; destruct o; inv H.
      eapply mem_step_trans.
       apply (store_stack_mem _ _ _ _ _ _ Heqo).
       eapply IHtys; eassumption.
Qed.

Lemma store_args_mem_step m stk args tys m':
  store_args m stk args tys = Some m' -> mem_step m m'.
Proof. intros. unfold store_args in H.
  apply store_args_rec_only_stores in H.
  remember (encode_longs tys args). clear Heql.
  induction H. apply mem_step_refl.
  eapply mem_step_trans; try eassumption.
  eapply mem_step_store; eassumption.
Qed.


Require Import floyd.proofauto.
Import ListNotations.
Require sha.sha.
Require sha.SHA256.
Local Open Scope logic.

Require Import sha.spec_sha.
Require Import sha_lemmas.
Require Import sha.HMAC_functional_prog.

Require Import sha.hmac091c.

Require Import sha.spec_hmac.

Lemma isbyte_Nlist i n: isbyteZ i -> Forall isbyteZ (Nlist i n).
  intros. apply Forall_forall. intros.
  induction n; simpl in *. contradiction.
  destruct H0. subst. trivial.
  apply (IHn H0).
Qed.

Lemma body_hmac_cleanup: semax_body HmacVarSpecs HmacFunSpecs
       f_HMAC_cleanup HMAC_Cleanup_spec.
Proof.
start_function.
name ctx' _ctx.
unfold hmacstate_simple, hmac_relate_simple. normalize. intros hst. normalize.
apply semax_pre with (P':=
  PROP (size_compatible t_struct_hmac_ctx_st c /\
        align_compatible t_struct_hmac_ctx_st c)
   LOCAL  (`(eq c) (eval_id _ctx))
   SEP
   (`(data_at Tsh t_struct_hmac_ctx_st
        (upd_reptype t_struct_hmac_ctx_st [_md_ctx] hst
           (default_val t_struct_SHA256state_st)) c))).
  entailer. unfold data_at. simpl. normalize.
normalize.

forward_call (Tsh, c, sizeof t_struct_hmac_ctx_st, Int.zero).
  { assert (FR: Frame = nil).
      subst Frame. reflexivity.
    rewrite FR. clear FR Frame.
    entailer.
    eapply derives_trans. apply data_at_data_at_.
       reflexivity.
    rewrite <- memory_block_data_at_; try reflexivity.
    entailer.
  }
after_call. subst retval0.
forward.
assert (isByte0:  isbyteZ 0). unfold isbyteZ. omega.
specialize (isbyte_Nlist 0 (Z.to_nat (sizeof t_struct_hmac_ctx_st)) isByte0).
unfold data_block. rewrite Zlength_correct; simpl. intros.
entailer.
Qed.


(** * Saturation of the Grothendieck Construction of a functor to Set *)
Require Import Category.Core Functor.Core.
Require Import Category.Univalent.
Require Import Category.Morphisms.
Require Import SetCategory.Core.
Require Import Grothendieck.ToSet.Core Grothendieck.ToSet.Morphisms.
Require Import HoTT.Basics.Equivalences HoTT.Basics.Trunc.
Require Import HoTT.Types.Universe HoTT.Types.Sigma.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.

Section Grothendieck.
  Context `{Univalence}.

  Variable C : PreCategory.
  Context `{IsCategory C}.
  Variable F : Functor C set_cat.

  Definition category_isotoid_helper {s d} (a : c s = c d)
  : (transport (fun c : C => F c) a (x s) = x d)
      <~> (F _1 (idtoiso C a)) (x s) = x d.
  Proof.
    apply equiv_path.
    apply ap10, ap.
    destruct a; simpl.
    exact (ap10 (identity_of F _)^ _).
  Defined.

  Arguments category_isotoid_helper : simpl never.

  Definition category_isotoid {s d : category F}
  : s = d <~> (s <~=~> d)%category.
  Proof.
    refine (isequiv_sigma_category_isomorphism^-1 oE _ oE (equiv_ap' (issig_pair F)^-1 s d)).
    refine (_ oE (equiv_path_sigma _ _ _)^-1).
    simpl.
    simple refine (equiv_functor_sigma' _ _).
    { exists (@idtoiso C _ _).
      exact _. }
    { exact category_isotoid_helper. }
  Defined.

  Global Instance preservation : IsCategory (category F).
  Proof.
    intros s d.
    refine (@isequiv_homotopic _ _ category_isotoid (idtoiso (category F) (x:=s) (y:=d)) _ _).
    intro x.
    destruct x; apply path_isomorphic, path_sigma_hprop.
    reflexivity.
  Defined.
End Grothendieck.


Require Import Eqdep Lia Framework FSParameters FileDiskLayer. (* LoggedDiskLayer TransactionCacheLayer TransactionalDiskLayer. *)
Require Import FileDiskNoninterference FileDiskRefinement.
Require Import ATCDLayer FileDisk.TransferProofs ATCD_Simulation ATCD_AOE.
Require Import Not_Init HSS ATCD_ORS.
Require Import ATCD_TS_Recovery ATCD_TS_Common ATCD_TS_Operations.

Import FileDiskLayer.
Set Nested Proofs Allowed.
Opaque File.recover.

Lemma ATCD_TS_BatchOperations_encrypt_all:
  forall n u k l1 l2 txns1 txns2 hdr1 hdr2,
  length l1 = length l2 ->
Termination_Sensitive u
(@lift_L2 AuthenticationOperation _ TCDLang _
  (@lift_L2 _ _ CachedDiskLang _
     (|CDDP| BatchOperations.encrypt_all k l1)))
(@lift_L2 AuthenticationOperation _ TCDLang _
     (@lift_L2 _ _ CachedDiskLang _
        (|CDDP| BatchOperations.encrypt_all k l2)))
   (Simulation.Definitions.compile
     ATCD_Refinement
     (Simulation.Definitions.compile
   ATC_Refinement
   (Simulation.Definitions.compile
      FD.refinement
      (| Recover |))))
  (refines_valid ATCD_Refinement
  (refines_valid ATC_Refinement AD_valid_state))
  (fun s1 s2 => equivalent_for_recovery txns1 txns2
  Log.Current_Part hdr1 hdr2 s1 s2 /\
  (forall x,
  consistent_with_upds (snd (fst (snd (snd (snd s1))))) (firstn x (map (encrypt k) l1)) (firstn x (map (fun v => (k, v)) l1)) ->
  consistent_with_upds (snd (fst (snd (snd (snd s2))))) (firstn x (map (encrypt k) l2)) (firstn x (map (fun v => (k, v)) l2))))
(ATCD_reboot_list n).
Proof.
   unfold Termination_Sensitive, ATCD_reboot_list;
   intros; destruct n;
   repeat invert_exec.
   {
      repeat invert_lift2; cleanup.
      destruct s2, s0, s2, s3.

      eapply_fresh BatchOperations.encrypt_all_finished in H8; cleanup; eauto.
      eapply BatchOperations_TS_encrypt_all in H8; eauto; cleanup.
      eexists (RFinished _ _).
      repeat econstructor; eauto.
      repeat eapply lift2_exec_step; eauto.
      specialize (c (length l1)).
      do 4 rewrite firstn_oob in c.
      simpl in *.
      eapply c; eauto.
      all: repeat rewrite map_length; lia.
    }
    {
      repeat invert_lift2; cleanup.
      destruct s2, s0, s2, s3.

      eapply_fresh BatchOperations.encrypt_all_crashed in H8; cleanup.
      eapply BatchOperations_TS_encrypt_all_crashed in H8; eauto; cleanup.
      eapply_fresh BatchOperations.encrypt_all_crashed in H8; cleanup.
      repeat cleanup_pairs.
      simpl in *.
       edestruct ATCD_TS_recovery.
       3: eauto.
       3: shelve. (* eapply equivalent_for_recovery_after_reboot; eauto. *)

       3: {
          eexists (Recovered _); econstructor; eauto.
      repeat eapply lift2_exec_step_crashed; eauto.
      }

      all: try solve [unfold AD_valid_state,
      refines_valid, FD_valid_state;
      intros; simpl; eauto].
    }
    Unshelve.
    all: try exact ATCDLang.
    6: {
      unfold equivalent_for_recovery in *; simpl in *;
      cleanup.
      eexists (_, (_, _)), (_, (_,_)); split.
      simpl; intuition eauto.
      rewrite e2 in *;
      do 2 eexists; intuition eauto.
      eapply RepImplications.log_rep_explicit_after_reboot in l0; simpl in *.
      eapply RepImplications.log_rep_explicit_consistent_with_upds; eauto.
      eapply select_total_mem_synced in H3; eauto.

      simpl. split.
      repeat split.
      do 2 eexists; split.
      eapply RepImplications.log_rep_explicit_after_reboot in l; simpl in *.
      eapply RepImplications.log_rep_explicit_consistent_with_upds; eauto.
      all: intuition eauto.
      eapply select_total_mem_synced in H3; eauto.
    }
Qed.

Lemma ATCD_TS_BatchOperations_hash_all:
  forall n u l1 l2 h1 h2 txns1 txns2 hdr1 hdr2,
  length l1 = length l2 ->
Termination_Sensitive u
(@lift_L2 AuthenticationOperation _ TCDLang _
  (@lift_L2 _ _ CachedDiskLang _
     (|CDDP| BatchOperations.hash_all h1 l1)))
(@lift_L2 AuthenticationOperation _ TCDLang _
     (@lift_L2 _ _ CachedDiskLang _
        (|CDDP| BatchOperations.hash_all h2 l2)))
   (Simulation.Definitions.compile
     ATCD_Refinement
     (Simulation.Definitions.compile
   ATC_Refinement
   (Simulation.Definitions.compile
      FD.refinement
      (| Recover |))))
  (refines_valid ATCD_Refinement
  (refines_valid ATC_Refinement AD_valid_state))
  (fun s1 s2 => equivalent_for_recovery txns1 txns2
  Log.Current_Part hdr1 hdr2 s1 s2 /\
  (forall x,
  consistent_with_upds (snd (fst (fst (snd (snd (snd s1))))))
  (firstn x (rolling_hash_list h1 l1))
  (firstn x (combine (h1 :: rolling_hash_list h1 l1) l1)) ->
  consistent_with_upds (snd (fst (fst (snd (snd (snd s2))))))
  (firstn x (rolling_hash_list h2 l2))
  (firstn x (combine (h2 :: rolling_hash_list h2 l2) l2))))
(ATCD_reboot_list n).
Proof.
   unfold Termination_Sensitive, ATCD_reboot_list;
   intros; destruct n;
   repeat invert_exec.
   {
      repeat invert_lift2; cleanup.
      destruct s2, s0, s2, s3.
      eapply BatchOperations_TS_hash_all in H8; eauto; cleanup.
      eexists (RFinished _ _).
      repeat econstructor; eauto.
      repeat eapply lift2_exec_step; eauto.
      eapply BatchOperations.hash_all_finished in H8; cleanup; eauto.
      specialize (c (length l1)).
      do 4 rewrite firstn_oob in c.
      apply c; eauto.
      all: repeat rewrite combine_length; try lia.

      all: rewrite rolling_hash_list_length; lia.
    }
    {
      repeat invert_lift2; cleanup.
      destruct s2, s0, s2, s3.
      eapply_fresh BatchOperations_TS_hash_all_crashed in H8; eauto; cleanup.
      eapply BatchOperations.hash_all_crashed in H8; cleanup.
      eapply_fresh BatchOperations.hash_all_crashed in H2; cleanup.
      repeat cleanup_pairs.
      simpl in *.
       edestruct ATCD_TS_recovery.
       3: eauto.
       3: shelve. (* eapply equivalent_for_recovery_after_reboot; eauto. *)
       3: {
         eexists (Recovered _); econstructor; eauto.
         repeat eapply lift2_exec_step_crashed; eauto.
       }
       (* 3: repeat cleanup_pairs; eauto. *)
       all: try solve [unfold AD_valid_state,
       refines_valid, FD_valid_state;
       intros; simpl; eauto].
    }
    Unshelve.
    all: try exact ATCDLang.
    6: {
      unfold equivalent_for_recovery in *; simpl in *;
      cleanup_no_match.
      eexists (_, (_, _)), (_, (_,_)); split.
      simpl; intuition eauto.
      rewrite e2 in *;
      do 2 eexists; intuition eauto.
      eapply RepImplications.log_rep_explicit_after_reboot in l4; simpl in *.
      eapply RepImplications.log_rep_explicit_consistent_with_upds_hashmap; eauto.
      eapply select_total_mem_synced in H4; eauto.

      simpl. split.
      repeat split.
      do 2 eexists; split.
      eapply RepImplications.log_rep_explicit_after_reboot in l3; simpl in *.
      eapply RepImplications.log_rep_explicit_consistent_with_upds_hashmap; eauto.
      all: intuition eauto.
      eapply select_total_mem_synced in H4; eauto.
    }
Qed.

Lemma ATCD_TS_BatchOperations_write_batch:
  forall n u la1 la2 lv1 lv2 txns1 txns2 hdr1 hdr2,
  length la1 = length la2 ->
  length lv1 = length lv2 ->
  length la2 = length lv2 ->
  Forall (fun a => a < disk_size) la2 ->
Termination_Sensitive u
(@lift_L2 AuthenticationOperation _ TCDLang _
  (@lift_L2 _ _ CachedDiskLang _
     (|CDDP| BatchOperations.write_batch la1 lv1)))
(@lift_L2 AuthenticationOperation _ TCDLang _
     (@lift_L2 _ _ CachedDiskLang _
        (|CDDP| BatchOperations.write_batch la2 lv2)))
   (Simulation.Definitions.compile
     ATCD_Refinement
     (Simulation.Definitions.compile
   ATC_Refinement
   (Simulation.Definitions.compile
      FD.refinement
      (| Recover |))))
  (refines_valid ATCD_Refinement
  (refines_valid ATC_Refinement AD_valid_state))
  (equivalent_for_recovery txns1 txns2
  Log.Current_Part hdr1 hdr2)
(ATCD_reboot_list n).
Proof.
   unfold Termination_Sensitive, ATCD_reboot_list;
   intros; destruct n;
   repeat invert_exec.
   {
      repeat invert_lift2; cleanup.
      destruct s2, s0, s2, s3.
      eapply BatchOperations_TS_write_batch in H12; cleanup.
      eexists (RFinished _ _).
      repeat econstructor; eauto.
      repeat eapply lift2_exec_step; eauto.
      all: eauto.
    }
    {
      repeat invert_lift2; cleanup.
      destruct s2, s0, s2, s3.
      eapply_fresh BatchOperations_TS_write_batch_crashed in H12; cleanup.
      eapply BatchOperations.write_batch_crashed in H12; cleanup.
      eapply_fresh BatchOperations.write_batch_crashed in H5; cleanup.
      simpl in *.
       edestruct ATCD_TS_recovery.
       3: eauto.
       3: shelve. (* eapply equivalent_for_recovery_after_reboot; eauto. *)
      3: {
         eexists (Recovered _); econstructor; eauto.
      repeat eapply lift2_exec_step_crashed; eauto.
    }
    all: try solve [unfold AD_valid_state,
      refines_valid, FD_valid_state;
      intros; simpl; eauto].

    Unshelve.
    all: try exact ATCDLang.
    6: {
       (* probably need to add the fact that
       it is written to the end of the log *)
      admit. (*
      unfold equivalent_for_recovery in *; simpl in *;
      cleanup_no_match.
      eexists (_, (_, _)), (_, (_,_)); split.
      simpl; intuition eauto.
      do 2 eexists; intuition eauto.

      Search Log.log_rep_explicit upd_batch_set.
      eapply RepImplications.log_rep_explicit_after_reboot in l4; simpl in *.
      eapply RepImplications.log_rep_explicit_consistent_with_upds_hashmap; eauto.
      eapply select_total_mem_synced in H3; eauto.

      simpl. split.
      repeat split.
      do 2 eexists; split.
      eapply RepImplications.log_rep_explicit_after_reboot in l3; simpl in *.
      eapply RepImplications.log_rep_explicit_consistent_with_upds_hashmap; eauto.
      all: intuition eauto.
      eapply select_total_mem_synced in H3; eauto.
      *)
    }
Admitted.