Require Import syntax.
Require Import alist.
Require Import FMapWeakList.

Require Import Classical.
Require Import Coqlib.
Require Import infrastructure.
Require Import Metatheory.
Import LLVMsyntax.
Import LLVMinfra.
Require Import opsem.

Require Import sflib.
Require Import paco.
Import Opsem.

Require Import TODO.
Require Import Decs.
Require Import Hints.
Require Import Validator.
Require Import GenericValues.
Require Import TODOProof.
Require Import OpsemAux.
Require Import SimulationLocal.
Require Import Simulation.
Require Import Inject.
Require AssnMem.
Require AssnState.
Require Import ValidAux.
Require Import SoundBase.
Require Import SoundImplies.
Require Import SoundPostcondCmd.
Require Import SoundPostcondCall.
Require Import SoundPostcondPhinodes.
Require Import SoundInfrules.
Require Import SoundReduceMaydiff.
Require Import opsem_wf.

Set Implicit Arguments.

Inductive valid_state_sim
          (conf_src conf_tgt:Config)
          (stack0_src stack0_tgt:ECStack)
          (assnmem:AssnMem.Rel.t)
          (idx:nat)
          (st_src st_tgt:State): Prop :=
| valid_state_sim_intro
    m_src m_tgt
    fdef_hint cmds_hint
    inv
    invst
    (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt)
    (ECS_SRC: st_src.(ECS) = stack0_src)
    (ECS_TGT: st_tgt.(ECS) = stack0_tgt)
    (FDEF: valid_fdef m_src m_tgt st_src.(EC).(CurFunction) st_tgt.(EC).(CurFunction) fdef_hint)
    (LABEL: st_src.(EC).(CurBB).(fst) = st_tgt.(EC).(CurBB).(fst))
    inv_term
    (CMDS: valid_cmds m_src m_tgt st_src.(EC).(CurCmds) st_tgt.(EC).(CurCmds) cmds_hint inv = Some inv_term)
    (TERM: exists infrules,
        valid_terminator fdef_hint (Infrules.apply_infrules m_src m_tgt infrules inv_term) m_src m_tgt
                         (st_src.(EC).(CurFunction).(get_blocks))
                         (st_tgt.(EC).(CurFunction).(get_blocks))
                         (st_src.(EC).(CurBB).(fst))
                         (st_src.(EC).(Terminator))
                         (st_tgt.(EC).(Terminator)))
    (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst assnmem inv)
    (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem)
    (WF_SRC: wf_ConfigI conf_src /\ wf_StateI conf_src st_src)
    (WF_TGT: wf_ConfigI conf_tgt /\ wf_StateI conf_tgt st_tgt)
.

Lemma decide_nonzero_inject
      TD conds_src conds_tgt decision meminj
      (NONZERO: decide_nonzero TD conds_src decision)
      (INJECT: genericvalues_inject.gv_inject meminj conds_src conds_tgt)
  :
    <<NONZERO: decide_nonzero TD conds_tgt decision>>
.
Proof.
  inv NONZERO.
  red. econs; eauto.
  eapply genericvalues_inject.simulation__GV2int; eauto.
Qed.

Lemma valid_sim_term
      conf_src conf_tgt inv0 idx0
      CurFunction0 CurBB0 Terminator0 Locals0 Allocas0
      ECS0 Mem0 CurFunction1 CurBB1 Terminator1 Locals1 Allocas1 ECS1 Mem1
      (ERROR_SRC : ~ error_state conf_src
                     (mkState (mkEC CurFunction0 CurBB0 [] Terminator0 Locals0 Allocas0) ECS0 Mem0))
      (m_src m_tgt : module)
      fdef_hint inv_term invst
      (CONF : AssnState.valid_conf m_src m_tgt conf_src conf_tgt)
      (FDEF : valid_fdef m_src m_tgt CurFunction0 CurFunction1 fdef_hint)
      (LABEL : fst CurBB0 = fst CurBB1)
      (TERM: exists infrules,
          valid_terminator fdef_hint (Infrules.apply_infrules m_src m_tgt infrules inv_term)
                           m_src m_tgt (get_blocks CurFunction0)
                           (get_blocks CurFunction1) (fst CurBB0) Terminator0 Terminator1)
      (MEM : AssnMem.Rel.sem conf_src conf_tgt Mem0 Mem1 inv0)
      (STATE : AssnState.Rel.sem conf_src conf_tgt
                                (mkState (mkEC CurFunction0 CurBB0 [] Terminator0 Locals0 Allocas0) ECS0 Mem0)
                                (mkState (mkEC CurFunction1 CurBB1 [] Terminator1 Locals1 Allocas1) ECS1 Mem1)
                                invst inv0 inv_term)
      (WF_SRC: wf_ConfigI conf_src /\
               wf_StateI conf_src (mkState (mkEC CurFunction0 CurBB0 [] Terminator0 Locals0 Allocas0)
                                           ECS0 Mem0))
      (WF_TGT: wf_ConfigI conf_tgt /\
               wf_StateI conf_tgt (mkState (mkEC CurFunction1 CurBB1 [] Terminator1 Locals1 Allocas1)
                                           ECS1 Mem1))
  :
    <<SIM_TERM: _sim_local conf_src conf_tgt
                           (valid_state_sim conf_src conf_tgt)
                           ECS0 ECS1 inv0 idx0
                           (mkState (mkEC CurFunction0 CurBB0 [] Terminator0 Locals0 Allocas0) ECS0 Mem0)
                           (mkState (mkEC CurFunction1 CurBB1 [] Terminator1 Locals1 Allocas1) ECS1 Mem1)
                           >>
.
Proof.
  des.
  unfold valid_terminator in TERM.
  expl apply_infrules_sound. cbn in *.
  simtac;
    (try by exfalso; eapply has_false_False; eauto).
  destruct Terminator0, Terminator1; simtac.
  + (* return *)
    move inv0 at bottom.
    move assnmem1 at bottom.
    eapply _sim_local_return; eauto; ss.
    { apply STATE0. }
    { eapply Forall_harder; [apply STATE0|].
      s. i.
      rpapply H. symmetry. apply MEM0. }
    { eapply Forall_harder; [apply STATE0|].
      s. i.
      rpapply H. symmetry. apply MEM0. }
    { apply STATE0. }
    { apply STATE0. }
    i.
    exploit AssnState.Rel.inject_value_spec; try exact COND0; eauto.
    { rewrite AssnState.Unary.sem_valueT_physical. eauto. }
    i. des. rewrite AssnState.Unary.sem_valueT_physical in VAL_TGT. ss.
    esplits; eauto.
    econs; eauto.
    * eapply get_operand_valid_ptr; eauto; try apply STATE0; try apply MEM0.
    * eapply get_operand_valid_ptr; eauto; try apply STATE0; try apply MEM0.
  + (* return_void *)
    eapply _sim_local_return_void; eauto; ss.
    { apply STATE. }
    { eapply Forall_harder; [apply STATE|].
      s. i.
      rpapply H. symmetry. apply MEM. }
    { eapply Forall_harder; [apply STATE|].
      s. i.
      rpapply H. symmetry. apply MEM. }
    { apply STATE. }
    { apply STATE. }
  + (* br *)
    clears invst.
    rename STATE0 into STATE1.
    exploit nerror_nfinal_nstuck; eauto. i. des. inv x0.
    rewrite <- (ite_spec decision l0 l3) in *. simtac.
    exploit AssnState.Rel.inject_value_spec; eauto.
    { rewrite AssnState.Unary.sem_valueT_physical. eauto. }
    rewrite AssnState.Unary.sem_valueT_physical. s. i. des.
    eapply _sim_local_step; swap 2 4. (* move 2 to the end *)
    {
      expl progress.
      - ss.
      - unfold OpsemPP.undefined_state in *.
        des_ifs_safe; ss.
        des; ss.
        { des_ifs; ss. }
        des_ifs.
        exfalso.
        inv H13.
        inv CONF. inv INJECT0. ss. clarify.
        clear - Heq0 INT INJECT.
        unfold GV2int in *.
        des_ifs_safe.
        inv INJECT. inv H4. inv H3.
        des_ifs.
      - ii. ss.
    }
    { splits; ss. }
    { splits; ss. }
    i.
    expl preservation (try exact WF_TGT0; eauto). rename preservation into WF_TGT_NEXT.
    clear ERROR_SRC.
    inv STEP. unfold valid_phinodes in *.
    do 12 simtac0. rewrite <- (ite_spec decision0 l0 l3) in *.
    {
      inv CONF. inv INJECT0. ss. clarify.
      expl decide_nonzero_inject_aux. clarify.
      expl valid_fdef_valid_stmts (try exact COND3; eauto).
      expl valid_fdef_valid_stmts (try exact COND7; eauto).
      move COND1 at bottom.
      move COND2 at bottom.
      rename s0 into __s0__.
      rename s into __s__.

      Ltac abstr_gen_infrules HYP NAME :=
        match goal with
        | [H: context[(gen_infrules_next_inv false ?x ?y)] |- _ ] =>
          check_equal H HYP;
          abstr (gen_infrules_next_inv false x y) NAME
        end.
      Ltac abstr_gen_infrules_first HYP NAME :=
        match goal with
        | [H: context[(gen_infrules_next_inv true ?x ?y) ++ ?z] |- _ ] =>
          check_equal H HYP;
          abstr ((gen_infrules_next_inv true x y) ++ z) NAME
        end.

      abstr_gen_infrules COND1 infrulesA0.
      abstr_gen_infrules COND2 infrulesB0.
      unfold l in *.

      abstr_gen_infrules_first COND1 infrulesA2.
      abstr (ValidationHint.assertion_after_phinodes __s0__) inv_afterA.
      assert(exists infrulesA1,
                (Assertion.implies
                  (Postcond.reduce_maydiff
                     (Infrules.apply_infrules m_src m_tgt infrulesA1
                        (Postcond.reduce_maydiff
                           (Infrules.apply_infrules m_src m_tgt infrulesA2 t0)))) inv_afterA)).
      { des_ifsH COND1; des_bool.
        - esplits; ss. eassumption.
        - exists nil. ss. etransitivity; eauto.
          eapply implies_reduce_maydiff; eauto. }
      clear COND1.

      abstr_gen_infrules_first COND2 infrulesB2.
      abstr (ValidationHint.assertion_after_phinodes __s__) inv_afterB.
      abstr (ValidationHint.cmds __s__) cmdsB.
      assert(exists infrulesB1,
                (Assertion.implies
                  (Postcond.reduce_maydiff
                     (Infrules.apply_infrules m_src m_tgt infrulesB1
                        (Postcond.reduce_maydiff
                           (Infrules.apply_infrules m_src m_tgt infrulesB2 t)))) inv_afterB)).
      { des_ifsH COND2; des_bool.
        - esplits; ss. eassumption.
        - exists nil. ss. etransitivity; eauto.
          eapply implies_reduce_maydiff; eauto. }
      clear COND2.

      des. clarify.
      (* expl add_terminator_cond_br. *)
      rewrite lookupBlockViaLabelFromFdef_spec in *.
      (* expl (lookupAL_ite fdef_hint decision0 l0 l3). *) (* TODO: Fix expl to pass thi *)
      exploit (lookupAL_ite fdef_hint decision0 l0 l3); eauto. clear COND7 COND3. i.
      exploit (lookupAL_ite CurFunction0.(get_blocks) decision0 l0 l3); eauto. clear COND8 COND4. i.
      exploit (lookupAL_ite CurFunction1.(get_blocks) decision0 l0 l3); eauto. clear COND9 COND5. i.
      (* TODO: apply & clear ? *)
      rewrite x1 in *. clarify.
      rewrite x2 in *. clarify.

      expl add_terminator_cond_br.
      destruct decision0; ss; clarify.
      -
        exploit postcond_phinodes_sound;
          try exact add_terminator_cond_br; try exact COND10; try eassumption; eauto; ss; []; intro STATE2.
        destruct STATE2 as [invst2 STATE2].
        clears add_terminator_cond_br invst1.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE3.
        destruct STATE3 as [invst3 [assnmem3 [STATE3 [MEM3 MEMLE3]]]]; des.
        clears invst2.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE4.
        destruct STATE4 as [invst4 STATE4]; des.
        clears invst3.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE5.
        destruct STATE5 as [invst5 [assnmem5 [STATE5 [MEM5 MEMLE5]]]]; des.
        clears invst4.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE6.
        destruct STATE6 as [invst6 STATE6]; des.
        clears invst5.

        assert(AssnMem.Rel.le inv0 assnmem5).
        { etransitivity; eauto. etransitivity; eauto. }

        esplits; eauto.
        { econs 1. econs; eauto. rewrite lookupBlockViaLabelFromFdef_spec. ss. }
        {
          econs; eauto; ss.
          - eapply implies_sound; eauto.
            { ss. }
          - split; ss.
            eapply preservation; eauto.
            rpapply sBranch; eauto. ss.
            rewrite lookupBlockViaLabelFromFdef_spec. ss.
            (* Are we lucky? Will there be no siuation that forces us to get wf_src before esplits? *)
            (* Will we always be able to (easy to) re-construct sInsn like this? *)
        }
      -
        exploit postcond_phinodes_sound;
          try exact add_terminator_cond_br; try exact COND6; try eassumption; eauto; ss; []; intro STATE2.
        destruct STATE2 as [invst2 STATE2].
        clears add_terminator_cond_br invst1.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE3.
        destruct STATE3 as [invst3 [assnmem3 [STATE3 [MEM3 MEMLE3]]]]; des.
        clears invst2.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE4.
        destruct STATE4 as [invst4 STATE4]; des.
        clears invst3.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE5.
        destruct STATE5 as [invst5 [assnmem5 [STATE5 [MEM5 MEMLE5]]]]; des.
        clears invst4.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE6.
        destruct STATE6 as [invst6 STATE6]; des.
        clears invst5.

        assert(AssnMem.Rel.le inv0 assnmem5).
        { etransitivity; eauto. etransitivity; eauto. }
        esplits; eauto.
        { econs 1. econs; eauto. rewrite lookupBlockViaLabelFromFdef_spec. ss. }
        {
          econs; eauto; ss.
          (* - eapply inject_allocas_inj_incr; eauto. *)
          - eapply implies_sound; eauto.
            { ss. }
          - split; ss.
            eapply preservation; eauto.
            rpapply sBranch; eauto. ss.
            rewrite lookupBlockViaLabelFromFdef_spec. ss.
        }
    }
  + (* br_uncond *)
    clears invst.
    rename STATE0 into STATE1.
    exploit nerror_nfinal_nstuck; eauto. i. des. inv x0.
    eapply _sim_local_step; swap 2 4. (* move 2 to the end *)
    {
      expl progress.
      - ss.
      - unfold OpsemPP.undefined_state in *.
        des_ifs; des; ss.
      - ii. ss.
    }
    { split; ss. }
    { split; ss. }
    i.
    expl preservation. rename preservation into WF_TGT_NEXT.
    clear ERROR_SRC.
    inv STEP. unfold valid_phinodes in *.
    {
      inv CONF. inv INJECT. ss. clarify.
      repeat (simtac0; []).
      expl valid_fdef_valid_stmts.
      hide_goal.
      abstr_gen_infrules COND0 infrulesA0.
      unfold l in *.

      abstr_gen_infrules_first COND0 infrulesA2.
      abstr (ValidationHint.assertion_after_phinodes s) inv_afterA.
      assert(exists infrulesA1,
                (Assertion.implies
                  (Postcond.reduce_maydiff
                     (Infrules.apply_infrules m_src m_tgt infrulesA1
                        (Postcond.reduce_maydiff
                           (Infrules.apply_infrules m_src m_tgt infrulesA2 t)))) inv_afterA)).
      { des_ifsH COND0; des_bool.
        - esplits; ss. eassumption.
        - exists nil. ss. etransitivity; eauto.
          eapply implies_reduce_maydiff; eauto. }
      clear COND0.

      des. clarify.
      rewrite lookupBlockViaLabelFromFdef_spec in *.
      rewrite COND2 in *. rewrite COND3 in *. clarify.
      rewrite add_terminator_cond_br_uncond in *.

      -
        exploit postcond_phinodes_sound;
          try eassumption; eauto; ss; []; intro STATE2.
        destruct STATE2 as [invst2 STATE2].
        clears invst1.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE3.
        destruct STATE3 as [invst3 [assnmem3 [STATE3 [MEM3 MEMLE3]]]]; des.
        clears invst2.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE4.
        destruct STATE4 as [invst4 STATE4]; des.
        clears invst3.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE5.
        destruct STATE5 as [invst5 [assnmem5 [STATE5 [MEM5 MEMLE5]]]]; des.
        clears invst4.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE6.
        destruct STATE6 as [invst6 STATE6]; des.
        clears invst5.

        assert(AssnMem.Rel.le inv0 assnmem5).
        { etransitivity; eauto. etransitivity; eauto. }
        unfold HIDDEN_GOAL.
        esplits; eauto.
        { econs 1. econs; eauto. rewrite lookupBlockViaLabelFromFdef_spec. ss. }
        {
          econs; eauto; ss.
          (* - eapply inject_allocas_inj_incr; eauto. *)
          - eapply implies_sound; eauto.
            { ss. }
          - split; ss.
            eapply preservation; eauto.
            econs; eauto.
            rewrite lookupBlockViaLabelFromFdef_spec. ss.
        }
    }
  + (* switch *)
    clears invst.
    rename STATE0 into STATE1.
    exploit nerror_nfinal_nstuck; eauto. i. des. inv x0.
    eapply _sim_local_step; swap 2 4. (* move 2 to the end *)
    {
      expl progress.
      - ss.
      - unfold OpsemPP.undefined_state in *.
        des_ifs_safe; ss.
        des; ss.
        { des_ifs. }
        des_ifs.
        exfalso.
        inv CONF. inv INJECT. ss. clarify.
        exploit AssnState.Rel.inject_value_spec; eauto.
        { ss. }
        { rewrite AssnState.Unary.sem_valueT_physical. ss. eauto. }
        i; des. rewrite AssnState.Unary.sem_valueT_physical in *. ss. clarify.
        clear - INJECT Heq1 Heq0.
        unfold GV2int in *.
        des_ifs_safe.
        inv INJECT. inv H4. inv H3.
        des_ifs.
      - ii. ss.
    }
    { split; ss. }
    { split; ss. }
    i.
    expl preservation. rename preservation into WF_TGT_NEXT.
    clear ERROR_SRC.
    inv STEP. unfold valid_phinodes in *.
    {
      inv CONF. inv INJECT. ss. clarify.
      des_sumbool. subst. (* list_const_l_dec *)
      rename l_0 into dflt.
      rename l1 into cases.
      rename COND3 into COND_DFLT.
      rename COND2 into COND_CASES.
      repeat (simtac0; []).
      rename COND4 into PCOND_DFLT.
      hexploit AssnState.Rel.inject_value_spec; try exact STATE1; ss; eauto.
      { rewrite AssnState.Unary.sem_valueT_physical. eauto. }
      i; des.
      rewrite AssnState.Unary.sem_valueT_physical in *. ss. clarify.
      expl get_switch_branch_inject. clarify.
      hide_goal.

      expl add_terminator_cond_switch.

      expl get_switch_branch_in_successors.
      unfold successors_terminator in *.
      apply nodup_In in get_switch_branch_in_successors0. ss. des.
      { (* default *)
        expl valid_fdef_valid_stmts.
        clear COND_CASES.
        subst dflt.
        rewrite lookupBlockViaLabelFromFdef_spec in *.

        move H19 at bottom.
        move COND3 at bottom.
        move get_switch_branch_inject at bottom.

        eq_closure_tac. clarify.

        abstr_gen_infrules COND_DFLT infrulesA0.
        unfold l in *.

        abstr_gen_infrules_first COND_DFLT infrulesA2.
        abstr (ValidationHint.assertion_after_phinodes s) inv_afterA.
        assert(exists infrulesA1,
                  (Assertion.implies
                     (Postcond.reduce_maydiff
                        (Infrules.apply_infrules
                           m_src m_tgt infrulesA1
                           (Postcond.reduce_maydiff
                              (Infrules.apply_infrules m_src m_tgt infrulesA2 t)))) inv_afterA)).
        { des_ifsH COND_DFLT; des_bool.
          - esplits; ss. eassumption.
          - exists nil. ss. etransitivity; eauto.
            eapply implies_reduce_maydiff; eauto. }
        clear COND_DFLT.
        des.

        exploit postcond_phinodes_sound; try exact PCOND_DFLT; try exact add_terminator_cond_switch;
          ss; eauto; []; intro STATE2. destruct STATE2 as [invst2 STATE2].
        clears invst1.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE3.
        destruct STATE3 as [invst3 [assnmem3 [STATE3 [MEM3 MEMLE3]]]]; des.
        clears invst2.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE4.
        destruct STATE4 as [invst4 STATE4]; des.
        clears invst3.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE5.
        destruct STATE5 as [invst5 [assnmem5 [STATE5 [MEM5 MEMLE5]]]]; des.
        clears invst4.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE6.
        destruct STATE6 as [invst6 STATE6]; des.
        clears invst5.

        assert(AssnMem.Rel.le inv0 assnmem5).
        { etransitivity; eauto. etransitivity; eauto. }
        unfold HIDDEN_GOAL.
        esplits; eauto.
        { econs 1. econs; eauto. rewrite lookupBlockViaLabelFromFdef_spec. ss. }
        {
          econs; eauto; ss.
          - eapply implies_sound; eauto.
            { ss. }
          - split; ss.
            eapply preservation; eauto.
            econs; eauto.
            rewrite lookupBlockViaLabelFromFdef_spec. ss.
        }
      }
      { (* cases *)
        (* clears dflt. *)
        clear COND_DFLT PCOND_DFLT COND1 COND2 COND3.
        apply list_prj2_inv in get_switch_branch_in_successors0. des.
        rewrite forallb_forall in COND_CASES.
        specialize (COND_CASES (x, tgt0) get_switch_branch_in_successors0).
        clear get_switch_branch_in_successors0.
        des_bool. des_ifs_safe. des_bool.
        clear_tac. rename Heq into COND_CASES. rename Heq3 into PCOND_CASES.
        rewrite lookupBlockViaLabelFromFdef_spec in *.
        ss. eq_closure_tac. clarify.
        expl valid_fdef_valid_stmts. ss.

        abstr_gen_infrules COND_CASES infrulesA0.
        unfold l in *.

        abstr_gen_infrules_first COND_CASES infrulesA2.
        abstr (ValidationHint.assertion_after_phinodes s0) inv_afterA.
        assert(exists infrulesA1,
                  (Assertion.implies
                     (Postcond.reduce_maydiff
                        (Infrules.apply_infrules
                           m_src m_tgt infrulesA1
                           (Postcond.reduce_maydiff
                              (Infrules.apply_infrules m_src m_tgt infrulesA2 t0)))) inv_afterA)).
        { des_ifsH COND_CASES; des_bool.
          - esplits; ss. eassumption.
          - exists nil. ss. etransitivity; eauto.
            eapply implies_reduce_maydiff; eauto. }
        clear COND_CASES.
        des.

        exploit postcond_phinodes_sound; try exact PCOND_CASES; try exact add_terminator_cond_switch;
          ss; eauto; []; intro STATE2. destruct STATE2 as [invst2 STATE2].
        clears invst1.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE3.
        destruct STATE3 as [invst3 [assnmem3 [STATE3 [MEM3 MEMLE3]]]]; des.
        clears invst2.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE4.
        destruct STATE4 as [invst4 STATE4]; des.
        clears invst3.

        exploit apply_infrules_sound; eauto; ss; []; intro STATE5.
        destruct STATE5 as [invst5 [assnmem5 [STATE5 [MEM5 MEMLE5]]]]; des.
        clears invst4.

        exploit reduce_maydiff_sound; eauto; ss; []; intro STATE6.
        destruct STATE6 as [invst6 STATE6]; des.
        clears invst5.

        assert(AssnMem.Rel.le inv0 assnmem5).
        { etransitivity; eauto. etransitivity; eauto. }
        unfold HIDDEN_GOAL.
        esplits; eauto.
        { econs 1. econs; eauto. rewrite lookupBlockViaLabelFromFdef_spec. ss. }
        {
          econs; eauto; ss.
          (* - eapply inject_allocas_inj_incr; eauto. *)
          - eapply implies_sound; eauto.
            { ss. }
          - split; ss.
            eapply preservation; eauto.
            econs; eauto.
            rewrite lookupBlockViaLabelFromFdef_spec. ss.
        }
      }
    }
  + (* unreachable *)
    exploit nerror_nfinal_nstuck; eauto. i. des. inv x0.
Unshelve.
all: try destruct CONF; subst; ss.
Qed.
(* TODO: Pull out same pattern as lemma or tac *)

(* TODO: move to postcond.v? SoundBase? Maybe this is proper position.. *)
Lemma postcond_cmd_implies_inject_event
      c0 c1 inv t
      (POSTCOND: Postcond.postcond_cmd c0 c1 inv = Some t)
  :
    <<INJECT_EVENT: Postcond.postcond_cmd_inject_event
                      c0 c1
                      (if Instruction.isCallInst c0
                       then
                         Postcond.ForgetStackCall.t (AtomSetImpl_from_list (Postcond.Cmd.get_def c0))
                                                    (AtomSetImpl_from_list (Postcond.Cmd.get_def c1))
                                                    (Postcond.ForgetMemoryCall.t inv)
                       else
                         Postcond.ForgetStack.t
                           (AtomSetImpl_from_list (Postcond.Cmd.get_def c0))
                           (AtomSetImpl_from_list (Postcond.Cmd.get_def c1))
                           (AtomSetImpl_from_list (Postcond.Cmd.get_leaked_ids c0))
                           (AtomSetImpl_from_list (Postcond.Cmd.get_leaked_ids c1))
                           (Postcond.ForgetMemory.t (Postcond.Cmd.get_def_memory c0)
                                                    (Postcond.Cmd.get_def_memory c1)
                                                    (Postcond.Cmd.get_leaked_ids_to_memory c0)
                                                    (Postcond.Cmd.get_leaked_ids_to_memory c1) inv))
                    = true>>
.
Proof.
  unfold Postcond.postcond_cmd in *.
  unfold Postcond.postcond_cmd_check in *.
  des_ifs; ss; des_bool; ss.
Qed.

Lemma valid_progress
      conf_src conf_tgt stack0_src stack0_tgt inv0 idx0 st_src st_tgt
      (VALID: valid_state_sim conf_src conf_tgt stack0_src stack0_tgt inv0 idx0 st_src st_tgt)
      (ERROR_SRC: ~ error_state conf_src st_src)
      c_src cs_src
      (CMDSRC: st_src.(EC).(CurCmds) = c_src :: cs_src)
      (NOTCALL: Instruction.isCallInst c_src = false)
      c_tgt cs_tgt
      (CMDTGT: st_tgt.(EC).(CurCmds) = c_tgt :: cs_tgt)
      (NOTFINAL: s_isFinalState conf_tgt st_tgt = None)
  :
    <<PROGRESS: ~stuck_state conf_tgt st_tgt>>
.
Proof.
  inv VALID.
  des.
  expl progress; ss. clear WF_TGT WF_TGT0.
  destruct st_src, st_tgt; ss.
  destruct EC0, EC1; ss.
  destruct CurCmds0, CurCmds1; ss. clarify; clear_tac.
  des_ifs_safe.
  unfold OpsemPP.undefined_state in *.
  des_ifs_safe.
  des; ss.
  - des_ifs; ss.
  - des_ifsH IS_UNDEFINED; ss.
    unfold Debug.debug_print_auto in *.
    unfold Debug.failwith_None in *.
    des_ifs_safe.
Abort.

Hint Unfold Debug.debug_print_auto. (* TODO: Put all debugs into this *)
Hint Unfold Debug.debug_print_validation_process.

Lemma apply_is_true
      x
  :
    is_true x <-> x = true (* using << >> here will unable rewrite *)
.
Proof. ss. Qed.

Lemma valid_sim
      conf_src conf_tgt
  :
  (valid_state_sim conf_src conf_tgt) <6= (sim_local conf_src conf_tgt).
Proof.
  pcofix CIH.
  intros stack0_src stack0_tgt inv0 idx0 st_src st_tgt SIM. pfold.
  apply _sim_local_src_error; try apply SIM; []. i.
  destruct st_src, st_tgt. destruct EC0, EC1.
  inv SIM. ss.
  destruct CurCmds0.
  - (* term *)
    des.
    simtac.
    expl valid_sim_term.
    eapply _sim_local_mon; eauto.
  - (* cmd *)
    ss. des_ifs_safe. Fail progress repeat (simtac0; []).
    destruct (Assertion.has_false inv) eqn:T.
    { exfalso; eapply has_false_False; eauto. }
    autounfold in *. ss.
    destruct (match Postcond.postcond_cmd c c0 inv with
              | Some inv1 => Some inv1
              | None =>
                Postcond.postcond_cmd
                  c c0
                  (Infrules.apply_infrules m_src m_tgt
                                           (gen_infrules_from_insns (insn_cmd c) (insn_cmd c0) inv) inv)
              end) eqn: PCND; try by ss.

    abstr (gen_infrules_next_inv true t0 inv ++ l1) l2.
    clear l1. rename l2 into l1. (* to minimize proof break *)

    rename t into __t__.
    assert(PCND0: exists infrulesA,
              Postcond.postcond_cmd
                c c0
                (Infrules.apply_infrules m_src m_tgt infrulesA inv) = Some t0).
    { clear CMDS.
      des_ifs.
      - exists nil. esplits; ss.
      - esplits; eassumption.
    } clear PCND. des.
    des_ifs_safe ss.

    assert(IMPLIES: exists infrulesB,
            Assertion.implies
              (Postcond.reduce_maydiff
                 (Infrules.apply_infrules
                    m_src m_tgt infrulesB
                    (Postcond.reduce_maydiff
                       (Infrules.apply_infrules m_src m_tgt l1 t0)))) __t__ = true).
    { des_ifs.
      - exists nil. ss.
        rewrite <- apply_is_true.
        rewrite <- apply_is_true in Heq0.
        etransitivity; eauto.
        eapply implies_reduce_maydiff.
      - esplits; eassumption.
    } clear Heq. des.

    exploit apply_infrules_sound; try apply STATE; eauto; []; intro PCND;
      destruct PCND as [invst_pcnd [assnmem_pcnd [STATE_PCND [MEM_PCND MEMLE_PCND]]]]. des.
    clears invst.

    (* clears inv0. *)
    (* MEMLE should survive. *)
    (* TODO: if we can make a lemma, sim_local inv0 && inv0 <= inv1 => sim_local inv1, we can *)
    (* do "clears inv0". *)
    (* The lemma is not true for now, (AssnMem.Rel.le not relaxed in all cases) but it seems ok *)
    clear MEM.
    instantiate (1:= infrulesA) in STATE_PCND.
    abstr (Infrules.apply_infrules m_src m_tgt infrulesA inv) inv_pcnd.
    clears inv.

    rename MEM_PCND into MEM1.
    rename MEMLE_PCND into MEMLE1.
    rename STATE_PCND into STATE1.
    rename invst_pcnd into invst1.
    rename assnmem_pcnd into assnmem1.
    rename inv_pcnd into inv1.

    destruct (Instruction.isCallInst c) eqn:CALL; cycle 1.
    + ss.
      simtac. des.
      eapply _sim_local_step; swap 2 4. (* move 2 to the end *)
      {

        expl progress.
        - ss.
        - move ERROR_SRC at bottom.
          apply error_state_neg in ERROR_SRC. des; ss. apply NNPP in ERROR_SRC. des.
          rename ERROR_SRC into SRC_STEP.
          rename PCND0 into POSTCOND.
          (* rename inv into inv0. *)
          move POSTCOND at bottom.
          destruct conf_src; ss.
          inv CONF. inv INJECT. ss. clarify.
          eapply postcond_cmd_implies_inject_event in POSTCOND; des. rewrite CALL in *.

          unfold OpsemPP.undefined_state in *.
          des_ifs_safe. des; ss; des_ifs_safe; ss.
          + des_ifs; ss.
          + exfalso.
            destruct c; des_ifs. ss. repeat (des_bool; des; des_sumbool). clarify.
            inv SRC_STEP.
            unfold alloca in *. des_ifs.
            assert(INJECT : genericvalues_inject.gv_inject (AssnMem.Rel.inject assnmem1) gn g).
            {
              eapply AssnState.Subset.inject_value_Subset in POSTCOND1; cycle 1.
              { instantiate (1:= inv1).
                etransitivity; eauto.
                { eapply SoundForgetStack.forget_stack_Subset; eauto. }
                etransitivity; eauto.
                { eapply SoundForgetMemory.forget_memory_Subset; eauto. }
                reflexivity.
              }
              exploit AssnState.Rel.inject_value_spec; try exact POSTCOND1; eauto.
              { ss. }
              { rewrite AssnState.Unary.sem_valueT_physical. ss. eauto. }
              i; des.
              rewrite AssnState.Unary.sem_valueT_physical in *. ss. rewrite Heq in *. clarify.
            }
            expl genericvalues_inject.simulation__GV2int. rewrite simulation__GV2int in *. ss.
          + exfalso.
            destruct c; des_ifs. ss. des_bool; des. des_sumbool. clarify.
            inv SRC_STEP.
            assert(INJECT : genericvalues_inject.gv_inject (AssnMem.Rel.inject assnmem1) mptr0 g).
            {
              eapply AssnState.Subset.inject_value_Subset in POSTCOND0; cycle 1.
              { instantiate (1:= inv1).
                etransitivity; eauto.
                { eapply SoundForgetStack.forget_stack_Subset; eauto. }
                etransitivity; eauto.
                { eapply SoundForgetMemory.forget_memory_Subset; eauto. }
                reflexivity.
              }
              exploit AssnState.Rel.inject_value_spec; try exact POSTCOND0; eauto.
              { ss. }
              { rewrite AssnState.Unary.sem_valueT_physical. ss. rewrite <- H17. ss. }
              i; des.
              rewrite AssnState.Unary.sem_valueT_physical in *. ss. rewrite Heq in *. clarify.
            }
            {
              (* free inject. easy *)
              unfold free in *. des_ifs_safe.
              unfold GV2ptr in *. des_ifs_safe.
              repeat all_with_term ltac:(fun H => inv H) genericvalues_inject.gv_inject.
              repeat all_with_term ltac:(fun H => inv H) memory_sim.MoreMem.val_inject.
              exploit genericvalues_inject.mem_inj__free; eauto; try apply MEM1; i; des.
              assert(delta = 0).
              { inv MEM1. ss. inv WF. expl mi_bounds. }
              clarify.
              repeat rewrite Z.add_0_r in *.
              rewrite <- int_add_0 in *. clarify.

              des_ifs.
              exploit genericvalues_inject.mi_bounds.
              { apply MEM1. }
              { eauto. }
              i; des.

              eq_closure_tac.
              clarify.
            }
          +
            destruct c; des_ifs; ss; repeat (des_bool; des; des_sumbool; clarify).
(*             * (* nop case *) *)
(*               exfalso. *)
(*               rewrite SoundSnapshot.ExprPairSet_exists_filter in POSTCOND. *)
(*               apply Exprs.ExprPairSetFacts.exists_iff in POSTCOND; [|solve_compat_bool]. *)
(*               unfold Exprs.ExprPairSet.Exists in *. des. *)
(*               des_ifs. des_bool. des. unfold compose in *. des_bool. *)
(*               apply Exprs.ExprPairSetFacts.mem_iff in POSTCOND. *)
(*               { *)
(*                 des. des_sumbool. clarify. *)
(*                 assert(NOT_IN_MD: Assertion.not_in_maydiff inv1 *)
(*                                                            (Exprs.ValueT.lift Exprs.Tag.physical value1)). *)
(*                 { *)
(*                   expl SoundForgetStack.forget_stack_Subset. *)
(*                   eapply AssnState.Subset.not_in_maydiff_Subset; eauto. *)
(*                 } clear POSTCOND0. *)

(*                 assert(DEFINED: exists val, const2GV CurTargetData0 Globals0 (const_undef typ5) = *)
(*                                             Some val). *)
(*                 { AD-MIT " *)
(* Issue on encoding definedness with undef. *)
(* More explanation on: https://github.com/snu-sf/crellvm/issues/426". } *)
(*                 des. *)
(*                 exploit AssnState.Rel.lessdef_expr_spec; eauto. *)
(*                 { apply STATE1. } *)
(*                 { unfold AssnState.Unary.sem_expr. ss. eauto. } *)
(*                 i; des. ss. rewrite AssnState.Unary.sem_valueT_physical in *. ss. des_ifs. *)

(*                 exploit AssnState.Rel.not_in_maydiff_value_spec; try apply STATE1; eauto. *)
(*                 { ss.  } *)
(*                 { rewrite AssnState.Unary.sem_valueT_physical. ss. eauto. } *)
(*                 i; des. *)
(*                 rewrite AssnState.Unary.sem_valueT_physical in *. ss. *)

(*                 { *)
(*                   (* load inject. easy *) *)
(*                   unfold mload in *. des_ifs_safe. *)
(*                   unfold GV2ptr in *. des_ifs_safe. *)
(*                   rename g into __g__. *)
(*                   repeat all_with_term ltac:(fun H => inv H) genericvalues_inject.gv_inject. *)
(*                   repeat all_with_term ltac:(fun H => inv H) memory_sim.MoreMem.val_inject. *)
(*                   exploit genericvalues_inject.simulation_mload_aux; eauto; try apply MEM1; i; des. *)
(*                   assert(delta = 0). *)
(*                   { inv MEM1. ss. inv WF. expl mi_bounds. } *)
(*                   clarify. *)
(*                   rewrite Z.add_0_r in *. *)
(*                   rewrite <- int_add_0 in *. clarify. *)
(*                 } *)
(*               } *)
            * exfalso.
              inv SRC_STEP.
              assert(INJECT : genericvalues_inject.gv_inject (AssnMem.Rel.inject assnmem1) mp g).
              {
                eapply AssnState.Subset.inject_value_Subset in POSTCOND0; cycle 1.
                { instantiate (1:= inv1).
                  etransitivity; eauto.
                  { eapply SoundForgetStack.forget_stack_Subset; eauto. }
                  etransitivity; eauto.
                  { eapply SoundForgetMemory.forget_memory_Subset; eauto. }
                  reflexivity.
                }
                exploit AssnState.Rel.inject_value_spec; try exact POSTCOND0; eauto.
                { ss. }
                { rewrite AssnState.Unary.sem_valueT_physical. ss. rewrite <- H18. ss. }
                i; des.
                rewrite AssnState.Unary.sem_valueT_physical in *. ss. rewrite Heq in *. clarify.
              }
              {
                (* load inject. easy *)
                unfold mload in *. des_ifs_safe.
                unfold GV2ptr in *. des_ifs_safe.
                repeat all_with_term ltac:(fun H => inv H) genericvalues_inject.gv_inject.
                repeat all_with_term ltac:(fun H => inv H) memory_sim.MoreMem.val_inject.
                exploit genericvalues_inject.simulation_mload_aux; eauto; try apply MEM1; i; des.
                assert(delta = 0).
                { inv MEM1. ss. inv WF. expl mi_bounds. }
                clarify.
                rewrite Z.add_0_r in *.
                rewrite <- int_add_0 in *. clarify.
              }
          + exfalso.
            destruct c; des_ifs; ss; repeat (des_bool; des; des_sumbool; clarify).
            inv SRC_STEP.
            assert(INJECT1 : genericvalues_inject.gv_inject (AssnMem.Rel.inject assnmem1) gv1 g).
            {
              eapply AssnState.Subset.inject_value_Subset in POSTCOND1; cycle 1.
              { instantiate (1:= inv1).
                etransitivity; eauto.
                { eapply SoundForgetStack.forget_stack_Subset; eauto. }
                etransitivity; eauto.
                { eapply SoundForgetMemory.forget_memory_Subset; eauto. }
                reflexivity.
              }
              exploit AssnState.Rel.inject_value_spec; try exact POSTCOND1; eauto.
              { ss. }
              { rewrite AssnState.Unary.sem_valueT_physical. ss. rewrite <- H19. ss. }
              i; des.
              rewrite AssnState.Unary.sem_valueT_physical in *. ss. rewrite Heq in *. clarify.
            }
            assert(INJECT2 : genericvalues_inject.gv_inject (AssnMem.Rel.inject assnmem1) mp2 g0).
            {
              eapply AssnState.Subset.inject_value_Subset in POSTCOND0; cycle 1.
              { instantiate (1:= inv1).
                etransitivity; eauto.
                { eapply SoundForgetStack.forget_stack_Subset; eauto. }
                etransitivity; eauto.
                { eapply SoundForgetMemory.forget_memory_Subset; eauto. }
                reflexivity.
              }
              exploit AssnState.Rel.inject_value_spec; try exact POSTCOND0; eauto.
              { ss. }
              { rewrite AssnState.Unary.sem_valueT_physical. ss. rewrite <- H20. ss. }
              i; des.
              rewrite AssnState.Unary.sem_valueT_physical in *. ss. rewrite Heq0 in *. clarify.
            }
            {
              (* mstore inject. easy *)
              unfold mstore in *. des_ifs_safe.
              unfold GV2ptr in *. des_ifs_safe.
              inv INJECT2. inv H4.
              repeat all_with_term ltac:(fun H => inv H) memory_sim.MoreMem.val_inject.
              exploit genericvalues_inject.mem_inj_mstore_aux; eauto; try apply MEM1; i; des.
              assert(delta = 0).
              { inv MEM1. ss. inv WF. expl mi_bounds. }
              clarify.
              rewrite Z.add_0_r in *.
              rewrite <- int_add_0 in *. clarify.
            }
          + destruct c; ss.
        - i; ss.
      }

      { split; ss. }
      { split; ss. }
      i.
      expl preservation. rename preservation into WF_TGT_NEXT.
      exploit postcond_cmd_is_call; eauto. i. rewrite CALL in x0.
      exploit sInsn_non_call; eauto; try congruence. i. des. subst. ss.
      exploit postcond_cmd_sound; [apply WF_SRC | apply WF_TGT | apply WF_SRC0 | apply WF_TGT0|..]; eauto;
        ss; try congruence. i. des.
      exploit sInsn_non_call; eauto; try congruence. i. des. subst. ss.

      (* Want to get AssnState.Rel.sem of __t__ *)
      exploit apply_infrules_sound; try apply STATE; eauto; []; intro STATE2;
        destruct STATE2 as [invst2 [assnmem2 [STATE2 [MEM2 MEMLE2]]]]. des. ss.
      clears invst1.
      instantiate (1:= l1) in STATE2.

      exploit reduce_maydiff_sound; try apply STATE2; eauto; ss; []; intro STATE3.
      destruct STATE3 as [invst3 STATE3]; des.
      clears invst2.

      exploit apply_infrules_sound; try apply STATE3; eauto; []; intro STATE4;
        destruct STATE4 as [invst4 [assnmem4 [STATE4 [MEM4 MEMLE4]]]]. des. ss.
      clears invst3.
      instantiate (1:= infrulesB) in STATE4.

      exploit reduce_maydiff_sound; try apply STATE4; eauto; ss; []; intro STATE5.
      destruct STATE5 as [invst5 STATE5]; des.
      clears invst4.

      {
        assert(AssnMem.Rel.le inv0 assnmem4).
        { etransitivity; eauto. etransitivity; eauto. etransitivity; eauto. }
        esplits; eauto.
        { econs 1; eauto. }
        { right. apply CIH. econs; eauto.
          - eapply implies_sound; eauto.
          - split; ss. eapply preservation; eauto.
        }
      }
    + (* call *)
      exploit postcond_cmd_is_call; eauto. i.
      destruct c; ss. destruct c0; ss.
      clear_tac.
      rename t0 into __t0__.
      hexploit postcond_call_sound; try exact PCND0; eauto;
        (try instantiate (2 := (mkState (mkEC _ _ _ _ _ _) _ _))); ss; eauto; ss.
      { inv WF_SRC0; ss. }
      { inv WF_TGT0; ss. }
      i. des. subst. des.

      eapply _sim_local_call with
          (inv2 := assnmem1)
          (uniqs_src:= (memory_blocks_of conf_src Locals0 (Assertion.unique (Assertion.src inv1))))
          (uniqs_tgt:= (memory_blocks_of conf_tgt Locals1 (Assertion.unique (Assertion.tgt inv1))))
          (privs_src:= (memory_blocks_of_t conf_src _ _ (Assertion.private (Assertion.src inv1))))
          (privs_tgt:= (memory_blocks_of_t conf_tgt _ _ (Assertion.private (Assertion.tgt inv1))));
        ss; eauto; ss.
      { inv STATE1. inv SRC.
        unfold memory_blocks_of. ii.
        des.
        match goal with [ H: In _ (flat_map _ _) |- _ ] => eapply in_flat_map in H; eauto end.
        des.
        des_ifs.
        exploit UNIQUE.
        { apply AtomSetFacts.elements_iff, InA_iff_In; eauto. }
        intro UNIQUE_A. inv UNIQUE_A. ss. clarify.
        (* TODO: name clash on "MEM". Chnage sem_unqiue? smarter way? *)
        exploit MEM; eauto.
      }
      { inv STATE1. inv SRC.
        unfold memory_blocks_of. ii.
        des.
        match goal with [ H: In _ (flat_map _ _) |- _ ] => eapply in_flat_map in H; eauto end.
        des.
        des_ifs.
        exploit UNIQUE.
        { apply AtomSetFacts.elements_iff, InA_iff_In; eauto. }
        intro UNIQUE_A. inv UNIQUE_A. ss. clarify.
        exploit GLOBALS; eauto.
        (* NEED TO STRENGTHEN GLOBALS *)
      }

      { inv STATE1. inv TGT.
        unfold memory_blocks_of. ii.
        des.
        match goal with [ H: In _ (flat_map _ _) |- _ ] => eapply in_flat_map in H; eauto end.
        des.
        des_ifs.
        exploit UNIQUE.
        { apply AtomSetFacts.elements_iff, InA_iff_In; eauto. }
        intro UNIQUE_A. inv UNIQUE_A. ss. clarify.
        exploit MEM; eauto.
      }
      {
        inv STATE1. inv TGT. ss.
        unfold memory_blocks_of.
        replace (AtomSetImpl.elements (Assertion.unique (Assertion.tgt inv1))) with ([]: list atom); cycle 1.
        { symmetry. apply AtomSetProperties.elements_Empty; ss. }
        ss.
      }
      {
        inv STATE1. inv TGT. ss.
        unfold memory_blocks_of.
        replace (AtomSetImpl.elements (Assertion.unique (Assertion.tgt inv1))) with ([]: list atom); cycle 1.
        { symmetry. apply AtomSetProperties.elements_Empty; ss. }
        ss.
      }
      { inv STATE1. inv SRC. ss.
        i. unfold memory_blocks_of_t in IN.
        des.
        match goal with [ H: In _ (flat_map _ _) |- _ ] => eapply in_flat_map in H; eauto end.
        des.
        des_ifs.
        exploit PRIVATE; eauto.
        { apply Exprs.IdTSetFacts.elements_iff.
          (* apply In_InA; eauto. *)
          apply InA_iff_In; eauto.
          split.
          - apply Exprs.IdT.compare_leibniz.
          - i. subst. apply Exprs.IdTFacts.compare_refl.
        }
        ss. i. des. clarify.
      }
      { inv STATE1. inv TGT. ss.
        i. unfold memory_blocks_of_t in IN.
        des.
        match goal with [ H: In _ (flat_map _ _) |- _ ] => eapply in_flat_map in H; eauto end.
        des.
        des_ifs.
        exploit PRIVATE; eauto.
        { apply Exprs.IdTSetFacts.elements_iff.
          (* apply In_InA; eauto. *)
          apply InA_iff_In; eauto.
          split.
          - apply Exprs.IdT.compare_leibniz.
          - i. subst. apply Exprs.IdTFacts.compare_refl.
        }
        ss. i. des. clarify.
      }

      i.
      exploit RETURN; eauto. intro STATE'. des.
      hide_goal.
      rename STATE into STATE'0.
      rename MEM0 into MEM'0.
      rename assnmem2 into assnmem'0.
      rename invst2 into invst'0.

      (* Want to get AssnState.Rel.sem of __t__ *)
      (* This part is common with non-call case... can we remove redundancy? *)

      exploit apply_infrules_sound; try apply STATE'0; eauto; []; intro STATE'1;
        destruct STATE'1 as [invst'1 [assnmem'1 [STATE'1 [MEM'1 MEMLE'1]]]]. des. ss.
      clears invst'0.
      instantiate (1:= l1) in STATE'1.

      exploit reduce_maydiff_sound; try apply STATE'1; eauto; ss; []; intro STATE'2.
      destruct STATE'2 as [invst'2 STATE'2]; des.
      clears invst'1.

      exploit apply_infrules_sound; try apply STATE'2; eauto; []; intro STATE'3;
        destruct STATE'3 as [invst'3 [assnmem'3 [STATE'3 [MEM'3 MEMLE'3]]]]. des. ss.
      clears invst'2.
      instantiate (1:= infrulesB) in STATE'3.

      exploit reduce_maydiff_sound; try apply STATE'3; eauto; ss; []; intro STATE'4.
      destruct STATE'4 as [invst'4 STATE'4]; des.
      clears invst'3.

      {
       unfold HIDDEN_GOAL.
        exists locals2_tgt, 0%nat, assnmem'3. splits; ss.
        - etransitivity; eauto. etransitivity; eauto.
        - esplits; eauto.
          { right. apply CIH. econs; eauto.
            - eapply implies_sound; eauto.
          }
      }
Unshelve.
all: try ss.
Qed.

(* TODO: move to better position? with init_invvmem in SimModule *)
(* I think the laziest point (here) may make sense in this case .. *)
Definition init_invst: AssnState.Rel.t :=
  (AssnState.Rel.mk (AssnState.Unary.mk [] []) (AssnState.Unary.mk [] [])).

Lemma initLocals_type_spec
      TD args argvs lc
      a ty
      (IN:In a (getArgsIDs args))
      (ARGTY: lookupTypViaIDFromArgs args a = Some ty)
      (INIT:initLocals TD args argvs = Some lc)
  : exists gv : GenericValue,
    ((exists gv0, fit_gv TD ty gv0 = Some gv) \/ gundef TD ty = Some gv) /\
    lookupAL GenericValue lc a = Some gv.
Proof.
  revert lc argvs IN ARGTY INIT.
  induction args; ss.
  i. unfold initLocals in INIT. ss.
  des_ifs; try (by esplits; eauto using lookupAL_updateAddAL_eq);
    by rewrite <- lookupAL_updateAddAL_neq; eauto;
      exploit IHargs; eauto; ss; des; congruence.
Qed.

Lemma function_entry_args_sound
      conf st a args ty argvs lc invst
      (INARG: In a (getArgsIDs args))
      (ARGTY: lookupTypViaIDFromArgs args a = Some ty)
      (INITLOCALS_SRC : initLocals (CurTargetData conf) args argvs = Some lc)
      (LOCALS: st.(EC).(Locals) = lc)
  : AssnState.Unary.sem_lessdef conf st invst
                               (Exprs.Expr.value (Exprs.ValueT.const (const_undef ty)),
                                Exprs.Expr.value (Exprs.ValueT.id (Exprs.Tag.physical, a))).
Proof.
  ii. ss.
  exploit opsem_props.OpsemProps.initLocals_spec; eauto. i. des.
  esplits.
  - unfold AssnState.Unary.sem_idT. ss. subst. eauto.
  - exploit initLocals_type_spec; eauto. i. des.
    + clarify. eapply fit_gv_undef; eauto.
    + clarify. unfold const2GV, _const2GV in *.
      des_ifs. unfold cgv2gv. apply GVs.lessdef_refl.
Qed.

Lemma function_entry_args_aux
      e1 e2 args
      (IN : Exprs.ExprPairSet.In (e1, e2) (Assertion.add_Args_IDs args))
  : exists a ty, In a (getArgsIDs args) /\
                 lookupTypViaIDFromArgs args a = Some ty /\
                 e1 = Exprs.Expr.value (Exprs.ValueT.const (const_undef ty)) /\
                 e2 = Exprs.Expr.value (Exprs.ValueT.id (Exprs.Tag.physical, a)).
Proof.
  unfold Assertion.add_Args_IDs in *.
  induction (getArgsIDs args) as [|a al]; simpl in *.
  - apply Exprs.ExprPairSetFacts.empty_iff in IN. contradiction.
  - destruct (lookupTypViaIDFromArgs args a) eqn:ARGTY.
    + apply Exprs.ExprPairSetFacts.add_iff in IN. des.
      * inv IN.
        exploit Exprs.ExprPair.compare_leibniz; eauto. inversion 1.
        esplits; eauto.
      * apply IHal in IN. des. esplits; eauto.
    + apply IHal in IN. des. esplits; eauto.
Qed.

Lemma function_entry_gids_aux
      e1 e2 prods
      (IN : Exprs.ExprPairSet.In (e1, e2) (Assertion.add_Gvar_IDs prods))
  : exists gv id ty, In (product_gvar gv) prods /\
                     (id = getGvarID gv) /\
                     (lookupTypViaGIDFromProducts prods id = Some (typ_pointer ty)) /\
                     e1 = Exprs.Expr.value (Exprs.ValueT.const (const_undef (typ_pointer ty))) /\
                     e2 = Exprs.Expr.value (Exprs.ValueT.const (const_gid ty id)).
Proof.
  unfold Assertion.add_Gvar_IDs in *.
  remember (Assertion.getGvarIDs prods) as gvars eqn:HGVARS.
  assert (GVARS_SPEC: forall x, In x gvars -> exists gv, In (product_gvar gv) prods /\ getGvarID gv = x).
  { i. unfold Assertion.getGvarIDs in HGVARS. exploit filter_map_inv.
    - subst; eauto.
    - i. des. des_ifs. esplits; eauto. }
  clear HGVARS.
  induction gvars as [|g gl]; simpl in *.
  - apply Exprs.ExprPairSetFacts.empty_iff in IN. contradiction.
  - destruct (lookupTypViaGIDFromProducts prods g) as [ty|] eqn:ARGTY.
    + destruct ty; try by apply IHgl; eauto; i; apply GVARS_SPEC; intuition.
      apply Exprs.ExprPairSetFacts.add_iff in IN. des.
      * exploit Exprs.ExprPair.compare_leibniz; eauto. inversion 1.
        exploit (GVARS_SPEC g); eauto.
        i. des. clarify. esplits; eauto.
      * apply IHgl; eauto.
    + apply IHgl; eauto.
Qed.

Lemma function_entry_gids_sound
      conf lo ndt
      st ty invst prods gv x
      (SYSTEM: conf.(CurSystem) = [module_intro lo ndt prods])
      (WF: OpsemPP.wf_Config conf)
      (IN_PROD: In (product_gvar gv) prods)
      (ID: getGvarID gv = x)
      (GID_TY: lookupTypViaGIDFromProducts prods x = Some (typ_pointer ty))
  : AssnState.Unary.sem_lessdef conf st invst
                               ((Exprs.Expr.value
                                   (Exprs.ValueT.const (const_undef (typ_pointer ty)))),
                                (Exprs.Expr.value (Exprs.ValueT.const (const_gid ty x)))).
Proof.
  subst. ii. ss.
  unfold OpsemPP.wf_Config in WF.
  destruct conf as [sys TD curprods gl ft]. ss. destruct TD as [los nts].
  destruct WF as [WF_NAMEDT [WF_GLOBAL [WF_SYSTEM WF_MIN]]].
  exploit (WF_GLOBAL (getGvarID gv) (typ_pointer ty)).
  { clarify. inv WF_SYSTEM. ss. des. des_ifs. }
  intros (gv_wf & sz_wf & LOOKUP_GL & TYSIZE & ZDIV & CHUNK).
  i. des.
  esplits; eauto.
  { unfold const2GV. ss. des_ifs. }
  unfold cgv2gv.
  unfold gv_chunks_match_typ in *. ss.
  unfold const2GV, cgv2gv in *. ss. clarify.
  destruct gv_wf as [|[v ch] gv_wf].
  { inversion CHUNK. }
  destruct gv_wf; [|inv CHUNK; match goal with [H:Forall2 _ _ _ |- _] => inv H end].
  inv CHUNK. match goal with [H:vm_matches_typ _ _ |- _] => inv H end.
  ss. clarify.

  econs; eauto; [|econs].
  ss. splits; ss. i. destruct v; ss.
  des.
  destruct (Nat.eq_dec wz 31); ss. clarify.
  destruct (zle _ _); ss.
  destruct (zlt _ _); ss.
Qed.

Lemma function_entry_inv_sound
      conf_src lo_src ndt_src prods_src
      conf_tgt lo_tgt ndt_tgt prods_tgt
      (CONF: inject_conf conf_src conf_tgt)
      (WF_CONF_SRC: wf_ConfigI conf_src)
      (WF_CONF_TGT: wf_ConfigI conf_tgt)
      (SYSTEM_SRC: conf_src.(CurSystem) = [module_intro lo_src ndt_src prods_src])
      (SYSTEM_TGT: conf_tgt.(CurSystem) = [module_intro lo_tgt ndt_tgt prods_tgt])
      assnmem
      st_src st_tgt
      (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem)
      (INITST: st_src.(EC).(Allocas) = [] /\ st_tgt.(EC).(Allocas) = [])
      args args_src args_tgt
      (INJECT_ARGS: list_forall2 (genericvalues_inject.gv_inject
                                    (AssnMem.Rel.inject assnmem)) args_src args_tgt)
      (VALID_SRC: List.Forall (memory_props.MemProps.valid_ptrs (Memory.Mem.nextblock st_src.(Mem))) args_src)
      (VALID_TGT: List.Forall (memory_props.MemProps.valid_ptrs (Memory.Mem.nextblock st_tgt.(Mem))) args_tgt)
      (INITLOCALS_SRC: initLocals (CurTargetData conf_src) args args_src =
                       Some st_src.(EC).(Locals))
      (INITLOCALS_TGT: initLocals (CurTargetData conf_tgt) args args_tgt =
                       Some st_tgt.(EC).(Locals))
      (INJECT_LOCALS: fully_inject_locals assnmem.(AssnMem.Rel.inject) st_src.(EC).(Locals) st_tgt.(EC).(Locals))
      (WF_SRC: wf_EC st_src.(EC) /\ wf_fdef conf_src.(CurSystem) conf_src st_src.(EC).(CurFunction))
      (WF_TGT: wf_EC st_tgt.(EC) /\ wf_fdef conf_tgt.(CurSystem) conf_tgt st_tgt.(EC).(CurFunction))
      (* TODO: conf_src.(CurSystem) != [(module_of_conf conf_src)] *)
      (* WF condition for this? which is conceptually right? *)
      (* Anyway, let's do this lazy.. *)
  :
  <<SEM: AssnState.Rel.sem conf_src conf_tgt
                          st_src st_tgt init_invst assnmem
                          (Assertion.function_entry_inv args args prods_src prods_tgt)>>
.
Proof.
  (* inject_locals is reduced from below *)
  (* proof.Inject.locals_init *)
  destruct st_src, st_tgt; ss.
  destruct EC0, EC1; ss.
  des; clarify.
  econs; ss; eauto.
  - econs; ss; eauto.
    + intros [e1 e2] IN. apply Exprs.ExprPairSetFacts.union_iff in IN. des.
      * (* ARGS *)
        exploit function_entry_args_aux; eauto.
        i. des. subst. eapply function_entry_args_sound; eauto.
      * (* GID *)
        exploit function_entry_gids_aux; eauto.
        i. des; subst. eapply function_entry_gids_sound; eauto.
        eapply wf_ConfigI_spec in WF_CONF_SRC; eauto.
    + ii. exfalso. eapply AtomSetFacts.empty_iff; eauto.
    + ii. exfalso. eapply Exprs.IdTSetFacts.empty_iff; eauto.
    + (* wf_lc *)
      inv MEM.
      clear SRC TGT INJECT FUNTABLE.
      inv WF.
      clear Hno_overlap Hmap1 Hmap2
            (* mi_freeblocks *)
            mi_mappedblocks mi_range_block mi_bounds mi_globals.
      clear_tac. unfold initLocals in *.
      (* REMARK: Originally, we proved this by using wasabi, injection implies valid *)
      (* However, this logic no longer holds in tgt, so validitiy condition of args became needed *)
      (* This is current proof, same logic as tgt *)
      eapply initLocals_preserves_valid_ptrs; eauto.
    + (* diffblock unique parent *)
      inv MEM. clear TGT INJECT FUNTABLE.
      inv SRC.
      clear MEM_PARENT UNIQUE_PARENT_MEM UNIQUE_PARENT_GLOBALS NEXTBLOCK NEXTBLOCK_PARENT.
      ii.
      eapply sublist_In in UNIQUE_PRIVATE_PARENT; eauto.
      expl PRIVATE_PARENT.
      expl fully_inject_locals_spec.
      rewrite PTR in *. unfold lift2_option in *.
      des_ifs.
      unfold AssnMem.private_block in *. des.
      clear - PRIVATE_PARENT0 ING fully_inject_locals_spec.
      ginduction fully_inject_locals_spec; ii; ss.
      rewrite GV2blocks_cons in ING.
      apply in_app in ING. des.
      { destruct v1; ss. des; ss. clarify.
        apply PRIVATE_PARENT0; eauto.
        ii. inv H; clarify.
      }
      eauto.
  - (* tgt. same with src *)
    (* exactly copied from above *)
    econs; ss; eauto.
    + intros [e1 e2] IN. apply Exprs.ExprPairSetFacts.union_iff in IN. des.
      * (* ARGS *)
        exploit function_entry_args_aux; eauto.
        i. des. subst. eapply function_entry_args_sound; eauto.
      * (* GID *)
        exploit function_entry_gids_aux; eauto.
        i. des; subst. eapply function_entry_gids_sound; eauto.
        eapply wf_ConfigI_spec in WF_CONF_TGT; eauto.
    + ii. exfalso. eapply AtomSetFacts.empty_iff; eauto.
    + ii. exfalso. eapply Exprs.IdTSetFacts.empty_iff; eauto.
    + (* wf_lc *)
      inv MEM.
      clear SRC TGT INJECT FUNTABLE.
      inv WF.
      clear Hno_overlap Hmap1 Hmap2
            (* mi_freeblocks *)
            mi_freeblocks mi_range_block mi_bounds mi_globals.
      clear_tac. unfold initLocals in *.
      eapply initLocals_preserves_valid_ptrs; eauto.
    + (* diffblock unique parent *)
      inv MEM. clear SRC INJECT FUNTABLE.
      inv TGT.
      clear MEM_PARENT UNIQUE_PARENT_MEM UNIQUE_PARENT_GLOBALS NEXTBLOCK NEXTBLOCK_PARENT.
      rewrite TGT_NOUNIQ. ii; ss.
  - ii. clear NOTIN.
    destruct id0; ss.
    destruct t; ss.
    unfold AssnState.Unary.sem_idT in *. ss.
    eapply fully_inject_locals_inject_locals; eauto.
  - econs; eauto.
Qed.

Lemma init_fdef_wf_EC
      conf fdef args ec
      (INIT: init_fdef conf fdef args ec)
  :
    <<WF: wf_EC ec>>
.
Proof.
  inv INIT; ss.
  des_ifs.
  econs; ss; eauto.
  - apply orb_true_iff. left. unfold blockEqB. unfold sumbool2bool. des_ifs.
  - unfold get_cmds_from_block. ss. apply sublist_refl.
  - unfold terminatorEqB. unfold sumbool2bool. des_ifs.
Qed.

Lemma valid_init
      m_src m_tgt
      conf_src conf_tgt
      stack0_src stack0_tgt
      fdef_src fdef_tgt
      fdef_hint
      args_src args_tgt
      mem_src mem_tgt
      inv idx
      ec_src
      (WF_SRC: wf_ConfigI conf_src)
      (WF_TGT: wf_ConfigI conf_tgt)
      (SYSTEM_SRC: conf_src.(CurSystem) = [m_src])
      (SYSTEM_TGT: conf_tgt.(CurSystem) = [m_tgt])
      (FDEF: valid_fdef m_src m_tgt fdef_src fdef_tgt fdef_hint)
      (ARGS: list_forall2 (genericvalues_inject.gv_inject inv.(AssnMem.Rel.inject)) args_src args_tgt)
      (VALID_SRC: List.Forall (memory_props.MemProps.valid_ptrs (Memory.Mem.nextblock mem_src)) args_src)
      (VALID_TGT: List.Forall (memory_props.MemProps.valid_ptrs (Memory.Mem.nextblock mem_tgt)) args_tgt)
      (MEM: AssnMem.Rel.sem conf_src conf_tgt mem_src mem_tgt inv)
      (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt)
      (INIT_SRC: init_fdef conf_src fdef_src args_src ec_src)
  :
  exists ec_tgt,
    (<<INIT_TGT: init_fdef conf_tgt fdef_tgt args_tgt ec_tgt>>) /\
    (forall (WF_SRC: wf_ConfigI conf_src /\ wf_StateI conf_src (mkState ec_src stack0_src mem_src))
            (WF_TGT: wf_ConfigI conf_tgt /\ wf_StateI conf_tgt (mkState ec_tgt stack0_tgt mem_tgt))
            (WF_FDEF_SRC: wf_fdef conf_src.(CurSystem) conf_src ec_src.(CurFunction))
            (WF_FDEF_TGT: wf_fdef conf_tgt.(CurSystem) conf_tgt ec_tgt.(CurFunction))
      ,
        <<SIM:
          valid_state_sim
            conf_src conf_tgt
            stack0_src stack0_tgt
            inv idx
            (mkState ec_src stack0_src mem_src)
            (mkState ec_tgt stack0_tgt mem_tgt)>>).
Proof.
  expl init_fdef_wf_EC. rename init_fdef_wf_EC0 into WF_EC_SRC. (* TODO: make "expl into" *)
  inv INIT_SRC. unfold valid_fdef in FDEF. simtac.
  exploit locals_init; eauto; [by apply CONF|apply MEM|]. i. des.
  generalize FDEF. i.
  unfold forallb2AL in FDEF0. ss. apply andb_true_iff in FDEF0. des.
  do 10 simtac0.
  unfold proj_sumbool in *. des_ifs_safe ss. clarify.
  assert(VALID_TERM_INFRULES: exists infrules,
            valid_terminator fdef_hint
                             (Infrules.apply_infrules
                                (module_intro layouts5 namedts5 products5)
                                (module_intro layouts0 namedts0 products0)
                                infrules t)
                             (module_intro layouts5 namedts5 products5)
                             (module_intro layouts0 namedts0 products0)
                             ((l0, stmts_intro ps' cs' tmn') :: b0)
                             ((l0, stmts_intro phinodes5 cmds5 terminator5) :: b1)
                             l0 tmn' terminator5).
  { simtac.
    - exists nil. assumption.
    - eexists; eassumption.
  }
  clear COND4. des.

  i. des.

  eexists.
  apply dependent_split.
  - econs; eauto; ss.
  - intros INIT_TGT ? ? ? ? . des.
    expl init_fdef_wf_EC. rename init_fdef_wf_EC0 into WF_EC_TGT. clear INIT_TGT.
    econs; eauto.
    { ss.
      repeat
        (try match goal with
             | [|- is_true (if ?c then _ else _)] =>
               let COND := fresh "COND" in
               destruct c eqn:COND
             end;
         simtac).
      { match goal with
        | [H: proj_sumbool (fheader_dec ?a ?a) = false |- _] => destruct (fheader_dec a a); ss
        end.
      }
      apply andb_true_iff. splits; [|by eauto].
      repeat
        (try match goal with
             | [|- (if ?c then _ else _) = true] =>
               let COND := fresh "COND" in
               destruct c eqn:COND
             end;
         simtac).
      { match goal with
        | [H: proj_sumbool (id_dec ?a ?a) = false |- _] => destruct (id_dec a a); ss
        end.
      }
      des_ifs_safe ss. clarify.
    }
    {
      eapply implies_sound; eauto.
      clear FDEF FDEF1. clear_tac.
      clear COND VALID_TERM_INFRULES. clear_tac.
      inv CONF. unfold is_empty in *. des_ifs.
      clear COND0 COND3. clear_tac.
      eapply function_entry_inv_sound; eauto.
    }
Qed.

Lemma valid_sim_fdef
      m_src m_tgt
      conf_src conf_tgt
      fdef_src fdef_tgt
      fdef_hint
      (SYSTEM_SRC: conf_src.(CurSystem) = [m_src])
      (SYSTEM_TGT: conf_tgt.(CurSystem) = [m_tgt])
      (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt)
      (FDEF: valid_fdef m_src m_tgt fdef_src fdef_tgt fdef_hint)
      (WF_SRC: wf_ConfigI conf_src)
      (WF_TGT: wf_ConfigI conf_tgt)
      (WF_FDEF_SRC: wf_fdef conf_src.(CurSystem) conf_src fdef_src)
      (WF_FDEF_TGT: wf_fdef conf_tgt.(CurSystem) conf_tgt fdef_tgt)
  :
  sim_fdef conf_src conf_tgt fdef_src fdef_tgt.
Proof.
  ii.
  assert(WF: wf_EC ec0_src).
  { inv SRC. ss.
    des_ifs.
    econs; ss; eauto.
    - apply orb_true_iff. left. unfold blockEqB. unfold sumbool2bool. des_ifs.
    - unfold get_cmds_from_block. ss. apply sublist_refl.
    - unfold terminatorEqB. unfold sumbool2bool. des_ifs.
  }
  exploit valid_init; try exact CONF; eauto.
  intro VALID_INIT. des.
  esplits; eauto. i.
  specialize (VALID_INIT0 WF_SRC0).
  specialize (VALID_INIT0 WF_TGT0).
  exploit VALID_INIT0.
  { rpapply WF_FDEF_SRC. inv SRC. ss. }
  { rpapply WF_FDEF_TGT. inv INIT_TGT. ss. }
  intro VALID_INIT; des.
  apply valid_sim; eauto.
Grab Existential Variables.
  { exact 0%nat. }
Qed.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coq.Program.Basics.
Require Import Coq.Classes.Morphisms.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcertx.common.MemoryX.
Require Import liblayers.lib.Functor.
Require Import liblayers.lib.Monad.
Require Import liblayers.lib.Lens.
Require Export liblayers.lib.Lift.
Require Export liblayers.compcertx.LiftMem.

(** * Prerequisites *)

(** We're going to lift the memory operations and theorems from a base
  type [bmem] to a "richer" type [mem], which contains [bmem] as a
  component. Formally, this means that we have a [Lens mem bmem] which
  provides us with well-behaved accessors to the [bmem] component
  inside of [mem]. While this is enough to lift most of the memory
  operations and theorems, we also need to know the value of
  the empty memory state of the richer type [mem]; indeed there's no
  way we would be able to construct that just from [empty : bmem].
  However, the simpler memory state contained within this empty [mem]
  should correspond to the empty [bmem] from the base memory states. *)

Section LIFTMEM.
  Context mem bmem `{Hmem: LiftMemoryModel mem bmem}.

  Local Arguments fmap : simpl never.

  Global Instance liftmemx_spec:
    Mem.MemoryModelX bmem -> Mem.MemoryModelX mem.
  Proof.
    intros Hbmem; split.
    typeclasses eauto.
    lift π Mem.extends_extends_compose.
    lift π Mem.inject_extends_compose.
    lift π Mem.inject_compose.
    lift π Mem.extends_inject_compose.
    lift π Mem.inject_neutral_incr.
    lift π Mem.free_inject_neutral.
    lift π Mem.drop_perm_right_extends.
    lift π Mem.drop_perm_parallel_extends.
    lift π Mem.storebytes_inject_neutral.
    {
      lift_partial π Mem.free_range.
      destruct Hf; try tauto.
      right; eauto using lens_same_context_eq, eq_sym.
    }
    {
      lift_partial π Mem.storebytes_empty.
      eauto using lens_same_context_eq, eq_sym.
    }
  Qed.
End LIFTMEM.


(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

  CFGV 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, or
  (at your option) any later version.

  CFGV is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with CFGV.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/CFGVLFMTP2014/
  Authors: Abhishek Anand & Vincent Rahli

*)
Require Export Term.
Set Implicit Arguments.

Inductive VarSym : Set :=  tmVSym | tyVSym.
Inductive TNonTerminal : Set := term | type .
Definition vSubstType (vc : VarSym) : TNonTerminal :=
match vc with
  tmVSym => term  | tyVSym => type
end.

Inductive Terminal :Set := .
Inductive PNonTerminal : Set := | lasgn | asgn | asgnRhs.

Inductive PatProd : Set :=  | aNil | aCons | asgnP.

Inductive EmbedProd : Set := | asgnRhsE.

Definition EmbedLhsRhs  (_: EmbedProd)
: (PNonTerminal * TNonTerminal) := (asgnRhs, term).

Notation inrr := (fun x => inr (inr x)).
Notation inlr := (fun x => inl (inr x)).
Notation inll := (fun x => inl (inl x)).

(**
Definition ppLhsRhs (p:PatProd) :
 (PNonTerminal * list (PNonTerminal+ (Terminal + VarSym))):=
match p with
|aNil => (lasgn,[])
|aCons => (lasgn, [inl lasgn, inl asgn])
|asgnP  => (asgn, [inrr vsym, inl asgnRhs])
end.

Inductive TermProd : Set := | app | lam | letr.

Definition tpLhsRhs (p:TermProd) :
 (TNonTerminal *
    list ((PNonTerminal + VarSym) + (Terminal + TNonTerminal))):=
match p with
|app => (term,[inrr term, inrr term])
|lam => (term, [inlr vsym, inrr term])
|letr  => (term, [inll lasgn, inrr term])
end.

Definition bindingInfo (p:TermProd) : list (nat * nat) :=
match p with
|app => []
|lam => [(0,1)]
|letr  => [(0,0),(0,1)]
end.

Definition letrecCFGV : CFGV.
eapply Build_CFGV
      with   (VarSym := VarSym)
             (Terminal := Terminal)
             (PNonTerminal := PNonTerminal)
             (TNonTerminal := TNonTerminal)
             (PatProd := PatProd)
             (TermProd := TermProd)
             (tpLhsRhs := tpLhsRhs)
             (bindingInfo := bindingInfo)
             (EmbedProd := EmbedProd).
  - intro. exact NVarSpec.
  - intro. intro. destruct x. destruct y. auto.
  - exact vSubstType.
  - intro H. contradiction.
  - exact ppLhsRhs.
  - exact EmbedLhsRhs.
  - admit.
  - intro. intro. destruct x. destruct y. auto.
  - intro H. contradiction.
  - intro. intro. destruct x. destruct y. auto.
  - intro. intro. destruct x; destruct y;
    try (left; cpx; fail); (try right; introv Hc; inverts Hc ; cpx).
  - intro. intro. destruct x; destruct y;
    try (left; cpx; fail); (try right; introv Hc; inverts Hc ; cpx).
  - intro. intro. destruct x; destruct y;
    try (left; cpx; fail); (try right; introv Hc; inverts Hc ; cpx).
  - intro. intro. destruct x; destruct y;
    try (left; cpx; fail); (try right; introv Hc; inverts Hc ; cpx).
Defined.

Definition letrxxx : @Term letrecCFGV (@gsymTN letrecCFGV term).
Proof.
  apply (@tnode letrecCFGV letr). apply (mpcons).
  - simpl. apply (@pnode letrecCFGV aCons); simpl.
    apply (mpcons); simpl.
    + apply (@pnode letrecCFGV aNil). simpl. apply mnil.
    + apply (mpcons); [| apply mnil].
      apply (@pnode letrecCFGV asgnP). simpl.
      apply (mpcons).
      * apply pvleaf. simpl. exact nvarx.
      * apply (mpcons);[| apply mnil].
        apply (@embed letrecCFGV asgnRhsE). simpl.
        apply (@vleaf letrecCFGV vsym).
        exact nvarx.
  - simpl. apply (mtcons);[| apply mnil].
    apply (@vleaf letrecCFGV vsym).
    exact nvarx.
Defined.
*)


Require Import VST.progs.prod.
Require Import VST.floyd.proofauto.

Definition bound_int (v : val) (b : Z) :=
  match v with
  | Vint i => -b < (Int.signed i) < b
  | _ => False
  end.

Definition product a b := map (fun vp => Val.mul (fst vp) (snd vp)) (combine a b).

Definition product_spec :=
  DECLARE _product
  WITH b0 : val, sh : share, orig_a : list val, orig_b : list val, out0 : val, a0 : val
  PRE [_out OF (tptr tlong), _a OF (tptr tint), _b OF (tptr tint)]
    PROP (writable_share sh;
          length orig_a = 10%nat;
          length orig_b = 10%nat;
          forall i, 0 <= i < 10 -> is_long (Znth i orig_a Vundef);
          forall i, 0 <= i < 10 -> is_long (Znth i orig_b Vundef);
          forall i, 0 <= i < 10 -> bound_int (Znth i orig_a Vundef) 134217728;
          forall i, 0 <= i < 10 -> bound_int (Znth i orig_b Vundef) 134217728)
    LOCAL (temp _out out0;
           temp _a a0;
           temp _b b0;
           `isptr (eval_id _out);
           `isptr (eval_id _a);
           `isptr (eval_id _b))
    SEP (`(data_at sh (tarray tlong 10) orig_a a0);
         `(data_at sh (tarray tlong 10) orig_b b0);
         `(data_at_ sh (tarray tlong 10) out0))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (`(data_at sh (tarray tlong 10) orig_a a0);
         `(data_at sh (tarray tlong 10) orig_b b0);
         `(data_at sh (tarray tlong 10) (product orig_a orig_b) out0)).

Local Open Scope logic.

Definition Vprog : varspecs := nil.
Definition Gprog : funspecs :=   ltac:(with_library prog [product_spec]).

Lemma cast_l2i : forall (x : val), is_long x -> is_int I32 Signed (force_val (sem_cast_l2i I32 Signed x)).
Proof.
intros.
unfold force_val, sem_cast_l2i.
induction x.
auto.
auto.
Focus 2.
auto.
Focus 2.
auto.
auto.
inversion H.
Qed.

Lemma product_sumarray : semax_body Vprog Gprog f_product product_spec.
Proof.
start_function.
forward.
  entailer!.
  apply cast_l2i.
  apply H2.
  lia.
forward.
  entailer!.
  apply cast_l2i.
  apply H3.
  lia.
forward.
forward.
forward.
Abort.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Constant propagation over RTL.  This is one of the optimizations
  performed at RTL level.  It proceeds by a standard dataflow analysis
  and the corresponding code rewriting. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import Lattice.
Require Import Kildall.
Require Import ConstpropOp.

(** * Static analysis *)

(** The type [approx] of compile-time approximations of values is
  defined in the machine-dependent part [ConstpropOp]. *)

(** We equip this type of approximations with a semi-lattice structure.
  The ordering is inclusion between the sets of values denoted by
  the approximations. *)

Module Approx <: SEMILATTICE_WITH_TOP.
  Definition t := approx.
  Definition eq (x y: t) := (x = y).
  Definition eq_refl: forall x, eq x x := (@refl_equal t).
  Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t).
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t).
  Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}.
  Proof.
    decide equality.
    apply Int.eq_dec.
    apply Float.eq_dec.
    apply Int.eq_dec.
    apply ident_eq.
    apply Int.eq_dec.
  Defined.
  Definition beq (x y: t) := if eq_dec x y then true else false.
  Lemma beq_correct: forall x y, beq x y = true -> x = y.
  Proof.
    unfold beq; intros.  destruct (eq_dec x y). auto. congruence.
  Qed.

  Definition ge (x y: t) : Prop := x = Unknown \/ y = Novalue \/ x = y.

  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge; tauto.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge; intuition congruence.
  Qed.
  Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'.
  Proof.
    unfold eq, ge; intros; congruence.
  Qed.
  Definition bot := Novalue.
  Definition top := Unknown.
  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot; tauto.
  Qed.
  Lemma ge_top: forall x, ge top x.
  Proof.
    unfold ge, bot; tauto.
  Qed.
  Definition lub (x y: t) : t :=
    if eq_dec x y then x else
    match x, y with
    | Novalue, _ => y
    | _, Novalue => x
    | _, _ => Unknown
    end.
  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold lub; intros.
    case (eq_dec x y); intro.
    apply ge_refl. apply eq_refl.
    destruct x; destruct y; unfold ge; tauto.
  Qed.
  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold lub; intros.
    case (eq_dec x y); intro.
    apply ge_refl. subst. apply eq_refl.
    destruct x; destruct y; unfold ge; tauto.
  Qed.
End Approx.

Module D := LPMap Approx.

(** We keep track of read-only global variables (i.e. "const" global
  variables in C) as a map from their names to their initialization
  data. *)

Definition global_approx : Type := PTree.t (list init_data).

(** Given some initialization data and a byte offset, compute a static
  approximation of the result of a memory load from a memory block
  initialized with this data. *)

Fixpoint eval_load_init (chunk: memory_chunk) (pos: Z) (il: list init_data): approx :=
  match il with
  | nil => Unknown
  | Init_int8 n :: il' =>
      if zeq pos 0 then
        match chunk with
        | Mint8unsigned => I (Int.zero_ext 8 n)
        | Mint8signed => I (Int.sign_ext 8 n)
        | _ => Unknown
        end
      else eval_load_init chunk (pos - 1) il'
  | Init_int16 n :: il' =>
      if zeq pos 0 then
        match chunk with
        | Mint16unsigned => I (Int.zero_ext 16 n)
        | Mint16signed => I (Int.sign_ext 16 n)
        | _ => Unknown
        end
      else eval_load_init chunk (pos - 2) il'
  | Init_int32 n :: il' =>
      if zeq pos 0
      then match chunk with Mint32 => I n | _ => Unknown end
      else eval_load_init chunk (pos - 4) il'
  | Init_float32 n :: il' =>
      if zeq pos 0
      then match chunk with
           | Mfloat32 => if propagate_float_constants tt then F (Float.singleoffloat n) else Unknown
           | _ => Unknown
           end
      else eval_load_init chunk (pos - 4) il'
  | Init_float64 n :: il' =>
      if zeq pos 0
      then match chunk with
           | Mfloat64 => if propagate_float_constants tt then F n else Unknown
           | _ => Unknown
           end
      else eval_load_init chunk (pos - 8) il'
  | Init_addrof symb ofs :: il' =>
      if zeq pos 0
      then match chunk with Mint32 => G symb ofs | _ => Unknown end
      else eval_load_init chunk (pos - 4) il'
  | Init_space n :: il' =>
      eval_load_init chunk (pos - Zmax n 0) il'
  end.

(** Compute a static approximation for the result of a load at an address whose
  approximation is known.  If the approximation points to a global variable,
  and this global variable is read-only, we use its initialization data
  to determine a static approximation.  Otherwise, [Unknown] is returned. *)

Definition eval_static_load (gapp: global_approx) (chunk: memory_chunk) (addr: approx) : approx :=
  match addr with
  | G symb ofs =>
      match gapp!symb with
      | None => Unknown
      | Some il => eval_load_init chunk (Int.unsigned ofs) il
      end
  | _ => Unknown
  end.

(** The transfer function for the dataflow analysis is straightforward.
  For [Iop] instructions, we set the approximation of the destination
  register to the result of executing abstractly the operation.
  For [Iload] instructions, we set the approximation of the destination
  register to the result of [eval_static_load].
  For [Icall] and [Ibuiltin], the destination register becomes [Unknown].
  Other instructions keep the approximations unchanged, as they preserve
  the values of all registers. *)

Definition approx_reg (app: D.t) (r: reg) :=
  D.get r app.

Definition approx_regs (app: D.t) (rl: list reg):=
  List.map (approx_reg app) rl.

Definition transfer (gapp: global_approx) (f: function) (pc: node) (before: D.t) :=
  match f.(fn_code)!pc with
  | None => before
  | Some i =>
      match i with
      | Iop op args res s =>
          let a := eval_static_operation op (approx_regs before args) in
          D.set res a before
      | Iload chunk addr args dst s =>
          let a := eval_static_load gapp chunk
                     (eval_static_addressing addr (approx_regs before args)) in
          D.set dst a before
      | Icall sig ros args res s =>
          D.set res Unknown before
      | Ibuiltin ef args res s =>
          D.set res Unknown before
      | _ =>
          before
      end
  end.

(** The static analysis itself is then an instantiation of Kildall's
  generic solver for forward dataflow inequations. [analyze f]
  returns a mapping from program points to mappings of pseudo-registers
  to approximations.  It can fail to reach a fixpoint in a reasonable
  number of iterations, in which case we use the trivial mapping
  (program point -> [D.top]) instead. *)

Module DS := Dataflow_Solver(D)(NodeSetForward).

Definition analyze (gapp: global_approx) (f: RTL.function): PMap.t D.t :=
  match DS.fixpoint (successors f) (transfer gapp f)
                    ((f.(fn_entrypoint), D.top) :: nil) with
  | None => PMap.init D.top
  | Some res => res
  end.

(** * Code transformation *)

(** The code transformation proceeds instruction by instruction.
    Operators whose arguments are all statically known are turned
    into ``load integer constant'', ``load float constant'' or
    ``load symbol address'' operations.  Likewise for loads whose
    result can be statically predicted.  Operators for which some
    but not all arguments are known are subject to strength reduction,
    and similarly for the addressing modes of load and store instructions.
    Conditional branches and multi-way branches are statically resolved
    into [Inop] instructions if possible. Other instructions are unchanged.

    In addition, we try to jump over conditionals whose condition can
    be statically resolved based on the abstract state "after" the
    instruction that branches to the conditional.  A typical example is:
<<
          1: x := 0 and goto 2
          2: if (x == 0) goto 3 else goto 4
>>
    where other instructions branch into 2 with different abstract values
    for [x].  We transform this code into:
<<
          1: x := 0 and goto 3
          2: if (x == 0) goto 3 else goto 4
>>
*)

Definition transf_ros (app: D.t) (ros: reg + ident) : reg + ident :=
  match ros with
  | inl r =>
      match D.get r app with
      | G symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros
      | _ => ros
      end
  | inr s => ros
  end.

Parameter generate_float_constants : unit -> bool.

Definition const_for_result (a: approx) : option operation :=
  match a with
  | I n => Some(Ointconst n)
  | F n => if generate_float_constants tt then Some(Ofloatconst n) else None
  | G symb ofs => Some(Oaddrsymbol symb ofs)
  | S ofs => Some(Oaddrstack ofs)
  | _ => None
  end.

Fixpoint successor_rec (n: nat) (f: function) (app: D.t) (pc: node) : node :=
  match n with
  | O => pc
  | Datatypes.S n' =>
      match f.(fn_code)!pc with
      | Some (Inop s) =>
          successor_rec n' f app s
      | Some (Icond cond args s1 s2) =>
          match eval_static_condition cond (approx_regs app args) with
          | Some b => if b then s1 else s2
          | None => pc
          end
      | _ => pc
      end
  end.

Definition num_iter := 10%nat.

Definition successor (f: function) (app: D.t) (pc: node) : node :=
  successor_rec num_iter f app pc.

Function annot_strength_reduction
     (app: D.t) (targs: list annot_arg) (args: list reg) :=
  match targs, args with
  | AA_arg ty :: targs', arg :: args' =>
      let (targs'', args'') := annot_strength_reduction app targs' args' in
      match ty, approx_reg app arg with
      | Tint, I n => (AA_int n :: targs'', args'')
      | Tfloat, F n => (AA_float n :: targs'', args'')
      | _, _ => (AA_arg ty :: targs'', arg :: args'')
      end
  | targ :: targs', _ =>
      let (targs'', args'') := annot_strength_reduction app targs' args in
      (targ :: targs'', args'')
  | _, _ =>
      (targs, args)
  end.

Function builtin_strength_reduction
      (app: D.t) (ef: external_function) (args: list reg) :=
  match ef, args with
  | EF_vload chunk, r1 :: nil =>
      match approx_reg app r1 with
      | G symb n1 => (EF_vload_global chunk symb n1, nil)
      | _ => (ef, args)
      end
  | EF_vstore chunk, r1 :: r2 :: nil =>
      match approx_reg app r1 with
      | G symb n1 => (EF_vstore_global chunk symb n1, r2 :: nil)
      | _ => (ef, args)
      end
  | EF_annot text targs, args =>
      let (targs', args') := annot_strength_reduction app targs args in
      (EF_annot text targs', args')
  | _, _ =>
      (ef, args)
  end.

Definition transf_instr (gapp: global_approx) (f: function) (apps: PMap.t D.t)
                       (pc: node) (instr: instruction) :=
  let app := apps!!pc in
  match instr with
  | Iop op args res s =>
      let a := eval_static_operation op (approx_regs app args) in
      let s' := successor f (D.set res a app) s in
      match const_for_result a with
      | Some cop =>
          Iop cop nil res s'
      | None =>
          let (op', args') := op_strength_reduction op args (approx_regs app args) in
          Iop op' args' res s'
      end
  | Iload chunk addr args dst s =>
      let a := eval_static_load gapp chunk
                  (eval_static_addressing addr (approx_regs app args)) in
      match const_for_result a with
      | Some cop =>
          Iop cop nil dst s
      | None =>
          let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in
          Iload chunk addr' args' dst s
      end
  | Istore chunk addr args src s =>
      let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in
      Istore chunk addr' args' src s
  | Icall sig ros args res s =>
      Icall sig (transf_ros app ros) args res s
  | Itailcall sig ros args =>
      Itailcall sig (transf_ros app ros) args
  | Ibuiltin ef args res s =>
      let (ef', args') := builtin_strength_reduction app ef args in
      Ibuiltin ef' args' res s
  | Icond cond args s1 s2 =>
      match eval_static_condition cond (approx_regs app args) with
      | Some b =>
          if b then Inop s1 else Inop s2
      | None =>
          let (cond', args') := cond_strength_reduction cond args (approx_regs app args) in
          Icond cond' args' s1 s2
      end
  | Ijumptable arg tbl =>
      match approx_reg app arg with
      | I n =>
          match list_nth_z tbl (Int.unsigned n) with
          | Some s => Inop s
          | None => instr
          end
      | _ => instr
      end
  | _ =>
      instr
  end.

Definition transf_code (gapp: global_approx) (f: function) (app: PMap.t D.t) (instrs: code) : code :=
  PTree.map (transf_instr gapp f app) instrs.

Definition transf_function (gapp: global_approx) (f: function) : function :=
  let approxs := analyze gapp f in
  mkfunction
    f.(fn_id)
    f.(fn_sig)
    f.(fn_params)
    f.(fn_stacksize)
    (transf_code gapp f approxs f.(fn_code))
    f.(fn_entrypoint).

Definition transf_fundef (gapp: global_approx) (fd: fundef) : fundef :=
  AST.transf_fundef (transf_function gapp) fd.

Fixpoint make_global_approx (gapp: global_approx) (gdl: list (ident * globdef fundef unit)): global_approx :=
  match gdl with
  | nil => gapp
  | (id, gl) :: gdl' =>
      let gapp1 :=
        match gl with
        | Gfun f => PTree.remove id gapp
        | Gvar gv =>
            if gv.(gvar_readonly) && negb gv.(gvar_volatile)
            then PTree.set id gv.(gvar_init) gapp
            else PTree.remove id gapp
        end in
      make_global_approx gapp1 gdl'
  end.

Definition transf_program (p: program) : program :=
  let gapp := make_global_approx (PTree.empty _) p.(prog_defs) in
  transform_program (transf_fundef gapp) p.


Require Import Arith.
Require Import ZArith.
Require Import List.
Import ListNotations.

Require Import v1.NeutronTactics.
Require Import v1.Util.
Require Import v1.Multi.
Require Import v1.Expr.

Require Import v1.EpicsTypes.

Require v1.EpicsRecordsBase.

Definition abs_value := option (Z * Z).

(* calc *)
Record calc_abs : Set :=
    CalcAbs {
        calc_A_to_L : multi 12 abs_value;
        calc_VAL : abs_value
    }.

(* calc_out *)
Record calc_out_abs : Set :=
    CalcOutAbs {
        calc_out_A_to_L : multi 12 abs_value;
        calc_out_VAL : abs_value;
        calc_out_PVAL : abs_value;
        calc_out_OVAL : abs_value;
        calc_out_tmp0 : abs_value
    }.

(* str_calc_out *)
Record str_calc_out_abs : Set :=
    StrCalcOutAbs {
        str_calc_out_A_to_L : multi 12 abs_value;
        (* str_calc_out_AA_to_LL : HAVOC; *)
        str_calc_out_VAL : abs_value;
        (* str_calc_out_SVAL : HAVOC; *)
        str_calc_out_PVAL : abs_value;
        str_calc_out_OVAL : abs_value;
        (* str_calc_out_OSV : HAVOC; *)
        str_calc_out_tmp0 : abs_value
    }.

(* array_calc_out *)
Record array_calc_out_abs {n : nat} : Set :=
    ArrayCalcOutAbs {
        array_calc_out_A_to_L : multi 12 abs_value;
        (* array_calc_out_AA_to_LL : HAVOC; *)
        array_calc_out_VAL : abs_value;
        (* array_calc_out_AVAL : HAVOC; *)
        array_calc_out_PVAL : abs_value;
        array_calc_out_OVAL : abs_value;
        (* array_calc_out_OAV : HAVOC; *)
        array_calc_out_tmp0 : abs_value
    }.
Implicit Arguments array_calc_out_abs.

(* fanout *)
Record fanout_abs : Set :=
    FanoutAbs {
    }.

(* ai *)
Record analog_in_abs : Set :=
    AnalogInAbs {
        analog_in_VAL : abs_value
    }.

(* ao *)
Record analog_out_abs : Set :=
    AnalogOutAbs {
        analog_out_VAL : abs_value;
        analog_out_PVAL : abs_value
    }.

(* bi *)
Record binary_in_abs : Set :=
    BinaryInAbs {
        binary_in_VAL : abs_value
    }.

(* bo *)
Record binary_out_abs : Set :=
    BinaryOutAbs {
        binary_out_VAL : abs_value;
    }.

(* mbbo *)
Record mbbo_abs : Set :=
    MBBOAbs {
        mbbo_VAL : abs_value
    }.

(* stringin *)
Record string_in_abs : Set :=
    StringInAbs {
    }.

(* stringout *)
Record string_out_abs : Set :=
    StringOutAbs {
    }.

(* longin *)
Record long_in_abs : Set :=
    LongInAbs {
        long_in_VAL : abs_value
    }.

(* longout *)
Record long_out_abs : Set :=
    LongOutAbs {
        long_out_VAL : abs_value
    }.

(* dfanout *)
Record dfanout_abs : Set :=
    DFanoutAbs {
        dfanout_VAL : abs_value
    }.

(* seq *)
Record seq_abs : Set :=
    SeqAbs {
        seq_DO1_to_DOA : multi 10 abs_value
    }.

(* waveform *)
Record waveform_abs {ty : elem_type} {n : nat} : Set :=
    WaveformAbs {
        (* waveform_VAL : HAVOC *)
    }.
Implicit Arguments waveform_abs.

(* subarray *)
Record subarray_abs {ty : elem_type} {n m : nat} : Set :=
    SubarrayAbs {
        (* subarray_VAL : HAVOC; *)
        (* subarray_tmp0 : HAVOC *)
    }.
Implicit Arguments subarray_abs.

(* asyn *)
Record asyn_abs : Set :=
    AsynAbs {
    }.

Definition set_calc_A_to_L  (r : calc_abs ) x0' : calc_abs  :=
    let '(CalcAbs  x0 x1) := r in
    CalcAbs  x0' x1.

Definition set_calc_VAL  (r : calc_abs ) x1' : calc_abs  :=
    let '(CalcAbs  x0 x1) := r in
    CalcAbs  x0 x1'.

Definition set_calc_out_A_to_L  (r : calc_out_abs ) x0' : calc_out_abs  :=
    let '(CalcOutAbs  x0 x1 x2 x3 x4) := r in
    CalcOutAbs  x0' x1 x2 x3 x4.

Definition set_calc_out_VAL  (r : calc_out_abs ) x1' : calc_out_abs  :=
    let '(CalcOutAbs  x0 x1 x2 x3 x4) := r in
    CalcOutAbs  x0 x1' x2 x3 x4.

Definition set_calc_out_PVAL  (r : calc_out_abs ) x2' : calc_out_abs  :=
    let '(CalcOutAbs  x0 x1 x2 x3 x4) := r in
    CalcOutAbs  x0 x1 x2' x3 x4.

Definition set_calc_out_OVAL  (r : calc_out_abs ) x3' : calc_out_abs  :=
    let '(CalcOutAbs  x0 x1 x2 x3 x4) := r in
    CalcOutAbs  x0 x1 x2 x3' x4.

Definition set_calc_out_tmp0  (r : calc_out_abs ) x4' : calc_out_abs  :=
    let '(CalcOutAbs  x0 x1 x2 x3 x4) := r in
    CalcOutAbs  x0 x1 x2 x3 x4'.

Definition set_str_calc_out_A_to_L  (r : str_calc_out_abs ) x0' : str_calc_out_abs  :=
    let '(StrCalcOutAbs  x0 x1 x2 x3 x4) := r in
    StrCalcOutAbs  x0' x1 x2 x3 x4.

Definition set_str_calc_out_VAL  (r : str_calc_out_abs ) x1' : str_calc_out_abs  :=
    let '(StrCalcOutAbs  x0 x1 x2 x3 x4) := r in
    StrCalcOutAbs  x0 x1' x2 x3 x4.

Definition set_str_calc_out_PVAL  (r : str_calc_out_abs ) x2' : str_calc_out_abs  :=
    let '(StrCalcOutAbs  x0 x1 x2 x3 x4) := r in
    StrCalcOutAbs  x0 x1 x2' x3 x4.

Definition set_str_calc_out_OVAL  (r : str_calc_out_abs ) x3' : str_calc_out_abs  :=
    let '(StrCalcOutAbs  x0 x1 x2 x3 x4) := r in
    StrCalcOutAbs  x0 x1 x2 x3' x4.

Definition set_str_calc_out_tmp0  (r : str_calc_out_abs ) x4' : str_calc_out_abs  :=
    let '(StrCalcOutAbs  x0 x1 x2 x3 x4) := r in
    StrCalcOutAbs  x0 x1 x2 x3 x4'.

Definition set_array_calc_out_A_to_L {n} (r : array_calc_out_abs n) x0' : array_calc_out_abs n :=
    let '(ArrayCalcOutAbs _ x0 x1 x2 x3 x4) := r in
    ArrayCalcOutAbs _ x0' x1 x2 x3 x4.

Definition set_array_calc_out_VAL {n} (r : array_calc_out_abs n) x1' : array_calc_out_abs n :=
    let '(ArrayCalcOutAbs _ x0 x1 x2 x3 x4) := r in
    ArrayCalcOutAbs _ x0 x1' x2 x3 x4.

Definition set_array_calc_out_PVAL {n} (r : array_calc_out_abs n) x2' : array_calc_out_abs n :=
    let '(ArrayCalcOutAbs _ x0 x1 x2 x3 x4) := r in
    ArrayCalcOutAbs _ x0 x1 x2' x3 x4.

Definition set_array_calc_out_OVAL {n} (r : array_calc_out_abs n) x3' : array_calc_out_abs n :=
    let '(ArrayCalcOutAbs _ x0 x1 x2 x3 x4) := r in
    ArrayCalcOutAbs _ x0 x1 x2 x3' x4.

Definition set_array_calc_out_tmp0 {n} (r : array_calc_out_abs n) x4' : array_calc_out_abs n :=
    let '(ArrayCalcOutAbs _ x0 x1 x2 x3 x4) := r in
    ArrayCalcOutAbs _ x0 x1 x2 x3 x4'.

Definition set_analog_in_VAL  (r : analog_in_abs ) x0' : analog_in_abs  :=
    let '(AnalogInAbs  x0) := r in
    AnalogInAbs  x0'.

Definition set_analog_out_VAL  (r : analog_out_abs ) x0' : analog_out_abs  :=
    let '(AnalogOutAbs  x0 x1) := r in
    AnalogOutAbs  x0' x1.

Definition set_analog_out_PVAL  (r : analog_out_abs ) x1' : analog_out_abs  :=
    let '(AnalogOutAbs  x0 x1) := r in
    AnalogOutAbs  x0 x1'.

Definition set_binary_in_VAL  (r : binary_in_abs ) x0' : binary_in_abs  :=
    let '(BinaryInAbs  x0) := r in
    BinaryInAbs  x0'.

Definition set_binary_out_VAL  (r : binary_out_abs ) x0' : binary_out_abs  :=
    let '(BinaryOutAbs  x0) := r in
    BinaryOutAbs  x0'.

Definition set_mbbo_VAL  (r : mbbo_abs ) x0' : mbbo_abs  :=
    let '(MBBOAbs  x0) := r in
    MBBOAbs  x0'.

Definition set_long_in_VAL  (r : long_in_abs ) x0' : long_in_abs  :=
    let '(LongInAbs  x0) := r in
    LongInAbs  x0'.

Definition set_long_out_VAL  (r : long_out_abs ) x0' : long_out_abs  :=
    let '(LongOutAbs  x0) := r in
    LongOutAbs  x0'.

Definition set_dfanout_VAL  (r : dfanout_abs ) x0' : dfanout_abs  :=
    let '(DFanoutAbs  x0) := r in
    DFanoutAbs  x0'.

Definition set_seq_DO1_to_DOA  (r : seq_abs ) x0' : seq_abs  :=
    let '(SeqAbs  x0) := r in
    SeqAbs  x0'.


Require Import Examples.AutoSep Examples.Malloc.

(* Two definitions based on hiding functions inside a new datatype, to avoid confusing our reification tactics *)
Inductive fn := Fn (f : W -> W).
Definition app (f : fn) (x : W) := let (f) := f in f x.

(* What does it mean for a program counter to implement a mathematical function? *)
Definition goodMemo (f : fn) (pc : W) : HProp := fun s m =>
  (ExX : settings * state, Cptr pc #0
    /\ ExX : settings * smem, #0 (s, m)
    /\ Al st : settings * state, AlX : settings * smem, AlX : settings * state,
    (Ex vs, Cptr st#Rp #0
      /\ ![ ^[locals ("rp" :: "x" :: nil) vs 0 st#Sp] * #1 * #2 ] st
      /\ Al st' : state,
      ([| Regs st' Sp = st#Sp /\ Regs st' Rv = app f (sel vs "x") |]
        /\ Ex vs', ![ ^[locals ("rp" :: "x" :: nil) vs' 0 st#Sp] * #1 * #2 ] (fst st, st'))
      ---> #0 (fst st, st'))
    ---> #3 st)%PropX.

Module Type MEMO.
  Parameter memo : fn -> W -> HProp.
  (* Arguments: mathematical function that is implemented, and pointer to private data *)

  Axiom memo_fwd : forall f p,
    memo f p ===> Ex pc, Ex lastIn, Ex lastOut, (p ==*> pc, lastIn, lastOut) * [| lastOut = app f lastIn |] * goodMemo f pc.

  Axiom memo_bwd : forall f p,
    (Ex pc, Ex lastIn, Ex lastOut, (p ==*> pc, lastIn, lastOut) * [| lastOut = app f lastIn|] * goodMemo f pc) ===> memo f p.
End MEMO.

Module Memo : MEMO.
  Definition memo (f : fn) (p : W) : HProp :=
    (Ex pc, Ex lastIn, Ex lastOut, (p ==*> pc, lastIn, lastOut) * [| lastOut = app f lastIn |] * goodMemo f pc)%Sep.

  Theorem memo_fwd : forall (f : fn) p,
    memo f p ===> Ex pc, Ex lastIn, Ex lastOut, (p ==*> pc, lastIn, lastOut) * [| lastOut = app f lastIn |] * goodMemo f pc.
    unfold memo; sepLemma.
  Qed.

  Theorem memo_bwd : forall f p,
    (Ex pc, Ex lastIn, Ex lastOut, (p ==*> pc, lastIn, lastOut) * [| lastOut = app f lastIn|] * goodMemo f pc) ===> memo f p.
    unfold memo; sepLemma.
  Qed.
End Memo.

Import Memo.
Export Memo.

Definition hints : TacPackage.
  prepare memo_fwd memo_bwd.
Defined.

Definition initS : spec := SPEC("f", "in", "out") reserving 7
  Al f,
  PRE[V] goodMemo f (V "f") * [| V "out" = app f (V "in") |] * mallocHeap
  POST[R] memo f R * mallocHeap.

Definition callS : spec := SPEC("m", "x") reserving 4
  Al f,
  PRE[V] memo f (V "m")
  POST[R] [| R = app f (V "x") |] * memo f (V "m").

Definition memoizeM := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS] ]]
  bmodule "memoize" {{
  bfunction "init"("f", "in", "out", "r") [initS]
    "r" <-- Call "malloc"!"malloc"(1)
    [PRE[V, R] R =?> 3
     POST[R'] [| R' = R |] * R ==*> V "f", V "in", V "out" ];;
    "r" *<- "f";;
    "r" <- "r" + 4;;
    "r" *<- "in";;
    "r" <- "r" + 4;;
    "r" *<- "out";;
    Return "r" - 8
  end with bfunction "call"("m", "x", "tmp", "tmp2") [callS]
    "tmp" <-* "m" + 4;;
    If ("x" = "tmp") {
      (* We're in luck!  This call is cached. *)

      "tmp" <-* "m" + 8;;
      Return "tmp"
    } else {
      (* This is a different argument from last time.  Call the function again. *)

      "tmp" <-* "m";;
      "tmp" <-- ICall "tmp"("x")
      [Al f,
        PRE[V, R] [| R = app f (V "x") |] * memo f (V "m")
        POST[R'] [| R' = R |] * memo f (V "m") ];;

      "tmp2" <- "m" + 4;;
      "tmp2" *<- "x";;
      "tmp2" <- "m" + 8;;
      "tmp2" *<- "tmp";;

      Return "tmp"
    }
  end
}}.

Hint Extern 1 (@eq W _ _) =>
  match goal with
    | [ |- context[app] ] => fail 1
    | _ => words
  end.

Hint Extern 1 (interp ?specs (?U ?x ?y)) =>
  match goal with
    | [ H : interp ?specs (?f (?x, ?y)) |- _ ] =>
      equate U (fun x y => f (x, y)); exact H
  end.

Lemma goodMemo_elim : forall specs f pc P st,
  interp specs (![ goodMemo f pc * P ] st)
  -> exists pre, specs pc = Some pre
    /\ exists inv, interp specs (![ inv * P ] st)
      /\ forall st fr rpre,
        interp specs ((Ex vs, Cptr st#Rp (fun x => rpre x)
          /\ ![ ^[locals ("rp" :: "x" :: nil) vs 0 st#Sp] * fr * inv ] st
          /\ Al st' : state,
          ([| Regs st' Sp = st#Sp /\ Regs st' Rv = app f (sel vs "x") |]
            /\ Ex vs', ![ ^[locals ("rp" :: "x" :: nil) vs' 0 st#Sp] * fr * inv ] (fst st, st'))
          ---> rpre (fst st, st'))
        ---> pre st)%PropX.
  Local Opaque locals.
  rewrite sepFormula_eq; repeat (propxFo; repeat (eauto; esplit)).
  specialize (H4 (a, b) (fun a_b => fr (fst a_b) (snd a_b)) rpre).
  Local Transparent locals lift.
  repeat rewrite sepFormula_eq in *.
  assumption.
  Local Opaque locals lift.
Qed.

Lemma goodMemo_intro : forall specs pre inv f pc,
  specs pc = Some pre
  -> (forall (st : ST.settings * state) (fr : hpropB nil)
    (rpre : settings * state -> propX W (settings * state) nil),
    interp specs
    ((Ex vs : vals,
      Cptr (st) # (Rp) (fun x : settings * state => rpre x) /\
      ![^[locals ("rp" :: "x" :: nil) vs 0 (st) # (Sp)] * fr * inv] st /\
      (Al st' : state,
        [| Regs st' Sp = (st) # (Sp) /\
          Regs st' Rv = app f (sel vs "x")|] /\
        (Ex vs' : vals,
          ![^[locals ("rp" :: "x" :: nil) vs' 0 (st) # (Sp)] * fr * inv]
          (fst st, st')) ---> rpre (fst st, st')))%PropX ---> pre st))
  -> himp specs inv (goodMemo f pc).
  intros.
  unfold goodMemo, himp; propxFo.
  imply_simp unf.
  imply_simp unf.
  imply_simp unf.
  eauto.
  imply_simp unf.
  imply_simp unf.
  instantiate (1 := fun p => inv (fst p) (snd p)); apply Imply_refl.
  apply Imply_I; apply interp_weaken.
  propxFo.
  eapply Imply_trans; [ | apply H0 ].
  rewrite sepFormula_eq.
  instantiate (1 := a1).
  instantiate (1 := fun a b => a0 (a, b)).
  apply Imply_refl.
Qed.

Lemma switchUp : forall specs P Q R,
  himp specs P R
  -> himp specs (P * Q)%Sep (Q * R)%Sep.
  intros; etransitivity; [ apply himp_star_comm | ]; apply himp_star_frame; auto; reflexivity.
Qed.

Hint Extern 1 (himp _ _ _) =>
  apply switchUp; eapply goodMemo_intro; eassumption.

(* Alternate VC post-processor that understands indirect function calls *)
Ltac post :=
  PreAutoSep.post;
  try ((* This appears to be an indirect function call.
        * Put the appropriate marker predicate in [H], to trigger use of a lemma about the
        * point-of-view shift from caller to callee. *)
    icall ("x" :: nil);

    (* Trigger symbolic execution early. *)
    evaluate hints;

    (* Move [goodMemo] to the front of its hypothesis and eliminate it. *)
    match goal with
      | [ H : interp _ _ |- _ ] =>
        toFront ltac:(fun P => match P with goodMemo _ _ => idtac end) H;
        apply goodMemo_elim in H; sep_firstorder
    end;

    (* Find and apply the hypothesis explaining the spec of the function pointer. *)
    match goal with
      | [ H : forall x : ST.settings * state, _ |- _ ] =>
        eapply Imply_sound; [ apply H | ]
    end).

(* Main tactic *)
Ltac sep := post; PreAutoSep.sep hints; auto.

Theorem memoizeMOk : moduleOk memoizeM.
  vcgen; abstract sep.
Qed.