Require Import UNIVERSE.
Require Import Events.
Require Import CoqlibC.
Require Import Simulation.
Require Import LinkingC.
Require Import JMeq.
Require Import SmallstepC.

Require Import 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_sim_skenv_weak; 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 (prog_main ss_link.(SimSymb.src)))
                              (Genv.symbol_address skenv_link_tgt (prog_main ss_link.(SimSymb.tgt)))>>).
  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. }
        dup SIMGE. eapply SimSymb.sim_skenv_sim_skenv_weak in 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 -> Mem.t -> 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 -> Mem.t -> 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)))
                [] 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)))
                [] 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_sim_skenv_weak. 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.
                subst skenv_link_src; congruence.
              }
              eapply lift_dplus; eauto.
              { unsguard SETGT. ss. des_ifs.
                subst skenv_link_tgt; congruence.
              }
            - 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. subst skenv_link_tgt; congruence. }
          }
          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. subst skenv_link_src; congruence. }
          eapply at_external_receptive_at; et. }
        apply plus_one. econs; ss; eauto.
        { eapply lift_determinate_at; et.
          { unsguard SETGT. ss. des_ifs. subst skenv_link_tgt; congruence. }
          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. rewrite INT0 in *. eapply Vint_inj; et.
        - 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. subst skenv_link_src; congruence. }
          eapply final_frame_receptive_at; et. }
        apply plus_one. econs; eauto.
        { eapply lift_determinate_at.
          { unsguard SETGT. ss. des_ifs. subst skenv_link_tgt; congruence. }
          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.
      unfold Genv.public_symbol in *. 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 Export ZArith.
Require Export ch2o.core_c.expressions.
Require Export ch2o.memory_separation.memory_singleton.
Require Export ch2o.separation.permissions.
Require Export ch2o.core_c.expressions.
Require Export ch2o.core_c.expression_eval.
Require Export ch2o.core_c.restricted_smallstep.
Require Export ch2o.core_c.expression_eval_smallstep.
Require Export ch2o.abstract_c.natural_type_environment.
Require Export ch2o.abstract_c.architecture_spec.
Require Export ch2o.abstract_c.architectures.

Definition is_final_state `{Env K} (S: state K) :=
  match S with
    State _ (Return _ _) _ => True
  | State _ (Undef _) _ => True
  | _ => False
  end.

Lemma mem_erase_free `{EnvSpec K} o (m: mem K):
  cmap_erase (mem_free o m) = cmap_erase (mem_free o (cmap_erase m)).
destruct m as [m].
unfold cmap_erase.
unfold mem_free.
assert (forall m1 m2, m1 = m2 -> (CMap m1: mem K) = CMap m2). intros; congruence.
apply H1.
apply map_eq.
intros.
rewrite lookup_omap.
rewrite lookup_omap.
destruct (decide (o = i)).
- subst.
  rewrite lookup_alter.
  rewrite lookup_alter.
  rewrite lookup_omap.
  destruct (m !! i).
  + destruct c; reflexivity.
  + reflexivity.
- rewrite lookup_alter_ne with (1:=n).
  rewrite lookup_alter_ne with (1:=n).
  rewrite lookup_omap.
  destruct (m !! i).
  + destruct c; reflexivity.
  + reflexivity.
Qed.

Definition A: architecture := {|
  arch_sizes := architectures.lp64;
  arch_big_endian := false;
  arch_char_signedness := Signed;
  arch_alloc_can_fail := false
|}.
Notation K := (arch_rank A).

Lemma mem_lock_cmap (Γ: env K) o (m: indexmap (cmap_elem K (pbit K))):
  mem_lock Γ (addr_top o sintT%BT) (CMap m) =
  CMap (alter (cmap_elem_map (ctree_map pbit_lock)) o m).
reflexivity.
Qed.

Lemma zip_with_pbit_unlock_if_list_fmap_pbit_lock (l: list (pbit K)):
  Forall (λ γb, Some Writable ⊆ pbit_kind γb) l ->
  zip_with pbit_unlock_if (pbit_lock <$> l) (replicate (Datatypes.length l) true) = l.
induction l; intros; try reflexivity.
simpl.
unfold fmap in IHl.
rewrite IHl.
- destruct a.
  simpl.
  inversion H; subst.
  destruct tagged_perm.
  + destruct l0; simpl in *.
    * unfold perm_kind in H2.
      elim H2.
    * reflexivity.
  + elim H2.
- inversion H; subst; assumption.
Qed.

Lemma mem_unlock_lock_singleton (Γ: env K) o (m: mem K):
  ✓{Γ} m ->
  (Γ, '{m}) ⊢ addr_top o sintT%BT : sintT%PT ->
  mem_writable Γ (addr_top o sintT%BT) m ->
  mem_unlock
    (lock_singleton Γ (addr_top o sintT%BT))
    (mem_lock Γ (addr_top o sintT%BT) m) = m.
destruct m as [m].
intros Hvalid. intros.
destruct Hvalid as [Hvalid1 [Hvalid2 Hvalid3]].
simpl in *.
assert (forall (m1: indexmap (cmap_elem K (pbit K))) m2, m1 = m2 -> CMap m1 = CMap m2). { intros; congruence. }
apply H1.
apply map_eq.
intro i.
rewrite lookup_merge.
2:reflexivity.
destruct (decide (i = o)).
- subst.
  rewrite lookup_singleton.
  rewrite lookup_alter.
  destruct H0 as [w [Hw H'w]].
  simpl in *.
  unfold cmap_lookup in Hw.
  simpl in Hw.
  case_eq (m !! o); intros; rewrite H0 in Hw; try discriminate.
  destruct c; try discriminate.
  simpl in Hw.
  injection Hw; clear Hw; intros; subst.
  simpl.
  unfold typed in H.
  unfold addr_typed in H.
  simpl in H.
  inversion H; clear H; subst.
  unfold typed in H8.
  unfold index_typed in H8.
  destruct H8 as [β Ho].
  rewrite lookup_fmap in Ho.
  rewrite H0 in Ho.
  simpl in Ho.
  injection Ho; clear Ho; intros; subst.
  destruct w; try discriminate.
  destruct b0; try discriminate.
  destruct i; try discriminate.
  simpl in H2.
  injection H2; clear H2; intros; subst.
  simpl.
  pose proof H0.
  apply Hvalid3 in H0.
  destruct H0 as [τ [Ho1 [Ho2 [Ho3 Ho4]]]].
  simpl in *.
  unfold typed in Ho1.
  unfold index_typed in Ho1.
  destruct Ho1 as [β Ho1].
  rewrite lookup_fmap in Ho1.
  rewrite H in Ho1.
  simpl in Ho1.
  injection Ho1; clear Ho1; intros; subst.
  simpl in Ho3.
  unfold typed in Ho3.
  unfold ctree_typed in Ho3.
  simpl in Ho3.
  inversion Ho3; subst.
  rewrite fmap_length.
  assert (Datatypes.length l = 32). {
    rewrite H5.
    reflexivity.
  }
  rewrite H0.
  assert (natmap.to_bools 32
              {|
              mapset.mapset_car := natmap.list_to_natmap
                                     [Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some ()] |} =
    [true; true; true; true; true; true; true; true;
     true; true; true; true; true; true; true; true;
     true; true; true; true; true; true; true; true;
     true; true; true; true; true; true; true; true]).
  reflexivity.
  rewrite H2.
  pose proof (zip_with_pbit_unlock_if_list_fmap_pbit_lock l H'w).
  rewrite H0 in H6.
  simpl in H6.
  rewrite H6.
  reflexivity.
- rewrite lookup_singleton_ne; try congruence.
  rewrite lookup_alter_ne; try congruence.
Qed.

Lemma lockset_union_right_id (Ω: lockset): Ω ∪ ∅ = Ω.
apply lockset_eq.
intros.
solve_elem_of.
Qed.

Lemma cons_snoc0 {A} x (xs: list A): exists y ys, x::xs = (ys ++ [y])%list.
revert x.
induction xs.
- intros.
  exists x.
  exists [].
  reflexivity.
- intros.
  destruct (IHxs a) as [y [ys Hyys]].
  rewrite Hyys.
  exists y.
  exists (x::ys).
  reflexivity.
Qed.

Lemma expr_eval_pure (Γ: env K) ρ e1 m e2 m2 (E: ectx K) ν:
  Γ\ ρ ⊢ₕ e1, m ⇒ e2, m2 ->
  ⟦ subst E e1 ⟧ Γ ρ m = Some ν ->
  m2 = m.
intros.
apply expr_eval_subst in H0.
destruct H0 as [ν' [Hν' _]].
apply symmetry.
apply ehstep_expr_eval_mem with (1:=H) (2:=Hν').
Qed.

Lemma expr_eval_complete_subst (Γ: env K) ρ e1 m e2 m2 (E: ectx K) ν:
  Γ\ ρ ⊢ₕ e1, m ⇒ e2, m2 ->
  ⟦ subst E e1 ⟧ Γ ρ m = Some ν ->
  ⟦ subst E e2 ⟧ Γ ρ m = Some ν.
intros.
pose proof H0.
apply expr_eval_subst in H0.
destruct H0 as [ν' [Hν' _]].
assert (m = m2). {
  apply ehstep_expr_eval_mem with (1:=H) (2:=Hν').
}
subst m2.
assert (⟦ e2 ⟧ Γ ρ m = Some ν'). {
  apply ehstep_expr_eval with (1:=H) (2:=Hν') (3:=Hν').
}
rewrite subst_preserves_expr_eval with (e4:=e2) in H1.
- assumption.
- congruence.
Qed.

Lemma expr_eval_call_None {Γ: env K} {ρ m} {E: ectx K} {f args ν}:
  ⟦ subst E (ECall f args) ⟧ Γ ρ m = Some ν -> False.
intros.
apply expr_eval_subst in H.
destruct H.
destruct H.
simpl in H.
discriminate.
Qed.

Lemma expr_eval_no_locks (Γ: env K) ρ m Ω ν ν':
  ⟦ %#{Ω} ν ⟧ Γ ρ m = Some ν' -> (%#{Ω} ν = %# ν')%E.
intros.
simpl in H.
unfold mguard in H.
unfold option_guard in H.
destruct (lockset_eq_dec Ω ∅); congruence.
Qed.

Lemma assign_pure (Γ: env K) δ ρ S0 S:
  Γ\ δ\ ρ ⊢ₛ S0 ⇒* S ->
  is_final_state S ->
  forall k el er m νl νr,
  S0 = State k (Expr (el ::= er)) m ->
  ⟦ el ⟧ Γ (rlocals ρ k) m = Some νl ->
  ⟦ er ⟧ Γ (rlocals ρ k) m = Some νr ->
  Γ\ δ\ ρ ⊢ₛ State k (Expr (%# νl ::= %# νr)) m ⇒* S.
induction 1; intros; subst. {
  elim H.
}
inversion H; clear H; subst.
- (* head reduction *)
  destruct E.
  + (* empty evaluation context *)
    simpl in *.
    subst.
    inversion H8; subst.
    simpl in *.
    unfold mguard in H4.
    unfold option_guard in H4.
    case_eq (lockset_eq_dec Ω2 ∅); intros.
    * rewrite H in H4.
      injection H4; clear H4; intros; subst.
      unfold mguard in H3; unfold option_guard in H3.
      case_eq (lockset_eq_dec Ω1 ∅); intros.
      -- rewrite H2 in H3.
         injection H3; clear H3; intros; subst.
         clear H H2.
         eapply rtc_l.
         ++ eapply rcstep_expr_head with (E:=[]).
            eassumption.
         ++ eassumption.
      -- rewrite H2 in H3; discriminate.
    * rewrite H in H4; discriminate.
  + (* nonempty evaluation context *)
    destruct (cons_snoc0 e E) as [e' [E' H']].
    rewrite H' in *.
    clear H' e E.
    rewrite subst_snoc in H6.
    destruct e'; try discriminate.
    * (* lhs *)
      simpl in H6.
      injection H6; clear H6; intros; subst.
      rewrite subst_snoc in H0.
      rewrite subst_snoc in IHrtc.
      simpl in *.
      assert (m2 = m). {
        apply expr_eval_pure with (1:=H8) (2:=H3).
      }
      subst m2.
      apply expr_eval_complete_subst with (1:=H8) in H3.
      apply IHrtc with (3:=H3) (4:=H4); trivial.
    * (* rhs *)
      simpl in *.
      injection H6; clear H6; intros; subst.
      rewrite subst_snoc in H0.
      rewrite subst_snoc in IHrtc.
      simpl in *.
      assert (m2 = m). {
        apply expr_eval_pure with (1:=H8) (2:=H4).
      }
      subst m2.
      apply expr_eval_complete_subst with (1:=H8) in H4.
      apply IHrtc with (3:=H3) (4:=H4); trivial.
- (* function call *)
  destruct E.
  + (* E = [] *)
    simpl in *.
    discriminate.
  + destruct (cons_snoc0 e0 E) as [e' [E' H']].
    rewrite H' in *.
    clear H' e0 E.
    rewrite subst_snoc in H6.
    destruct e'; try discriminate; simpl in *; injection H6; clear H6; intros; subst.
    * (* lhs *)
      elim (expr_eval_call_None H3).
    * (* rhs *)
      elim (expr_eval_call_None H4).
- (* undef *)
  destruct E.
  * (* E = [] *)
    simpl in *.
    subst.
    eapply rtc_l.
    2: eassumption.
    inversion H8; subst.
    destruct H5.
    destruct H7.
    rewrite expr_eval_no_locks with (1:=H3) in *.
    rewrite expr_eval_no_locks with (1:=H4) in *.
    apply rcstep_expr_undef with (E:=[]).
    -- assumption.
    -- assumption.
  * (* E <> [] *)
    destruct (cons_snoc0 e0 E) as [e' [E' H']].
    rewrite H' in *.
    clear H' e0 E.
    rewrite subst_snoc in H5.
    destruct e'; try discriminate; simpl in *; injection H5; clear H5; intros; subst.
    -- (* lhs *)
       destruct expr_eval_subst_ehstep with (1:=H3) (2:=H8).
       destruct H.
       elim H9.
       eapply ehsafe_step.
       apply H.
    -- (* rhs *)
       destruct expr_eval_subst_ehstep with (1:=H4) (2:=H8).
       destruct H.
       elim H9.
       eapply ehsafe_step.
       apply H.
Qed.

Lemma assign_pure' (Γ: env K) δ ρ S k el er m νl νr P:
  Γ\ δ\ ρ ⊢ₛ (State k (Expr (el ::= er)) m) ⇒* S ->
  is_final_state S ->
  ⟦ el ⟧ Γ (rlocals ρ k) m = Some νl ->
  ⟦ er ⟧ Γ (rlocals ρ k) m = Some νr ->
  (Γ\ δ\ ρ ⊢ₛ State k (Expr (%# νl ::= %# νr)) m ⇒* S ->
   P) ->
  P.
intros.
apply X.
apply assign_pure with (1:=H) (2:=H0) (4:=H1) (5:=H2).
reflexivity.
Qed.

Lemma Expr_pure (Γ: env K) δ ρ S0 S:
  Γ\ δ\ ρ ⊢ₛ S0 ⇒* S ->
  is_final_state S ->
  forall k e m ν,
  S0 = State k (Expr e) m ->
  ⟦ e ⟧ Γ (rlocals ρ k) m = Some ν ->
  Γ\ δ\ ρ ⊢ₛ State k (Expr (%# ν)) m ⇒* S.
intro Hrtc.
pose proof Hrtc.
induction H; intros; subst. {
  elim H.
}
assert (forall Ω ν', e = (%#{Ω} ν')%E -> Γ\ δ\ ρ ⊢ₛ State k (Expr (%# ν)) m ⇒* z). {
  intros.
  subst.
  simpl in H3.
  unfold mguard in H3.
  unfold option_guard in H3.
  destruct (lockset_eq_dec Ω ∅).
  2: discriminate.
  injection H3; clear H3; intros; subst.
  assumption.
}
clear Hrtc.
inversion H; clear H; subst; try (eapply H2; reflexivity); clear H2.
- (* head reduction *)
  assert (m2 = m). {
    apply expr_eval_pure with (1:=H8) (2:=H3).
  }
  subst m2.
  eapply IHrtc; try trivial.
  apply expr_eval_complete_subst with (1:=H8) (2:=H3).
- (* function call *)
  elim (expr_eval_call_None H3).
- elim H9.
  eapply expr_eval_subst_ehsafe; eassumption.
Qed.

Lemma Expr_pure' (Γ: env K) δ ρ S k e m ν:
  Γ\ δ\ ρ ⊢ₛ (State k (Expr e) m) ⇒* S ->
  is_final_state S ->
  ⟦ e ⟧ Γ (rlocals ρ k) m = Some ν ->
  Γ\ δ\ ρ ⊢ₛ State k (Expr (%# ν)) m ⇒* S.
intros.
apply Expr_pure with (1:=H) (2:=H0) (4:=H1).
reflexivity.
Qed.

Lemma Hint_coding: arch_int_coding A = (@int_coding
                               (arch_rank A)
                               (@env_type_env
                                  (arch_rank A)
                                  (arch_env A))).
reflexivity.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*             The Quantitative CompCert verified compiler             *)
(*                                                                     *)
(*                 Tahina Ramananandro, Yale University                *)
(*                                                                     *)
(*  This file is a modified version of the                             *)
(*  CompCert 1.13 verified compiler by Xavier Leroy, INRIA.            *)
(*  The CompCert verified compiler is                                  *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  The original file is           *)
(*  distributed                                                        *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*  According to this license, this modified version is distributed    *)
(*  under a similar license (see LICENSE for details).                 *)
(*                                                                     *)
(* *********************************************************************)

(** Corollaries of the main semantic preservation theorem. *)

Require Import Classical.
Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Behaviors.
Require Import Csyntax.
Require Import Csem.
Require Import Cstrategy.
Require Import Clight.
Require Import Cminor.
Require Import RTL.
Require Import Asm.
Require Import Compiler.
Require Import Errors.
Require Import Prune.
Require Import Memdata.

(** We assume that the available stack size [bound] of the process in
    the target machine is machine-representable, and that the stack is
    strongly aligned. *)

Section WITHBOUNDS.
Context
  (bound : Integers.Int.int)
  (Hbound: (Stacklayout.strong_align
       | Integers.Int.unsigned bound + size_chunk Mint32))
  (external_event_needs: Events.event -> Z)
  (p: Csyntax.program) (tp: Asm.program)
  (H: transf_c_program p = OK tp)
.

(** * Preservation of whole-program behaviors *)

(** From the simulation diagrams proved in file [Compiler]. it follows that
  whole-program observable behaviors are preserved in the following sense.
  First, every behavior of the generated assembly code is matched by
  a behavior of the source C code. *)

Section CSTRATEGY.

(** If we consider the C evaluation strategy implemented by the
  compiler, we get stronger preservation results: the behaviors are
  exactly preserved. *)

Lemma prune_atomic_behaves_intro:
  forall beh, program_behaves (prune_semantics (Cstrategy.semantics p)) beh ->
              program_behaves (prune_semantics (atomic (Cstrategy.semantics p))) beh.
Proof.
  intros.
  destruct (prune_program_behaves _ _ H0).
  destruct H1.
  apply atomic_behaviors in H2.
  eapply program_behaves_prune.
  eassumption.
  assumption.
  intros. eapply ssr_well_behaved. apply Cstrategy.semantics_strongly_receptive.
Qed.

Lemma prune_atomic_behaves_elim:
  forall beh, program_behaves (prune_semantics (atomic (Cstrategy.semantics p))) beh ->
              program_behaves (prune_semantics (Cstrategy.semantics p)) beh.
Proof.
  intros.
  destruct (prune_program_behaves _ _ H0).
  destruct H1.
  apply atomic_behaviors in H2.
  eapply program_behaves_prune.
  eassumption.
  assumption.
  intros. eapply ssr_well_behaved. apply Cstrategy.semantics_strongly_receptive.
Qed.

(** We assume that:

    - the [Cstrategy] source program is proved not to go wrong

    - the traces of the source program do not "stack overflow". Let us
      explain this in more detail.  To compute the weights
      (cf. Section 3.1 of our PLDI 2014 paper) of the traces of the so
      program, we instantiate the stack metric with the sizes of the
      stack frames obtained in [Mach] and adjusted by the
      [Mach]-to-[Mach2] pass ([Mach2Mach2.stacksizes]). Then, the
      condition [NO_OVERFLOW] below imposes that those weights must
      not exceed [bound].
 *)

Variables
  (NOT_STUCK: not_stuck (prune_semantics (atomic (Cstrategy.semantics p))))
  (NO_OVERFLOW: no_overflow_with_mach bound external_event_needs (fun p' => atomic (Cstrategy.semantics p')) transf_c_to_mach p)
.

(** Under these conditions, the target [Asm] program is guaranteed to
    refine the [Cstrategy] source program -- and more precisely, the
    *pruned* behaviors (without call/return events) are exactly
    preserved.  In particular, the [Asm] program is guaranteed to not
    go wrong at all, and in particular, is guaranteed to not stack
    overflow.

    As explained in Section 3.2, it is important that the source
    program be proved to not go wrong in the unbounded-stack setting
    (condition [NOT_STUCK]. Indeed, our transformation uses the
    [Compiler.transf_mach_program_correct_strong] theorem, which
    depends on *all* traces of the [Mach] program obtained during the
    compilation of a source. If the source program were to have a
    wrong behavior [Goes_wrong t], then the compiled [Mach] program
    would well have a behavior [behavior_app t b] whose weight could
    well exceed [bound], thus violating the [NO_OVERFLOW] condition of
    that theorem. As each pass is proved independently of the others,
    it is not possible to track those behaviors of the [Mach] program
    that correspond to [Goes_wrong] behaviors of the source.
 *)

Theorem transf_cstrategy_program_preservation:
  (forall beh, program_behaves (prune_semantics (Cstrategy.semantics p)) beh <->
               program_behaves (Asm.semantics bound tp) beh).
Proof.
  split.
  intros.
  eapply forward_simulation_same_safe_behavior.
  eapply transf_cstrategy_program_correct.
  assumption.
  eassumption.
  eassumption.
  assumption.
  apply prune_atomic_behaves_intro.
  assumption.
  apply NOT_STUCK.
  apply prune_atomic_behaves_intro.
  assumption.
 intro.
 apply prune_atomic_behaves_elim.
 eapply backward_simulation_same_safe_behavior.
 eapply transf_cstrategy_program_correct.
 eassumption.
 assumption.
 eassumption.
 eassumption.
 assumption.
 assumption.
Qed.

End CSTRATEGY.

(** Similarly, if we assume that:

    - the [Csem] source program is proved not to go wrong

    - the traces of the source program do not "stack overflow". Let us
      explain this in more detail.  To compute the weights
      (cf. Section 3.1 of our PLDI 2014 paper) of the traces of the so
      program, we instantiate the stack metric with the sizes of the
      stack frames obtained in [Mach] and adjusted by the
      [Mach]-to-[Mach2] pass ([Mach2Mach2.stacksizes]). Then, the
      condition [NO_OVERFLOW] below imposes that those weights must
      not exceed [bound].
 *)

Variables
  (NOT_STUCK: not_stuck (prune_semantics  (Csem.semantics p)))
  (NO_OVERFLOW: no_overflow_with_mach bound external_event_needs (Csem.semantics) transf_c_to_mach p)
.

(** Then, under these conditions, the target [Asm] program is
    guaranteed to refine the [Csem] source program. In particular, the
    [Asm] program is guaranteed to not go wrong at all, and in
    particular, is guaranteed to not stack overflow.

    However, the [Asm] program may well have lost some behaviors of
    the [Csem] program, because all internal non-determinism of [Csem]
    (e.g. argument evaluation order) have been solved by
    [Cstrategy]. So we only have refinement, not exact behavior
    preservation. This is CompCert-specific, nothing to do with stack
    consumption.
*)

Theorem transf_c_program_preservation:
  forall beh,
  program_behaves (Asm.semantics bound tp) beh ->
  program_behaves (prune_semantics (Csem.semantics p)) beh.
Proof.
  intros. eapply backward_simulation_same_safe_behavior; eauto.
  eapply transf_c_program_correct; eauto.
Qed.

(** * Satisfaction of specifications *)

(** The second additional results shows that if all executions
  of the source C program satisfies a given specification
  (a predicate on the observable behavior of the program),
  then all executions of the produced Asm program satisfy
  this specification as well.
 *)

Section SPECS_PRESERVED.

Variable spec: program_behavior -> Prop.

Theorem transf_c_program_preserves_spec:
  (forall beh, program_behaves (prune_semantics (Csem.semantics p)) beh -> spec beh) ->
  (forall beh, program_behaves (Asm.semantics bound tp) beh -> spec beh).
Proof.
  intros; eauto using transf_c_program_preservation.
Qed.

End SPECS_PRESERVED.

End WITHBOUNDS.


From hahn Require Import Hahn.
From PromisingLib Require Import Loc.
Require Import Events.
Require Import Execution.
Require Import imm_s_hb.
Require Import imm_s.
Require Import CombRelations.
Require Import IfThen.

Set Implicit Arguments.

Section CombRelationsMore.

Variable G : execution.
Variable WF : Wf G.
Variable sc : relation actid.
Variable Wf_sc : wf_sc G sc.

Notation "'co'" := (co G).
Notation "'sw'" := (sw G).
Notation "'hb'" := (hb G).
Notation "'sb'" := (sb G).
Notation "'rf'" := (rf G).
Notation "'rfi'" := (rfi G).
Notation "'rfe'" := (rfe G).
Notation "'rmw'" := (rmw G).
Notation "'lab'" := (lab G).
Notation "'release'" := (release G).

Notation "'Init'" := (fun a => is_true (is_init a)).
Notation "'E'" := (acts_set G).
Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'W_ex'" := (W_ex G).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1).
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'W_' l" := (W ∩₁ Loc_ l) (at level 1).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Lemma urr_n_f_alt_union_eqv l A r thread
  (SB : dom_rel (sb ⨾ ⦗ eq r ⦘) ⊆₁ A)
  (NF : ~ F r)
  (TID : tid r = thread):
  c_cur G sc thread l (A ∪₁ eq r)
      ≡
  urr G sc l ⨾ ⦗A⦘ ⨾ (sb ⨾ ⦗eq r⦘)^? ⨾ ⦗ Tid_ thread ∪₁ Init ⦘ ∪
  ⦗ W_ l ⦘ ⨾ ⦗eq r⦘ ∪
  ⦗ Loc_ l ⦘ ⨾ rf ⨾ ⦗eq r⦘ ∪
  (msg_rel G sc l ∪ ⦗ Loc_ l ⦘) ⨾
    rf ⨾ ⦗ Acq ⦘ ⨾ ⦗eq r⦘.
Proof using WF Wf_sc.
rewrite c_cur_union.
unfold c_cur; split.
- unionL; [basic_solver 21|].
  arewrite (⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗eq r⦘ ⊆ ⦗ set_compl F ⦘ ⨾ ⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗eq r⦘).
  by basic_solver 21.
  sin_rewrite (urr_non_f WF).
  relsf; unionL.
  * arewrite (⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗eq r⦘ ⊆ ⦗eq r⦘ ⨾ ⦗Tid_ thread ∪₁ Init⦘) by basic_solver.
    unionR left -> left -> left.
    hahn_frame; revert SB; basic_solver.
  * basic_solver 21.
  * basic_solver 21.
  * done.
- unionL.
  * case_refl (sb ⨾ ⦗eq r⦘).
    by basic_solver 21.
    arewrite_id ⦗A⦘; rels.
    arewrite (sb ⊆ hb^?).
    sin_rewrite urr_hb; basic_solver 12.
  * by unfold urr; basic_solver 21.
  * by unfold urr; rewrite (dom_l (wf_rfD WF)) at 1; basic_solver 21.
  * relsf; unionL.
    by sin_rewrite (msg_rel_urr WF); basic_solver 12.
    unfold urr; rewrite (dom_l (wf_rfD WF)) at 1; basic_solver 21.
Qed.

Lemma urr_w_alt_union_eqv l A w thread
  (SB : dom_rel (sb ⨾ ⦗ eq w ⦘) ⊆₁ A)
  (WW : W w)
  (TID : tid w = thread):
  c_cur G sc thread l (A ∪₁ eq w)
      ≡
  urr G sc l ⨾ ⦗A⦘ ⨾ (sb ⨾ ⦗eq w⦘)^? ⨾ ⦗ Tid_ thread ∪₁ Init ⦘ ∪
  ⦗ W_ l ⦘ ⨾ ⦗eq w⦘.
Proof using WF Wf_sc.
  rewrite urr_n_f_alt_union_eqv; auto.
  rewrite (dom_r (wf_rfD WF)); type_solver 21.
  type_solver 21.
Qed.

Lemma urr_acq_n_f_alt_union_eqv l A r thread
  (SB : dom_rel (sb ⨾ ⦗eq r⦘) ⊆₁ A)
  (NF : ~ F r)
  (TID : tid r = thread) :
  c_acq G sc thread l (A ∪₁ eq r)
      ≡
  (urr G sc l ⨾ ⦗A⦘ ⨾ (sb ⨾ ⦗eq r⦘)^? ⨾ ⦗ Tid_ thread ∪₁ Init ⦘ ∪
   (msg_rel G sc l ⨾ rf ⨾ ⦗ Tid_ thread ∪₁ Init ⦘ ⨾ ⦗A⦘)) ∪
  ⦗ W_ l ⦘ ⨾ ⦗eq r⦘ ∪
  ⦗ Loc_ l ⦘ ⨾ rf ⨾ ⦗eq r⦘ ∪
  (msg_rel G sc l ∪ ⦗Loc_ l⦘) ⨾ rf ⨾ ⦗eq r⦘.
Proof using WF Wf_sc.
  unfold c_acq; rewrite crE at 1.
  rewrite seq_union_l; rewrite seq_union_r; rewrite seq_id_l.
  arewrite (urr G sc l ⨾ ⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗A ∪₁ eq r⦘ ≡
            c_cur G sc thread l (A ∪₁ eq r)).
  rewrite (id_union A); rewrite (unionC ⦗A⦘).
  rewrite !seq_union_r.
  arewrite (⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗eq r⦘ ≡ ⦗eq r⦘) by basic_solver.
  rewrite urr_n_f_alt_union_eqv; eauto.
  unfold msg_rel.
  basic_solver 21.
Qed.

Lemma urr_rel_n_f_alt_union_eqv l l' A w thread
  (SB : dom_rel (sb ⨾ ⦗eq w⦘) ⊆₁ A)
  (WW : W w)
  (TID : tid w = thread):
  c_rel G sc thread l l' (A ∪₁ eq w) ≡
  c_rel G sc thread l l' A ∪ ⦗Rel⦘ ⨾ ⦗Loc_ l⦘ ⨾ ⦗Loc_ l'⦘ ⨾ ⦗eq w⦘ ∪
  urr G sc l ⨾ ⦗A⦘ ⨾ sb ⨾ ⦗Rel⦘ ⨾ ⦗Loc_ l'⦘ ⨾ ⦗eq w⦘.
Proof using WF Wf_sc.
unfold c_rel.
split.
- rewrite (id_union A) at 1; relsf.
  unionL.
  * basic_solver 21.
  * arewrite (⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗eq w⦘ ⊆ ⦗ set_compl F ⦘ ⨾ ⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗eq w⦘).
    by type_solver 21.
    arewrite (⦗Rel⦘ ⨾ ⦗W ∩₁ Loc_ l' ∪₁ F⦘ ⨾ ⦗set_compl F⦘ ⊆ ⦗set_compl F⦘  ⨾ ⦗Rel⦘ ⨾ ⦗W ∩₁ Loc_ l' ∪₁ F⦘).
    by type_solver 21.
    sin_rewrite (urr_non_f WF).
    relsf; unionL.
    + unionR right; revert SB; type_solver 21.
    + unionR left -> right; rewrite (dom_r (wf_rfD WF)); type_solver 21.
    + rewrite (dom_r (wf_rfD WF)); type_solver 21.
    + done.
- unionL.
  * basic_solver.
  * unfold urr; basic_solver 21.
  * arewrite_id ⦗A⦘; rels.
    arewrite (sb ⊆ hb^?).
    sin_rewrite urr_hb; basic_solver.
Qed.

(*
Lemma dom_rel_sb_clos B A r thread
    (SB : dom_rel (sb ⨾ ⦗ eq r ⦘) ⊆₁ A) :
    dom_rel (B ⨾ ⦗A⦘ ⨾ (sb ⨾ ⦗eq r⦘)^? ⨾ ⦗Tid_ thread ∪₁ Init⦘) ≡₁
    dom_rel (B ⨾ ⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗A⦘).
Proof using.
split.
rewrite (@no_sb_to_init G); generalize (@sb_tid_init G); basic_solver 20.
revert SB; basic_solver 20.
Qed.
*)

Lemma dom_rel_r l locr thread w r
  (LOC : loc lab r = Some locr)
  (RF : rf w r)
  (TID : tid r = thread) :
    (dom_rel
       (⦗Loc_ l⦘ ⨾ rf ⨾ ⦗eq r⦘) ≡₁
       if LocSet.Facts.eq_dec l locr then eq w else ∅).
Proof using WF.
split.
- unfolder; ins; desf.
  generalize (wf_rff WF); basic_solver.
  apply n; eauto.
  generalize (((wf_rfl WF) x y) H0); unfold same_loc; ins; congruence.
- assert (loc lab w = Some locr).
  by generalize (((wf_rfl WF) w r) RF); unfold same_loc; ins; congruence.
  desf; basic_solver 21.
Qed.

Lemma t_cur_urr_union_eqv l A thread r
  (SB : dom_rel (sb ⨾ ⦗eq r⦘) ⊆₁ A)
  (NF : ~ F r)
  (TID : tid r = thread) :
  t_cur G sc thread l (A ∪₁ eq r) ≡₁
  dom_rel (urr G sc l ⨾ ⦗Tid_ thread ∪₁ Init ⦘⨾ ⦗A⦘) ∪₁
  (W_ l ∩₁ eq r ∪₁
   dom_rel (⦗Loc_ l⦘ ⨾ rf ⨾ ⦗eq r⦘) ∪₁
   dom_rel
     ((msg_rel G sc l ∪ ⦗Loc_ l⦘)
      ⨾ rf ⨾ ⦗fun a : actid => Acq a⦘ ⨾ ⦗eq r⦘)).
Proof using WF Wf_sc.
  unfold t_cur.
  rewrite urr_n_f_alt_union_eqv; auto.
  rewrite (@no_sb_to_init G); generalize (@sb_tid_init G); basic_solver 20.
Qed.

Lemma t_cur_urr_union_eqv_w l A thread w
  (SB : dom_rel (sb ⨾ ⦗eq w⦘) ⊆₁ A)
  (WW : W w)
  (TID : tid w = thread) :
  t_cur G sc thread l (A ∪₁ eq w) ≡₁
  dom_rel (urr G sc l ⨾ ⦗Tid_ thread ∪₁ Init ⦘⨾ ⦗A⦘) ∪₁
  Loc_ l ∩₁ eq w.
Proof using WF Wf_sc.
  rewrite t_cur_urr_union_eqv; auto.
  2: by intros H; type_solver.
  split; [|basic_solver 10].
  arewrite_id ⦗ Acq ⦘; rewrite seq_id_l.
  arewrite (rf ⨾ ⦗ eq w ⦘ ⊆ ∅₂).
  2: basic_solver 10.
  rewrite (dom_r (wf_rfD WF)).
  type_solver.
Qed.

Lemma t_acq_urr_union_eqv l A thread r
  (SB : dom_rel (sb ⨾ ⦗ eq r ⦘) ⊆₁ A)
  (NF : ~ F r)
  (TID : tid r = thread) :
  t_acq G sc thread l (A ∪₁ eq r) ≡₁
  t_acq G sc thread l A ∪₁
  (W_ l ∩₁ eq r ∪₁
   dom_rel (⦗Loc_ l⦘ ⨾ rf ⨾ ⦗eq r⦘) ∪₁
   dom_rel ((msg_rel G sc l ∪ ⦗Loc_ l⦘) ⨾ rf ⨾ ⦗eq r⦘)).
Proof using WF Wf_sc.
  unfold t_acq.
  rewrite urr_acq_n_f_alt_union_eqv; eauto.
  unfold c_acq.
  unfold msg_rel.
  rewrite (@no_sb_to_init G); generalize (@sb_tid_init G); basic_solver 20.
Qed.

Lemma t_rel_union_eqv l l' A thread r
  (SB : dom_rel (sb ⨾ ⦗ eq r ⦘) ⊆₁ A)
  (RR : R r)
  (TID : tid r = thread) :
  t_rel G sc thread l l' (A ∪₁ eq r) ≡₁ t_rel G sc thread l l' A.
Proof using.
  unfold t_rel, c_rel.
  rewrite (id_union A); rewrite !seq_union_r.
  arewrite (⦗W_ l' ∪₁ F⦘ ⨾ ⦗Tid_ thread ∪₁ Init⦘ ⨾ ⦗eq r⦘ ≡ ∅₂); rels.
  type_solver 21.
Qed.

Lemma t_rel_w_union_eqv l l0 A thread w locw
  (NINIT : ~ is_init w)
  (CCLOS : doma (sb ⨾ ⦗ A ⦘) A)
  (AACTS : A ⊆₁ E)
  (NINA  : ~ A w)
  (SB : doma (sb ⨾ ⦗eq w⦘) A)
  (ACTS: E w)
  (WW : W w)
  (LOC : loc lab w = Some locw)
  (TID : tid w = thread)
  (FREFL : forall l y (Ws : W y) (LOC : loc lab y = Some l), urr G sc l y y)
  (CREL : forall l l',
    c_rel G sc thread l l' (A ∪₁ eq w)
        ≡
    c_rel G sc thread l l' A ∪
    ⦗fun _ => l' = l⦘ ⨾
    ⦗Rel⦘ ⨾ ⦗Loc_ l'⦘ ⨾ ⦗eq w⦘ ∪
    urr G sc l ⨾ ⦗A⦘ ⨾ sb ⨾ ⦗ Rel ⦘ ⨾ ⦗Loc_ l'⦘ ⨾ ⦗eq w⦘)
  :
  t_rel G sc thread l0 l (A ∪₁ eq w) ∪₁
  (if Loc.eq_dec l0 l
   then W ∩₁ Loc_ l ∩₁ Tid_ thread ∩₁ (A ∪₁ eq w)
   else ∅)
    ≡₁
  if Loc.eq_dec l locw
  then (if (is_rel lab w)
        then t_cur G sc thread l0 A
        else t_rel G sc thread l0 l A ∪₁
             (if Loc.eq_dec l0 l
              then W ∩₁ Loc_ l ∩₁ Tid_ thread ∩₁ A
              else ∅)) ∪₁
       (if Loc.eq_dec l0 locw then eq w else ∅)
  else
    t_rel G sc thread l0 l A ∪₁
    (if Loc.eq_dec l0 l
     then W ∩₁ Loc_ l ∩₁ Tid_ thread ∩₁ A
     else ∅).
Proof using WF.
  rewrite !ite_alt; rewrite !iteb_alt; rewrite !ite_alt.
  rewrite !set_inter_union_r.
  rewrite ite_union_t.
  unfold t_rel at 1; rewrite CREL; auto.
  arewrite (W ∩₁ Loc_ l ∩₁ Tid_ thread ∩₁ eq w ≡₁ Loc_ l ∩₁ eq w) by basic_solver 12.
  assert (forall l,
          dom_rel (urr G sc l ⨾ ⦗A⦘ ⨾ sb ⨾ ⦗eq w⦘) ≡₁
          dom_rel (c_cur G sc (tid w) l A)) as CSB.
  { intros; unfold c_cur.
    split; intros x H; destruct H as [y H].
    all: hahn_rewrite <- seqA in H.
    hahn_rewrite <- seqA in H.
    all: apply seq_eqv_r in H; destruct H as [H X]; subst.
    { destruct H as [z [H PSB]].
      apply seq_eqv_r in H; desf.
      exists z; hahn_rewrite <- seqA; apply seq_eqv_r; split; auto.
      apply seq_eqv_r; split; auto.
      eapply sb_tid_init; eauto. }
    apply seq_eqv_r in H; desc.
    exists w; hahn_rewrite <- seqA; hahn_rewrite <- seqA.
    apply seq_eqv_r; split; auto.
    exists y; split.
    by basic_solver.
    destruct (classic (is_init y)) as [IN|NIN].
    { apply init_ninit_sb; auto. }
    destruct (same_thread G y w) as [[ST|ST]|ST]; desf.
    { by apply AACTS. }
    revert H0; basic_solver.
    exfalso; revert CCLOS; basic_solver. }
  assert (forall l' l'',
          dom_rel (c_rel G sc (tid w) l' l'' A) ∪₁
          dom_rel (c_cur G sc (tid w) l' A) ≡₁
          dom_rel (c_cur G sc (tid w) l' A)) as CURREL.
  by unfold c_rel, c_cur; basic_solver 12.

  destruct (classic (l = locw)) eqn:LL1; subst.
  { rewrite <- !ite_alt; rewrite !Loc.eq_dec_eq.
    rename locw into l.
    rewrite !ite_alt.
    arewrite (⦗Loc_ l⦘ ⨾ ⦗eq w⦘ ≡ ⦗eq w⦘) by basic_solver.
    rewrite !dom_union.
    destruct (classic (l0 = l)) eqn:LL2; subst.
    { rewrite <- !ite_alt; rewrite !Loc.eq_dec_eq.
      arewrite (⦗fun _ : actid => l = l⦘ ≡ ⦗fun _ : actid => True⦘).
      { split; intros x y H; red; red in H; split; desf. }
      rewrite seq_id_l.
      rewrite (fun x => set_unionC x (dom_rel (⦗Rel⦘ ⨾ ⦗eq w⦘))).
      rewrite !set_unionA; rewrite set_unionC.
      rewrite !set_unionA.
      arewrite (Loc_ l ∩₁ eq w ≡₁ eq w) by basic_solver.
      arewrite (eq w ∪₁ dom_rel (⦗fun a : actid => Rel a⦘ ⨾ ⦗eq w⦘) ≡₁ eq w) by basic_solver.
      rewrite <- !set_unionA.
      repeat (apply set_equiv_union; [|done]).
      rewrite <- iteb_alt.
      destruct (is_rel lab w) eqn:RELEQ.
      { arewrite (⦗Rel⦘ ⨾ ⦗eq w⦘ ≡ ⦗eq w⦘).
        { by apply seq_eqvK_l; ins; subst. }
        unfold t_cur.
        rewrite CSB; rewrite CURREL.
        split; intros x H; [|by left]; destruct H; desf.
        unfold c_cur.
        revert H; basic_solver 21. }
      arewrite (⦗fun a : actid => Rel a⦘ ⨾ ⦗eq w⦘ ≡ ∅₂) by basic_solver.
        by rels. }
    rewrite <- !ite_alt.
    rewrite !Loc.eq_dec_neq; auto.
    arewrite (⦗fun _ : actid => l = l0⦘ ≡ ∅₂).
    { split; rels; intros x y H; inv H. }
    rels.
    rewrite <- iteb_alt; destruct (is_rel lab w) eqn: REL.
    { arewrite (⦗Rel⦘ ⨾ ⦗eq w⦘ ≡ ⦗eq w⦘).
      { by apply seq_eqvK_l; ins; subst. }
      by rewrite CSB; rewrite CURREL. }
    arewrite (⦗Rel⦘ ⨾ ⦗eq w⦘ ≡ ∅₂).
    { split; rels; intros x y H; apply seq_eqv_r in H; desf; red in H; desf. }
    by rels. }
  rewrite <- !ite_alt; rewrite (@Loc.eq_dec_neq _ l locw); auto.
  rewrite !ite_alt.
  rewrite <- !id_inter.
  arewrite (Loc_ l ∩₁ eq w ≡₁ ∅) by basic_solver.
  unfold ifthenelse, t_rel; basic_solver 21.
Qed.

Lemma t_cur_urr_init
      wi (C : actid -> Prop) l thread
      (INC : C wi) (INIT : is_init wi) (LOC : Loc_ l wi):
  t_cur G sc thread l C wi.
Proof using WF.
unfold t_cur, c_cur, urr.
generalize (init_w WF); unfold seq; basic_solver 42.
Qed.

Lemma urr_refl l y (YW : W y) (LOC : loc lab y = Some l):
  urr G sc l y y.
Proof using.
unfold urr.
basic_solver 21.
Qed.

Lemma t_rel_if_other_thread
      C C' thread l l'
      (CINIT : Init ∩₁ E ⊆₁ C)
      (CINCL : C ⊆₁ C')
      (CE : C' ⊆₁ E)
      (COVSTEP : forall a, tid a = thread -> C' a -> C a) :
  (t_rel G sc thread l l' C' ∪₁
   (if LocSet.Facts.eq_dec l l'
    then
      W ∩₁ Loc_ l' ∩₁ Tid_ thread ∩₁ C'
    else ∅)) ≡₁
  (t_rel G sc thread l l' C ∪₁
   (if LocSet.Facts.eq_dec l l'
    then
      W ∩₁ Loc_ l' ∩₁ Tid_ thread ∩₁ C
    else ∅)).
Proof using.
  apply set_equiv_union; [by symmetry; apply t_rel_other_thread|].
  desf; basic_solver 21.
Qed.

Lemma s_tm_n_f_steps
      C C' l
      (CINIT : Init ∩₁ E ⊆₁ C)
      (CINCL : C ⊆₁ C')
      (COVSTEP : forall a, C' a -> ~ C a -> ~ (F∩₁Sc) a) :
  S_tm G l C' ≡₁ S_tm G l C.
Proof using.
  unfold S_tm, S_tmr.
  arewrite (⦗F∩₁Sc⦘ ⨾ ⦗C'⦘ ≡ ⦗F∩₁Sc⦘ ⨾ ⦗C⦘); [|done].
  split; [|by rewrite CINCL].
  unfolder; ins; desf.
  destruct (classic (C y)) as [H|H]; auto.
  exfalso; eapply COVSTEP; basic_solver.
Qed.

End CombRelationsMore.


(**
 Verified SAR-BP: A verified C implementation of SAR backprojection
 with a certified absolute error bound.

 Version 1.0 (2015-12-04)

 Copyright (C) 2015 Reservoir Labs Inc.
 All rights reserved.

 This file is free software. You can redistribute it and/or modify it
 under the terms of the GNU General Public License as published by the
 Free Software Foundation, either version 3 of the License (GNU GPL
 v3), or (at your option) any later version.  A verbatim copy of the
 GNU GPL v3 is included in gpl-3.0.txt.

 This file is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See LICENSE for
 more details about the use and redistribution of this file and the
 whole Verified SAR-BP library.

 This work is sponsored in part by DARPA MTO as part of the Power
 Efficiency Revolution for Embedded Computing Technologies (PERFECT)
 program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The
 views and conclusions contained in this work are those of the authors
 and should not be interpreted as representing the official policies,
 either expressly or implied, of the DARPA or the
 U.S. Government. Distribution Statement "A" (Approved for Public
 Release, Distribution Unlimited.)

 If you are using or modifying Verified SAR-BP in your work, please
 consider citing the following paper:

 Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard
 Lethin.
 A Unified Coq Framework for Verifying C Programs with Floating-Point
 Computations.
 In CPP (5th ACM/SIGPLAN conference on Certified Programs and Proofs)
 2016.

 Verified SAR-BP derives from prior work listed in ACKS along with
 their copyright and licensing information.

 Verified SAR-BP requires third-party libraries listed in ACKS along
 with their copyright information.
*)
(**
Author: Tahina Ramananandro <ramananandro@reservoir.com>

Verification of a C implementation of 3D L2 norm
(norm() in backprojection.c)
*)

Require Import RAux.
Require Import List.
Require Import SARBackProjSource.
Require Import compcert.Integers.
Require Import compcert.Floats.
Require Import compcert.AST.
Require Import compcert.Values.
Require Import compcert.Memory.
Require Import compcert.Events.
Require Import compcert.Globalenvs.
Require Import compcert.Smallstep.
Require Import compcert.Clight.
Require Import Flocq.Core.Fcore_generic_fmt.
Require Import Flocq.Appli.Fappli_IEEE.
Require Import Flocq.Prop.Fprop_relative.
Require Import Fprop_absolute.
Require Import Clight2FPOpt.
Require Import SepLogic.
Require Import ClightFacts.
Require Import ClightTac.
Require Import ClightSep2.
Open Scope R_scope.

Local Existing Instance Clight2FP.nans.

Definition f_sqrt_correct ge fr_sqrt :=
  type_of_fundef fr_sqrt =
  Ctypes.Tfunction
    (Ctypes.Tcons (Clightdefs.tptr Clightdefs.tdouble)
                  (Ctypes.Tcons Clightdefs.tdouble Ctypes.Tnil)) Clightdefs.tvoid
    cc_default /\
  forall x,
  is_finite _ _ x = true ->
  0 <= B2R _ _ x ->
  forall pr,
    perm_order pr Writable ->
    forall o,
    (align_chunk Mfloat64 | Int.unsigned o)%Z ->
    forall P b m,
      holds (P ++ Pperm b (Int.unsigned o) pr (size_chunk_nat Mfloat64)) m ->
      let s0 := (Callstate fr_sqrt
                           (Vptr b o :: Vfloat x :: nil)
                           Kstop
                           m) in
      exists m',
        star Clight.step2 ge
             s0
             E0
             (Returnstate Vundef
                          Kstop
                          m')
        /\
        exists y,
          holds (P ++ Pval Mfloat64 b (Int.unsigned o) pr (Vfloat y)) m' /\
          y = FPLang.Bsqrt FPLang.Tdouble x
.

Definition f_sqrt_correct' ge fr_sqrt :=
  type_of_fundef fr_sqrt =
  Ctypes.Tfunction
    (Ctypes.Tcons (Clightdefs.tptr Clightdefs.tdouble)
                  (Ctypes.Tcons Clightdefs.tdouble Ctypes.Tnil)) Clightdefs.tvoid
    cc_default /\
  forall x,
  is_finite _ _ x = true ->
  0 <= B2R _ _ x ->
  forall pr,
    perm_order pr Writable ->
    forall o,
    (align_chunk Mfloat64 | Int.unsigned o)%Z ->
    forall P b m,
      holds (P ++ Pperm b (Int.unsigned o) pr (size_chunk_nat Mfloat64)) m ->
      let s0 := (Callstate fr_sqrt
                           (Vptr b o :: Vfloat x :: nil)
                           Kstop
                           m) in
      exists m',
        star Clight.step2 ge
             s0
             E0
             (Returnstate Vundef
                          Kstop
                          m')
        /\
        exists y,
          holds (P ++ Pval Mfloat64 b (Int.unsigned o) pr (Vfloat y)) m' /\
          y = FPLang.fval
                (env_
                   (Maps.PTree.set xH (Vfloat x) (Maps.PTree.empty _))
                )
                (FPLang.Unop (FPLang.Rounded1 FPLang.SQRT None) (FPLang.Var FPLang.Tdouble xH))
.

Lemma f_sqrt_correct'_eq: f_sqrt_correct' = f_sqrt_correct.
Proof.
  reflexivity.
Qed.

Require Import SARBackProjSourceOpt1.

Definition f_norm2_correct BOUNDS :=
  let '(norm2_error, norm2_left, norm2_right) := BOUNDS
  in
  forall
    os
    ps

    m bs P
    (Hm:
       holds
         (P ++
            Pperm bs (Int.unsigned os) ps (size_chunk_nat Mfloat64)
         )
         m)

    (Hos_align: (align_chunk Mfloat64 | Int.unsigned os)%Z )
    (Hps: perm_order ps Writable)

   x'
   (Hx'_range: xdiff_left <= B2R _ _ x' <= xdiff_right )

   y'
   (Hy'_range: ydiff_left <= B2R _ _ y' <= ydiff_right )

   z'
   (Hz'_range: zdiff_left <= B2R _ _ z' <= zdiff_right )

   (Hx'_finite: is_finite _ _ x' = true)
   (Hy'_finite: is_finite _ _ y' = true)
   (Hz'_finite: is_finite _ _ z' = true)

  ge,

   exists v1 : val,
     eval_expr ge empty_env
                (Maps.PTree.set _z (Vfloat z')
                   (Maps.PTree.set _y (Vfloat y')
                      (Maps.PTree.set _x (Vfloat x')
                         (Maps.PTree.set _n (Vptr bs os)
                            (create_undef_temps (fn_temps f_norm)))))) m
       (Ebinop Oadd
          (Ebinop Oadd
             (Ebinop Omul (Etempvar _x tdouble) (Etempvar _x tdouble) tdouble)
             (Ebinop Omul (Etempvar _y tdouble) (Etempvar _y tdouble) tdouble)
             tdouble)
          (Ebinop Omul (Etempvar _z tdouble) (Etempvar _z tdouble) tdouble)
          tdouble) v1
     /\
     exists f,
       v1 = Vfloat f /\
       is_finite _ _ f = true /\
       norm2_left <= B2R _ _ f <= norm2_right /\
       Rabs (B2R _ _ f - (B2R _ _ x' * B2R _ _ x' + B2R _ _ y' * B2R _ _ y' + B2R _ _ z' * B2R _ _ z')) <= norm2_error.

Lemma f_norm2_body_correct' :
  { BOUNDS |
    f_norm2_correct BOUNDS }.
Proof.
  eexists (_, _, _).
  unfold f_norm2_correct.
  intros os ps m bs P Hm Hos_align.
  intros Hps x' Hx'_range y'.
  intros Hy'_range z' Hz'_range Hx'_finite Hy'_finite Hz'_finite ge.

  unfold xdiff_left, xdiff_right in Hx'_range.
  unfold ydiff_left, ydiff_right in Hy'_range.
  unfold zdiff_left, zdiff_right in Hz'_range.

  apply eval_expr_exists_filter_float.
  apply eval_expr_exists_filter_domain.
  apply Vfloat_exists.
  (* here comes the framework into play! *)
  Transparent Float.of_bits.
  Transparent Int64.repr.
  C_to_float_as r Hr.
  compute_fval_as Hr Hr_finite Hr_val.

  Require Import Interval.Interval_tactic.
  match type of Hr_val with
      ?z = _ =>
      interval_intro z with (i_prec 128) as Hr_range
  end.
  rewrite Hr_val in Hr_range.
  destruct (rememb (B2R _ _ r - (B2R _ _ x' * B2R _ _ x' + B2R _ _ y' * B2R _ _ y' + B2R _ _ z' * B2R _ _ z'))) as (err & Herr).
  generalize Herr. intro Herr'.
  rewrite <- Hr_val in Herr'.
  ring_simplify in Herr'.
  match type of Herr' with
      _ = ?z =>
      interval_intro (Rabs z) upper with (i_prec 128) as Hr_error
  end.
  rewrite <- Herr' in Hr_error.
  clear Herr'.
  subst err.

  solve_trivial.
  eassumption.
Defined.

Definition norm2_error' :=
  let (x, _) := f_norm2_body_correct' in
  let '(y, _, _) := x in y
.

Definition norm2_error'_eq := $( field_eq norm2_error' )$ .

Definition norm2_error := $( match type of norm2_error'_eq with _ = ?z => exact z end )$ .

Definition norm2_left' :=
  let (x, _) := f_norm2_body_correct' in
  let '(_, y, _) := x in y
.

Definition norm2_left'_eq := $( field_eq norm2_left' )$ .

Definition norm2_left := $( match type of norm2_left'_eq with _ = ?z => exact z end )$ .

Definition norm2_right' :=
  let (x, _) := f_norm2_body_correct' in
  let '(_, _, y) := x in y
.

Definition norm2_right'_eq := $( field_eq norm2_right' )$ .

Definition norm2_right := $( match type of norm2_right'_eq with _ = ?z => exact z end )$ .

Lemma f_norm2_body_correct:
  f_norm2_correct (norm2_error, norm2_left, norm2_right).
Proof.
  unfold norm2_error. rewrite <- norm2_error'_eq.
  unfold norm2_left. rewrite <- norm2_left'_eq.
  unfold norm2_right. rewrite <- norm2_right'_eq.
  unfold norm2_error', norm2_left', norm2_right'.
  destruct f_norm2_body_correct'.
  destruct x.
  destruct p.
  assumption.
Qed.

Local Existing Instances
      FPLang.map_nat FPLang.compcert_map
.

Lemma fshift_correct:
  forall (V : Type) (NANS : FPLang.Nans)
    (env : forall ty : FPLang.type, V -> FPLang.ftype ty)
    (e : FPLang.expr) o,
           FPLang.fval env e = o ->
           {
             u : _ &
                   {v |
                    u = (FPLangOpt.fshift e) /\
                    FPLang.fval env u =
                    eq_rect_r FPLang.ftype o v} }
.
Proof.
  intros.
  subst o.
  esplit.
  esplit.
  split; eauto.
  apply FPLangOpt.fshift_correct.
Defined.

Ltac interval_with c :=
  match goal with
    |- ?a <= ?b =>
    interval_intro (a - b) with c;
      lra
    | |- ?a < ?b =>
    let K := fresh in
    interval_intro (a - b) with c;
      lra
  end.

Definition f_norm_correct BOUNDS ge fn_norm :=
  let '(f_norm_error, norm_left, norm_right) := BOUNDS in
type_of_fundef fn_norm =
   Ctypes.Tfunction
     (Ctypes.Tcons (Clightdefs.tptr Clightdefs.tdouble)
        (Ctypes.Tcons Clightdefs.tdouble
           (Ctypes.Tcons Clightdefs.tdouble
              (Ctypes.Tcons Clightdefs.tdouble
                 Ctypes.Tnil)))) Clightdefs.tvoid cc_default
/\
  forall
    os
    (Hos_align: (align_chunk Mfloat64 | Int.unsigned os)%Z )
    ps
    (Hps: perm_order ps Writable)

    m bs P
    (Hm:
       holds
         (P ++
            Pperm bs (Int.unsigned os) ps (size_chunk_nat Mfloat64)
         )
         m)

   x'
   (Hx'_finite: is_finite _ _ x' = true)
   (Hx'_range: xdiff_left <= B2R _ _ x' <= xdiff_right )

   y'
   (Hy'_finite: is_finite _ _ y' = true)
   (Hy'_range: ydiff_left <= B2R _ _ y' <= ydiff_right )

   z'
   (Hz'_finite: is_finite _ _ z' = true)
   (Hz'_range: zdiff_left <= B2R _ _ z' <= zdiff_right )

  ,
    let st0 := (Callstate fn_norm
                          (Vptr bs os :: Vfloat x' :: Vfloat y' :: Vfloat z' :: nil)
                          Kstop
                          m) in
    exists m',
      star Clight.step2 ge
           st0
           E0
           (Returnstate Vundef Kstop m')
      /\
      exists res,
      is_finite _ _ res = true
      /\
      Rabs (B2R _ _ res - R_sqrt.sqrt (B2R _ _ x' * B2R _ _ x' + B2R _ _ y' * B2R _ _ y' + B2R _ _ z' * B2R _ _ z')) <= f_norm_error
      /\
      norm_left <= B2R _ _ res <= norm_right
      /\
      holds
        (P ++
           Pval Mfloat64 bs (Int.unsigned os) ps (Vfloat res)
        )
        m'
.

Require Import SARBackProjSourceSqrt.

Lemma f_norm_body_correct': { f_norm_error | forall
      (ge: Clight.genv)
      b_sqrt fn_sqrt
      (Hb_sqrt_symb: Genv.find_symbol ge _sqrt = Some b_sqrt)
      (Hb_sqrt_funct: Genv.find_funct_ptr ge b_sqrt = Some fn_sqrt)

      (Hf_sqrt_correct: _sqrt_correct ge fn_sqrt)
,
  f_norm_correct f_norm_error ge (Internal f_norm)
}.
Proof.
  eexists (_, _, _).
  intros ge b_sqrt fn_sqrt Hb_sqrt_symb Hb_sqrt_funct.
  intros Hf_sqrt_correct.
  destruct Hf_sqrt_correct as (sqrt_type & Hf_sqrt_correct).

  split.
  {
    reflexivity.
  }
  intros os Hos_align ps Hps.
  intros m bs P Hm x'.
  intros Hx'_finite Hx'_range y' Hy'_finite Hy'_range z' Hz'_finite Hz'_range st0.

  unfold st0; clear st0.

  match goal with
    |- exists m', Smallstep.star step2 ?ge ?s Events.E0 (Returnstate Vundef Kstop m') /\ ?P =>
    cut
      (exists s',
         Smallstep.star step2 ge s Events.E0 s' /\
         exists m',
           s' = Returnstate Vundef Kstop m' /\
           P)
  end.
  {
    let H := fresh in
    intro H;  break H; subst; eauto 15.
  }

  apply star_call_eval_funcall_exists.
  apply eval_funcall_exists_internal.
  solve_trivial.

  simpl fn_vars.
  unfold alloc_variables_prop.
  solve_trivial.

  simpl fn_body.
  apply exec_Sseq_exists.
  apply exec_Scall_exists.
  solve_trivial.
  repeat ClightSep2.run.

  edestruct f_norm2_body_correct with (ge := ge) as (? & EVAL & n2 & ? & Hn2_finite & Hn2_range & Hn2_error); try eassumption.
  subst.
  solve_trivial.
  clear EVAL.
  unfold out_normal_b.

  apply eval_funcall_exists_star_call.
  apply exec_call_exists.
  solve_trivial.
  eapply exists_modus_ponens.
  {
    eapply exists_double_elim.
    eapply Hf_sqrt_correct.
    { assumption. }
    { unfold norm2_left in Hn2_range. lra. }
  }
  intros s1 (v & ? & Hv).
  subst s1.
  unfold Bsqrt in Hv.
  match type of Hv with
      _ = Fappli_IEEE.Bsqrt ?prec ?emax ?gt ?lt ?nan ?mode ?u =>
      generalize (Bsqrt_correct prec emax gt lt nan mode u)
  end.
  rewrite <- Hv; clear Hv.
  intros (Hv_val & Hv_finite_ & _).
  assert (is_finite _ _ v = true) as Hv_finite.
  {
    destruct n2; auto.
    destruct b; auto.
    simpl in Hn2_range.
    unfold Fcore_defs.F2R in Hn2_range.
    simpl in Hn2_range.
    unfold norm2_left in Hn2_range.
    rewrite P2R_INR in Hn2_range.
    generalize (bpow_gt_0 radix2 e).
    generalize (INR_pos m0).
    intros U V.
    generalize (Rmult_lt_0_compat _ _ U V).
    lra.
  }
  clear Hv_finite_.
  simpl round_mode in Hv_val.
  match type of Hv_val with
      _ = round ?beta (Fcore_FLT.FLT_exp ?emin ?prec) (Znearest ?choice) ?x =>
      generalize (error_N_FLT beta emin prec $( vm_compute; congruence )$ choice x)
  end.
  intros (d & e & Hd & He & _ & Hv_).
  rewrite Hv_ in Hv_val; clear Hv_.
  unfold fprec in Hv_val.
  simpl in Hv_val.
  simpl in Hd, He.
  solve_trivial.

  apply star_exists_refl.
  solve_trivial.

  apply exec_Sassign_exists.
  repeat run.

  holds_storev_solve.
  intros m Hm.
  solve_trivial.

  simpl outcome_result_value_exists.
  solve_trivial.

  apply and_assoc.
  split; eauto.

  unfold xdiff_left, ydiff_left, zdiff_left, norm2_left, norm2_error in *.
  generalize Hn2_error. intro Hn2_error'.
  apply Fcore_Raux.Rabs_le_inv in Hn2_error'.
  apply sqrt_abs_error_bound in Hn2_error; try lra.
  match type of Hn2_error with
    _ <= ?z =>
    destruct (rememb z) as (c & Hc);
      rewrite <- Hc in Hn2_error
  end.
  unfold norm2_right, xdiff_left, xdiff_right, ydiff_left, ydiff_right, zdiff_left, zdiff_right in *.
  match type of Hc with
      _ = ?z =>
      interval_intro z upper as Hc_range';
        rewrite <- Hc in Hc_range';
        clear Hc
  end.
  generalize (Rle_trans _ _ _ Hn2_error Hc_range').
  clear c Hn2_error Hc_range'.
  intro Hc.

  assert (B2R _ _ v - sqrt (B2R _ _ n2) = sqrt (B2R _ _ n2) * d + e) as Hy_error_eq.
  {
    rewrite Hv_val.
    ring.
  }
  match type of Hy_error_eq with
      _ = ?z =>
      interval_intro (Rabs z) upper with (i_prec 128) as Hy_error
  end.
  rewrite <- Hy_error_eq in Hy_error; clear Hy_error_eq.
  split.
  {
    eexact (Rabs_triang2 _ _ _ _ _ Hy_error Hc).
  }
  match type of Hv_val with
      _ = ?z =>
      interval_intro z with (i_prec 128) as Hy_range
  end.
  rewrite <- Hv_val in Hy_range.
  eexact Hy_range.

Defined.

Definition f_norm_error' :=
 let (x, _) := f_norm_body_correct' in
 let '(y, _, _) := x in y.

Definition f_norm_error'_eq :=
  $( field_eq f_norm_error' )$ .

Definition f_norm_error :=
  $( match type of f_norm_error'_eq with _ = ?z => exact z end )$ .

Definition f_norm_left' :=
 let (x, _) := f_norm_body_correct' in
 let '(_, y, _) := x in y.

Definition f_norm_left'_eq :=
  $( field_eq f_norm_left' )$ .

Definition f_norm_left :=
  $( match type of f_norm_left'_eq with _ = ?z => exact z end )$ .

Definition f_norm_right' :=
 let (x, _) := f_norm_body_correct' in
 let '(_, _, y) := x in y.

Definition f_norm_right'_eq :=
  $( field_eq f_norm_right' )$ .

Definition f_norm_right :=
  $( match type of f_norm_right'_eq with _ = ?z => exact z end )$ .

Lemma f_norm_body_correct: forall
      (ge: Clight.genv)
      b_sqrt fn_sqrt
      (Hb_sqrt_symb: Genv.find_symbol ge _sqrt = Some b_sqrt)
      (Hb_sqrt_funct: Genv.find_funct_ptr ge b_sqrt = Some fn_sqrt)

      (Hf_sqrt_correct: _sqrt_correct ge fn_sqrt)
,
  f_norm_correct (f_norm_error, f_norm_left, f_norm_right) ge (Internal f_norm)
.
Proof.
  unfold f_norm_error.
  rewrite <- f_norm_error'_eq.
  unfold f_norm_left.
  rewrite <- f_norm_left'_eq.
  unfold f_norm_right.
  rewrite <- f_norm_right'_eq.
  unfold f_norm_error', f_norm_left', f_norm_right'.
  destruct f_norm_body_correct'.
  destruct x.
  destruct p.
  assumption.
Qed.