Require Import RelationClasses.
Require Import List.

Require Import sflib.
From Paco Require Import paco.

Require Import Basic.
Require Import Axioms.
Require Import Loc.
Require Import Coqlib.
Require Import LibTactics.
Require Import Integers.
Require Import Language.
Require Import ZArith.
Require Import Maps.
Require Import FSets.
Require Import FSetInterface.
Require Import Lattice.
Require Import Event.
Require Import Syntax.
Require Import Semantics.

Require Import Kildall.
Require Import CorrectOpt.

Require Import Language.
Require Import Time.
Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import WFConfig.
Require Import MsgMapping.
Require Import DelaySet.
Require Import LocalSim.
Require Import MemoryMerge.

Require Import CompAuxDef.
Require Import MemoryProps.
Require Import promiseCertifiedAux.
Require Import ConsistentProp.
Require Import Mem_at_eq_lemmas.
Require Import ConsistentStableEnv.
Require Import ConsistentLemmas.

Require Import DetLoop.
Require Import LICM.
Require Import Lib_Step.
Require Import LICMProofMState.
Require Import LICMProofStep.
Require Import CSEProof.

(** * Correctness Proof of Loop Invariant Code Motion *)
(** ** Well-Formed Invariant *)
(** The invariant [I_linv] is well-formed. *)
Lemma WF_I_linv: wf_I I_linv.
Proof.
  unfold wf_I. ii.
  destruct S; ss. des.
  econs; eauto; subst.
  - ii. unfold spec_inj. rewrite MSG.
    inv MEM_LE. exploit COMPLETE; eauto. i. des1.
    do 3 eexists. splits; eauto.
  - ii. unfold spec_inj in *. destruct (Memory.get loc t T_MEM) eqn:Heqe; ss.
    destruct p. destruct t1; ss. inv INJ.
    inv MEM_LE. exploit COMPLETE; eauto.
  - unfold spec_inj; ii.
    destruct (Memory.get loc t1 T_MEM) eqn:Heqe1; ss. destruct p. destruct t0; ss. inv INJ1.
    destruct (Memory.get loc t2 T_MEM) eqn:Heqe2; ss. destruct p. destruct t1; ss. inv INJ2.
    eauto.
Qed.

Lemma I_linv_hold_init
      lo:
  I_linv lo inj_init (Build_Rss TimeMap.bot Memory.init TimeMap.bot Memory.init).
Proof.
  econs; eauto. eapply mem_id_le_identity; eauto.
  split. eapply View.TimeMap.le_PreOrder_obligation_1; eauto.
  eapply functional_extensionality. ii.
  eapply functional_extensionality. ii.
  unfold inj_init, spec_inj.
  des_if; subst. unfold Memory.init. ss.
  unfold Memory.init; ss. unfold Memory.get.
  rewrite Cell.init_get. des_if; eauto.
  ss.
Qed.

Lemma match_state_implies_SI
      inj lo b
      state_tgt lc_tgt sc_tgt mem_tgt
      state_src lc_src sc_src mem_src
      (MATCH_STATE: match_state_linv inj lo b
                                     (Thread.mk rtl_lang state_tgt lc_tgt sc_tgt mem_tgt)
                                     (Thread.mk rtl_lang state_src lc_src sc_src mem_src)):
  SI inj lo (state_tgt, lc_tgt, mem_tgt) (state_src, lc_src, mem_src) (@dset_init nat).
Proof.
  inv MATCH_STATE; ss. do 2 des1.
  assert (INCR_INJ: incr_inj inj inj').
  {
    des; subst. unfold incr_inj; ii; eauto.
    unfold incr_inj; ii; eauto.
  }
  clear ATM_BIT.
  econs; eauto; ss.
  - ii. unfold incr_inj in INCR_INJ. exploit INCR_INJ; eauto.
    ii. subst. unfold spec_inj in H1.
    destruct (Memory.get loc t mem_tgt) eqn:GET_MEM; ss.
    destruct p. destruct t1; ss. inv H1.
    clear - TVIEW_LE H0. inv TVIEW_LE.
    inv CUR. unfold TimeMap.le in RLX.
    specialize (RLX loc).
    auto_solve_time_rel.
  - exists (@dset_init nat). split.
    ii. rewrite dset_gempty in H; ss.
    econs; eauto.
    ii. rewrite dset_gempty in H; ss.
    ii. exploit PRM_INDOM; eauto. ii; des1.
    exploit INCR_INJ; eauto. ii; subst.
    unfold spec_inj in H1.
    destruct (Memory.get loc t mem_tgt) eqn:GET; ss.
    destruct p. destruct t1; ss. inv H1.
    exists to' f val R. split; eauto.
    ii. exploit PRM_INDOM; eauto. ii; des.
    assert (t' = to').
    {
      eapply INCR_INJ in H0. subst.
      exploit spec_inj_identity_inj; eauto.
    }
    subst.
    exists to'. splits; eauto.
  - subst.
    eapply mem_id_le_2_mem_at_eq; eauto.
Qed.

Lemma match_state_linv_implies_sim:
  forall inj lo b
    state_tgt lc_tgt sc_tgt mem_tgt
    state_src lc_src sc_src mem_src
    (MATCH_STATE: match_state_linv inj lo b
                                   (Thread.mk rtl_lang state_tgt lc_tgt sc_tgt mem_tgt)
                                   (Thread.mk rtl_lang state_src lc_src sc_src mem_src)),
    @local_sim_state nat lt rtl_lang I_linv lo inj dset_init b
                     (Thread.mk rtl_lang state_tgt lc_tgt sc_tgt mem_tgt)
                     (Thread.mk rtl_lang state_src lc_src sc_src mem_src).
Proof.
  cofix COFIX_HP.
  introv MATCH_STATE.
  destruct (classic (Local.promise_consistent lc_tgt)) as [PROMS_CONS | NOT_PROM_CONS].
  2: {
    eapply local_sim_state_tgt_not_prm_consistent_intro; eauto.
  }
  assert (CONS_SRC: Local.promise_consistent lc_src).
  {
    clear - MATCH_STATE PROMS_CONS. inv MATCH_STATE; ss.
    clear - PROMS_CONS TVIEW_LE. unfold Local.promise_consistent in *; ss.
    ii. exploit PROMS_CONS; eauto. i.
    inv TVIEW_LE. inv CUR; ss. unfold TimeMap.le in *; ss.
    specialize (RLX loc).
    auto_solve_time_rel.
  }
  destruct (classic (Thread.is_abort (Thread.mk rtl_lang state_src lc_src sc_src mem_src) lo)).
  eapply local_sim_state_abort_intro; eauto.

  eapply local_sim_state_step_intro.
  - eapply match_state_implies_SI; eauto.
  - introv THRD_STEP. splits.
    {
      (* atomic or out step *)
      introv THRD_AT_OR_OUT.
      destruct lc_tgt as (tview_tgt & prm_tgt).
      destruct lc_src as (tview_src & prm_src).
      destruct e_tgt'.
      renames state to state_tgt', local to lc_tgt', sc to sc_tgt', memory to mem_tgt'.
      destruct lc_tgt' as (tview_tgt' & prm_tgt').
      eapply atomic_or_out_step_case in THRD_STEP; eauto. des.
      do 4 eexists.
      split. eauto. split. eauto.
      split. eauto. split. eapply COFIX_HP; eauto.
      eauto.
    }
    {
      (* non-atomic step *)
      introv NA_STEP. destruct te; ss.
      + (* silent *)
        inv THRD_STEP; ss. inv STEP.
        destruct lc_tgt as (tview_tgt & prm_tgt).
        destruct lc_src as (tview_src & prm_src).
        destruct e_tgt'.
        renames state to state_tgt', local to lc_tgt', sc to sc_tgt', memory to mem_tgt'.
        destruct lc_tgt' as (tview_tgt' & prm_tgt').
        eapply silent_step_case in STEP; eauto. des; tryfalse.
        eexists. exists (@dset_init nat) (@dset_init nat) (@dset_init nat).
        splits.
        {
          eapply dset_become_na_read. ii; ss. eauto.
        }
        {
          eapply Thread_na_steps_to_na_steps_dset; eauto.
        }
        {
          econs. introv DSET_GET. rewrite dset_gempty in DSET_GET. tryfalse.
          introv DSET_GET. rewrite dset_gempty in DSET_GET. tryfalse.
        }
        {
          eapply COFIX_HP; eauto.
        }
      + (* non-atomic read *)
        destruct ord; tryfalse.
        inv THRD_STEP; ss. inv STEP.
        destruct lc_tgt as (tview_tgt & prm_tgt).
        destruct lc_src as (tview_src & prm_src).
        destruct e_tgt'.
        renames state to state_tgt', local to lc_tgt', sc to sc_tgt', memory to mem_tgt'.
        destruct lc_tgt' as (tview_tgt' & prm_tgt').
        eapply na_read_step_case in STEP; eauto.
        des.
        eexists. exists (@dset_init nat) (@dset_init nat) (@dset_init nat).
        splits.
        {
          eapply dset_become_na_read. ii; ss. eauto.
        }
        {
          eapply Thread_na_steps_to_na_steps_dset; eauto.
        }
        {
          econs. introv DSET_GET. rewrite dset_gempty in DSET_GET. tryfalse.
          introv DSET_GET. rewrite dset_gempty in DSET_GET. tryfalse.
        }
        {
          eapply COFIX_HP; eauto.
        }
      + (* non-atomic write *)
        destruct ord; tryfalse.
        inv THRD_STEP; ss. inv STEP.
        destruct lc_tgt as (tview_tgt & prm_tgt).
        destruct lc_src as (tview_src & prm_src).
        destruct e_tgt'.
        renames state to state_tgt', local to lc_tgt', sc to sc_tgt', memory to mem_tgt'.
        destruct lc_tgt' as (tview_tgt' & prm_tgt').
        eapply na_write_step_case in STEP; eauto.
        des.
        do 2 eexists. exists (@dset_init nat) (@dset_init nat).
        splits.
        {
          econs; eauto.
        }
        {
          instantiate (2 := 5%nat).
          eapply Operators_Properties.clos_rt1n_step.
          eapply na_steps_dset_write. eapply STEP.
          right. exists to. rewrite dset_remove_add; eauto.
        }
        {
          econs. introv DSET_GET. rewrite dset_gempty in DSET_GET. tryfalse.
          introv DSET_GET. rewrite dset_gempty in DSET_GET. tryfalse.
        }
        {
          eapply COFIX_HP; eauto.
        }
    }
    {
      (* promise step *)
      introv PROM_STEP. ii; subst.
      destruct lc_tgt as (tview_tgt & prm_tgt).
      destruct lc_src as (tview_src & prm_src).
      destruct e_tgt'.
      renames state to state_tgt', local to lc_tgt', sc to sc_tgt', memory to mem_tgt'.
      destruct lc_tgt' as (tview_tgt' & prm_tgt').
      eapply promise_step_case in THRD_STEP; eauto. clear PROM_STEP.
      des.
      do 2 eexists. split. eauto. split. eauto.
      eapply COFIX_HP. eauto.
    }
    {
      (* pf promise step *)
      introv PF_PROM_STEP. ii; subst.
      destruct lc_tgt as (tview_tgt & prm_tgt).
      destruct lc_src as (tview_src & prm_src).
      destruct e_tgt'.
      renames state to state_tgt', local to lc_tgt', sc to sc_tgt', memory to mem_tgt'.
      destruct lc_tgt' as (tview_tgt' & prm_tgt').
      eapply pf_promise_step_case in THRD_STEP; eauto.
      des.
      eexists. split; eauto.
    }
  - ii; subst.
    split.
    {
      clear - MATCH_STATE. inv MATCH_STATE. destruct ATM_BIT.
      destruct H; tryfalse. destruct H; subst. eauto.
    }
    {
      introv RELY INV.
      destruct lc_tgt as (tview_tgt & prm_tgt).
      destruct lc_src as (tview_src & prm_src).
      eapply rely_step_case in RELY; eauto.
    }
  - introv THRD_DONE.
    destruct lc_tgt as (tview_tgt & prm_tgt).
    destruct lc_src as (tview_src & prm_src).
    lets MATCH_STATE': MATCH_STATE.
    eapply done_step_case in MATCH_STATE; eauto. des.
    eexists. exists inj'.
    splits; eauto.
  - introv THRD_ABORT.
    destruct lc_tgt as (tview_tgt & prm_tgt).
    destruct lc_src as (tview_src & prm_src).
    lets MATCH_STATE': MATCH_STATE.
    eapply abort_step_case in MATCH_STATE; eauto.
Qed.

(** ** Correctness of the Loop Invariant Code Motion *)
(** [LInv] is verified. *)
Theorem verif_linv:
  forall code_s code_t lo,
      LInv lo code_s = Some code_t
      ->
      @local_sim nat lt rtl_lang I_linv lo code_t code_s.
Proof.
  ii. econs.
  - (* well_founded index *)
    eapply nat_lt_is_well_founded.
  - (* well-formed I_linv *)
    eapply WF_I_linv; eauto.
  - (* I_linv holds in initial state *)
    eapply I_linv_hold_init; eauto.
  - (* local simulation *)
    introv TGT_INIT.
    unfold Language.init in *; ss.
    unfold State.init in *; ss.
    destruct (code_t ! fid) eqn:FUNC_T; ss. destruct f; ss.
    renames c to cdhp_t. renames f to l_t.
    destruct (cdhp_t ! l_t) eqn:ENTRY_BB_T; ss. inv TGT_INIT; ss.
    unfold LInv in H. inv H.
    rewrite PTree.gmap in FUNC_T. unfold option_map in FUNC_T.
    destruct (code_s ! fid) eqn:SCODE_GET; ss.
    unfold det_loop_invs in FUNC_T.
    rewrite PTree.gmap in FUNC_T. unfold option_map in FUNC_T.
    rewrite SCODE_GET in FUNC_T. inv FUNC_T.
    destruct f as (cdph_s & l_s). renames t to BB_t.
    destruct (cdph_s ! l_s) eqn:CDHP_S.
    {
      renames t to BB_s.
      eapply transC_prop in H0; eauto.
      2: {  instantiate (1 := lo). right. exists BB_s. split; eauto. }
      do 7 des1.
      eexists. split; eauto.
      eapply match_state_linv_implies_sim.
      econs; eauto.
      {
        eapply I_linv_hold_init; eauto.
      }
      {
        econs; eauto. 2: { econs; eauto. }
        des1.
        {
          des1.
          rewrite CDHP_S in GET_BB_S. symmetry in GET_BB_S. inv GET_BB_S.
          eapply EXEC_NOT_PH; eauto.
          unfold det_loop_invs.
          rewrite PTree.gmap. unfold option_map. rewrite SCODE_GET.
          rewrite CDHP_S. eauto.
          ii. eapply reg_in_blk_in_cdhp; eauto.
        }
        {
          des1.
          eapply EXEC_PH with (f := fid); eauto.
          unfold det_loop_invs.
          rewrite PTree.gmap. unfold option_map.
          rewrite SCODE_GET. rewrite CDHP_S. eauto.
        }
      }
      {
        eapply TView.TView.le_PreOrder_obligation_1; eauto.
      }
      {
        ii. rewrite Memory.bot_get in H. ss.
      }
      {
        eapply Local.wf_init; eauto.
      }
      {
        unfold Memory.closed_timemap. ii.
        unfold TimeMap.bot.
        unfold Memory.get, Memory.init.
        rewrite Cell.init_get. des_if; ss; eauto.
        unfold Message.elt. eauto.
      }
      {
        eapply Memory.init_closed; eauto.
      }
      {
        eapply Local.wf_init; eauto.
      }
      {
        unfold Memory.closed_timemap. ii.
        unfold TimeMap.bot.
        unfold Memory.get, Memory.init.
        rewrite Cell.init_get. des_if; ss; eauto.
        unfold Message.elt. eauto.
      }
      {
        eapply Memory.init_closed; eauto.
      }
    }
    {
      ss.
      assert (GET_EMPTY: (PTree.empty positive) ! l_s = None).
      rewrite PTree.gempty. eauto.
      rewrite GET_EMPTY in H0; ss. inv H0. tryfalse.
    }
Qed.

(** Loop invariant code motion optimizer is correct. *)
Theorem correct_licm:
  Correct licm.
Proof.
  unfold licm.
  eapply correct_optimizer_transitive; eauto.
  eapply correct_cse; eauto.
  eapply Verif_implies_Correctness.
  unfolds Verif. intros. exists I_linv nat lt.
  eapply verif_linv; eauto.
Qed.


Require Import FunInd.
Require Import Zwf CoqlibC Maps Integers Floats Lattice.
Require Import Compopts AST.
Require Import Values MemoryC Globalenvs Events.
Require Import Registers RTL.
Require Import sflib.
(** newly added **)
Require Export ValueDomain.
Require Import Skeleton.
Require Import Sound UnreachC.
Require Import ModSem.

(* TODO: remove redundancy, move it to ValueDomain maybe *)
Definition bc2su (bc: block_classification) (ge_nb: block) (nb: block): Unreach.t :=
  Unreach.mk (fun blk => if plt blk nb then block_class_eq (bc blk) BCinvalid else false) ge_nb nb.

Lemma sound_state_sound_args
      bc m0 p skenv_link vs_arg rm (ge: genv)
      (GENV: ge = (SkEnv.revive (SkEnv.project skenv_link (Sk.of_program fn_sig p)) p))
      (ARGS: forall v : val, In v vs_arg -> vmatch bc v Vtop)
      (RO: romatch bc m0 rm)
      (MM: mmatch bc m0 mtop)
      (GE: genv_match bc ge)
      (NOSTK: forall b, bc b <> BCstack)
      fptr_arg sg_arg
      (SIG: exists skd, Genv.find_funct skenv_link fptr_arg = Some skd /\ Sk.get_csig skd = sg_arg):
    args' (bc2su bc ge.(Genv.genv_next) m0.(Mem.nextblock)) (Args.mk fptr_arg vs_arg m0).
Proof.
  { r. s. esplits; eauto.
    - des. unfold Genv.find_funct, Genv.find_funct_ptr in *. des_ifs. ss. r. ii; clarify. ss.
      r in GE. des. specialize (GE0 blk). exploit GE0; eauto.
      { ss. eapply Genv.genv_defs_range; eauto. }
      i; des.
      (* exploit sound_stack_unreach_compat; eauto. intro CPT. des. *)
      (* inv SU. ss. *)
      esplits; eauto.
      + ii. des_ifs. des_sumbool. congruence.
      + inv MM. eapply mmatch_below; eauto. rewrite H; ss.
    - rewrite Forall_forall. i. spcN 1 ARGS. spc ARGS. ii; clarify.
      assert(BCV: bc blk <> BCinvalid).
      { inv ARGS; ss. inv H1; ss. }
      esplits; eauto.
      + u. ii. des_ifs. des_sumbool. ss.
      + inv MM. eapply mmatch_below; eauto.
    - inv MM. econs; eauto.
      + ii. clarify.
        assert(BCV: bc blk <> BCinvalid).
        { u in PUB. ii. rewrite H in *. ss. exploit Mem.perm_valid_block; eauto. i; des. des_ifs. }
        assert(BCV0: bc blk0 <> BCinvalid).
        {
          exploit mmatch_top; eauto.
          (* spcN 0%nat mmatch_top. spc mmatch_top. inv mmatch_top. *)
          intro SM. inv SM.
          specialize (H0 ofs%Z blk0 ofs0 q n).
          exploit H0.
          { eapply Mem_loadbytes_succeeds; et. }
          intro PM.
          inv PM. ss.
        }
        esplits; eauto.
        { u. des_ifs. i; des_sumbool; ss. }
        s. eapply mmatch_below; eauto.
      + u. ii. des_ifs.
      + ss. r in GE. ss. des. r in mmatch_below.
        apply NNPP. ii. apply Pos.lt_nle in H.
        exploit GE0; eauto. i; des.
        exploit mmatch_below; eauto. { rewrite H0; ss. } i; des. xomega.
    - econs; ss; i; des_ifs. r in GE. des. ss. des_sumbool. apply NNPP. ii.
      exploit (GE0 x0); eauto. { xomega. } i; des. congruence.
  }
Qed.

(* copied from above *)
Lemma sound_state_sound_retv
      bc m_ret p skenv_link v_ret rm (ge: genv)
      (GENV: ge = (SkEnv.revive (SkEnv.project skenv_link (Sk.of_program fn_sig p)) p))
      (RES: vmatch bc v_ret Vtop)
      (RO: romatch bc m_ret rm)
      (MM: mmatch bc m_ret mtop)
      (GE: genv_match bc ge)
      (NOSTK: forall b, bc b <> BCstack):
    Sound.retv (bc2su bc ge.(Genv.genv_next) m_ret.(Mem.nextblock)) (Retv.mk v_ret m_ret).
Proof.
  { r. s. esplits; eauto.
    - ii; clarify.
      assert(BCV: bc blk <> BCinvalid).
      { inv RES; ss. inv H0; ss. }
      esplits; eauto.
      + u. ii. des_ifs. des_sumbool. ss.
      + inv MM. eapply mmatch_below; eauto.
    - inv MM. econs; eauto.
      + ii. clarify.
        assert(BCV: bc blk <> BCinvalid).
        { u in PUB. ii. rewrite H in *. ss. exploit Mem.perm_valid_block; eauto. i; des. des_ifs. }
        assert(BCV0: bc blk0 <> BCinvalid).
        {
          exploit mmatch_top; eauto.
          (* spcN 0%nat mmatch_top. spc mmatch_top. inv mmatch_top. *)
          intro SM. inv SM.
          specialize (H0 ofs blk0 ofs0 q n).
          exploit H0.
          { eapply Mem_loadbytes_succeeds; et. }
          intro PM. inv PM. ss.
        }
        esplits; eauto.
        { u. des_ifs. i; des_sumbool; ss. }
        s. eapply mmatch_below; eauto.
      + u. ii. des_ifs.
      + ss. r in GE. ss. des. r in mmatch_below.
        apply NNPP. ii. apply Pos.lt_nle in H.
        exploit GE0; eauto. i; des.
        exploit mmatch_below; eauto. { rewrite H0; ss. } i; des. xomega.
    - econs; eauto; ss; i; des_ifs. des_sumbool.
      rr in GE. des. apply NNPP. ii.
      exploit (GE0 x0); eauto.
      { unfold fundef in *. xomega. }
      i; des. congruence.
  }
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.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*          Low Level Specification                                    *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)
(** This file provide the contextual refinement proof between MBoot layer and MALInit layer*)
Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Asm.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Values.
Require Import Memory.
Require Import Maps.
Require Import AuxLemma.
Require Import FlatMemory.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import RealParams.
Require Import AsmImplLemma.
Require Import GenSem.
Require Import PrimSemantics.
Require Import Conventions.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import compcert.cfrontend.Ctypes.
Require Import AbstractDataType.

Require Import PIPC.

Local Open Scope string_scope.
Local Open Scope error_monad_scope.
Local Open Scope Z_scope.

(** * Definition of the refinement relation*)
Section Refinement.

  Context `{real_params: RealParams}.

  Notation LDATA := RData.

  Notation LDATAOps := (cdata LDATA).

  Inductive elf_load_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sprimcall_sem (mem := mwd LDATAOps):=
  | elf_load_spec_low_intro s (m'0: mwd LDATAOps) n be ofse sig rs b:
      find_symbol s elf_load = Some b ->
      rs PC = Vptr b Int.zero ->
      (exists elf_id, find_symbol s elf_id = Some be) ->
      sig = mksignature (AST.Tint::AST.Tint::nil) None cc_default ->
      extcall_arguments rs m'0 sig (Vptr be ofse :: Vint n :: nil)  ->
      asm_invariant (mem := mwd LDATAOps) s rs m'0 ->
      elf_load_spec_low_step s rs m'0 (rs#RA<- Vundef#PC <- (rs#RA)) m'0.

  Inductive uctx_get_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
    uctx_get_spec_low_intro s (WB: _ -> Prop) (m'0: mwd LDATAOps) b0 n ofs v:
      find_symbol s UCTX_LOC = Some b0 ->
      Mem.load Mint32 m'0 b0 ((Int.unsigned n) * UCTXT_SIZE * 4 + Int.unsigned ofs * 4) = Some (Vint v) ->
      0 <= (Int.unsigned n) < num_proc ->
      is_UCTXT_ptr (Int.unsigned ofs) = false ->
      kernel_mode (snd m'0) ->
      uctx_get_spec_low_step s WB (Vint n :: Vint ofs :: nil) m'0 (Vint v) m'0.

  Inductive uctx_set_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
    uctx_set_spec_low_intro s (WB: _ -> Prop) (m'0 m0: mwd LDATAOps) b0 n ofs v:
      find_symbol s UCTX_LOC = Some b0 ->
      Mem.store Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + Int.unsigned ofs * 4) (Vint v) = Some m0 ->
      0 <= (Int.unsigned n) < num_proc ->
      is_UCTXT_ptr (Int.unsigned ofs) = false ->
      kernel_mode (snd m'0) ->
      uctx_set_spec_low_step s WB (Vint n :: Vint ofs :: Vint v :: nil) m'0 Vundef m0.

  Inductive uctx_set_eip_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
    uctx_set_eip_spec_low_intro s (WB: _ -> Prop) (m'0 m0: mwd LDATAOps) b0 n bf ofs:
      find_symbol s UCTX_LOC = Some b0 ->
      Mem.store Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_EIP * 4) (Vptr bf ofs) = Some m0 ->
      0 <= (Int.unsigned n) < num_proc ->
      (exists fun_id, find_symbol s fun_id = Some bf) ->
      kernel_mode (snd m'0) ->
      uctx_set_eip_spec_low_step s WB (Vint n :: Vptr bf ofs :: nil) m'0 Vundef m0.

  Inductive save_uctx_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
    save_uctx_spec_low_intro s (WB: _ -> Prop)
                             (m0 m1 m2 m3 m4 m5 m6 m7 m8 m9 m10 m11 m12 m13 m14
                                 m15 m16 m17: mwd LDATAOps)
                             u0 u1 u2 u3 u4 u5 u6 u7 u8 u9 u10 u11 u12 u13 u14 u15 u16 b1 n:
      find_symbol s UCTX_LOC = Some b1 ->
      Mem.store Mint32 m0 b1 (UCTXT_SIZE * 4 * n + 4 * U_EDI) (Vint u0) = Some m1 ->
      Mem.store Mint32 m1 b1 (UCTXT_SIZE * 4 * n + 4 * U_ESI) (Vint u1) = Some m2 ->
      Mem.store Mint32 m2 b1 (UCTXT_SIZE * 4 * n + 4 * U_EBP) (Vint u2) = Some m3 ->
      Mem.store Mint32 m3 b1 (UCTXT_SIZE * 4 * n + 4 * U_OESP) (Vint u3) = Some m4 ->
      Mem.store Mint32 m4 b1 (UCTXT_SIZE * 4 * n + 4 * U_EBX) (Vint u4) = Some m5 ->
      Mem.store Mint32 m5 b1 (UCTXT_SIZE * 4 * n + 4 * U_EDX) (Vint u5) = Some m6 ->
      Mem.store Mint32 m6 b1 (UCTXT_SIZE * 4 * n + 4 * U_ECX) (Vint u6) = Some m7 ->
      Mem.store Mint32 m7 b1 (UCTXT_SIZE * 4 * n + 4 * U_EAX) (Vint u7) = Some m8 ->
      Mem.store Mint32 m8 b1 (UCTXT_SIZE * 4 * n + 4 * U_ES) (Vint u8) = Some m9 ->
      Mem.store Mint32 m9 b1 (UCTXT_SIZE * 4 * n + 4 * U_DS) (Vint u9) = Some m10 ->
      Mem.store Mint32 m10 b1 (UCTXT_SIZE * 4 * n + 4 * U_TRAPNO) (Vint u10) = Some m11 ->
      Mem.store Mint32 m11 b1 (UCTXT_SIZE * 4 * n + 4 * U_ERR) (Vint u11) = Some m12 ->
      Mem.store Mint32 m12 b1 (UCTXT_SIZE * 4 * n + 4 * U_EIP) (Vint u12) = Some m13 ->
      Mem.store Mint32 m13 b1 (UCTXT_SIZE * 4 * n + 4 * U_CS) (Vint u13) = Some m14 ->
      Mem.store Mint32 m14 b1 (UCTXT_SIZE * 4 * n + 4 * U_EFLAGS) (Vint u14) = Some m15 ->
      Mem.store Mint32 m15 b1 (UCTXT_SIZE * 4 * n + 4 * U_ESP) (Vint u15) = Some m16 ->
      Mem.store Mint32 m16 b1 (UCTXT_SIZE * 4 * n + 4 * U_SS) (Vint u16) = Some m17 ->
      cid (snd m0) = n ->
      kernel_mode (snd m0) ->
      pg (snd m0) = true ->
      save_uctx_spec_low_step s WB (Vint u0::Vint u1::Vint u2::Vint u3::Vint u4::Vint u5::Vint u6::
                                         Vint u7::Vint u8::Vint u9::Vint u10::Vint u11::Vint u12::Vint u13
                                         ::Vint u14::Vint u15::Vint u16::nil) m0 Vundef m17.

  Inductive restore_uctx_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sprimcall_sem (mem := mwd LDATAOps):=
    restore_uctx_spec_low_intro s v0 v1 v2 v4 v5 v6 v7 v8 v9
                                (m'0: mem) b0 n rs rs' labd labd' sig b:
      find_symbol s restore_uctx = Some b ->
      rs PC = Vptr b Int.zero ->
      find_symbol s UCTX_LOC = Some b0 ->
      Mem.load Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_EDI) = Some v0 ->
      Mem.load Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_ESI * 4) = Some v1 ->
      Mem.load Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_EBP * 4) = Some v2 ->
      Mem.load Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_EBX * 4) = Some v4 ->
      Mem.load Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_EDX * 4) = Some v5 ->
      Mem.load Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_ECX * 4) = Some v6 ->
      Mem.load Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_EAX * 4) = Some v7 ->
      Mem.load Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_ESP * 4) = Some v8 ->
      Mem.load Mint32 m'0 b0 (Int.unsigned n * UCTXT_SIZE * 4 + U_EIP * 4) = Some v9 ->
      rs' = (undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF
                            :: IR ECX :: IR EAX :: RA :: nil)
                        (undef_regs (List.map preg_of destroyed_at_call) rs)) ->
      trapout_spec labd = Some labd' ->
      cid labd = Int.unsigned n ->
      kernel_mode labd ->
      asm_invariant (mem := mwd LDATAOps) s rs (m'0, labd) ->
      high_level_invariant labd ->
      sig = mksignature (AST.Tint::nil) None cc_default ->
      extcall_arguments rs m'0 sig (Vint n ::nil) ->
      restore_uctx_spec_low_step s rs (m'0, labd)
                                 (rs'#Asm.EDI <- v0 #Asm.ESI <- v1 #Asm.EBP <- v2 #Asm.ESP<- v8#Asm.EBX <- v4
                                     #EDX<- v5 #ECX<-v6 #EAX <- v7# PC <- v9) (m'0, labd').

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    Definition uctx_get_spec_low: compatsem LDATAOps :=
      csem uctx_get_spec_low_step (type_of_list_type (Tint32::Tint32::nil)) Tint32.

    Definition uctx_set_spec_low: compatsem LDATAOps :=
      csem uctx_set_spec_low_step (type_of_list_type (Tint32::Tint32::Tint32::nil)) Tvoid.

    Definition uctx_set_eip_spec_low: compatsem LDATAOps :=
      csem uctx_set_eip_spec_low_step (type_of_list_type (Tint32::Tpointer Tvoid noattr::nil)) Tvoid.

    Definition elf_load_spec_low: compatsem LDATAOps :=
      asmsem_withsig elf_load elf_load_spec_low_step (mksignature (AST.Tint::AST.Tint::nil) None cc_default).

    Definition save_uctx_spec_low: compatsem LDATAOps :=
      csem save_uctx_spec_low_step (type_of_list_type
                                      (Tint32::Tint32::Tint32::Tint32::
                                             Tint32::Tint32::Tint32::Tint32::
                                             Tint32::Tint32::Tint32::Tint32::
                                             Tint32::Tint32::Tint32::Tint32::
                                             Tint32::nil)) Tvoid.

    Definition restore_uctx_spec_low: compatsem LDATAOps :=
      asmsem_withsig restore_uctx restore_uctx_spec_low_step (mksignature (AST.Tint::nil) None cc_default).

    (*Definition MSpec : compatlayer LDATAOps :=
           uctx_get ↦ uctx_get_spec_low
           ⊕ uctx_set ↦ uctx_set_spec_low
           ⊕ uctx_set_eip ↦ uctx_set_eip_spec_low
           ⊕ restore_uctx ↦ restore_uctx_spec_low
           ⊕ save_uctx ↦ save_uctx_spec_low
           ⊕ elf_load ↦ elf_load_spec_low.

    Definition MVar : compatlayer LDATAOps :=
      UCTX_LOC ↦ mkglobvar (Tarray Tint32 (num_proc * UCTXT_SIZE * 4) (mk_attr false None))
              (Init_space (num_proc * UCTXT_SIZE * 4) :: nil) false false.*)

  End WITHMEM.

End Refinement.


From sflib Require Import sflib.
From Paco Require Import paco.
Require Import Coq.Classes.RelationClasses Lia Program.
From Fairness Require Export
     ITreeLib WFLibLarge FairBeh NatStructsLarge Mod pind Axioms
     Linking WMM Red IRed WeakestAdequacy FairLock Concurrency.
From PromisingLib Require Import Loc Event.
From PromisingSEQ Require Import View.
From Ordinal Require Export ClassicalHessenberg.
Require Import Coq.Numbers.BinNums.

Set Implicit Arguments.

Section INIT.

  Definition loc_X: Loc.t := Loc.of_nat 2.

  Definition const_0: Const.t := Const.of_Z (BinIntDef.Z.of_nat 0).
  Definition const_42: Const.t := Const.of_Z (BinIntDef.Z.of_nat 42).

End INIT.

Module ClientImpl.

  Definition thread1:
    ktree (programE void unit) unit unit
    :=
    fun _ =>
      let tvw := View.bot in
      tvw <- (OMod.call "lock" (tvw: View.t));;
      tvw <- (OMod.call "store" (tvw: View.t, loc_X, const_42, Ordering.plain));;
      `tvw: View.t <- (OMod.call "unlock" (tvw: View.t));;
      _ <- trigger Yield;;
      Ret tt.

  Definition thread2:
    ktree (programE void unit) unit unit
    :=
    fun _ =>
      let tvw := View.bot in
      val_x <- ITree.iter
                (fun (tvw: View.t) =>
                   tvw <- (OMod.call "lock" (tvw: View.t));;
                   '(tvw, x) <- (OMod.call "load" (tvw: View.t, loc_X, Ordering.plain));;
                   `tvw: View.t <- (OMod.call "unlock" (tvw: View.t));;
                         b <- unwrap (Const.eqb const_0 x);;
                         if (b: bool) then Ret (inl tvw) else Ret (inr x)) tvw;;
      b <- unwrap (Const.eqb const_42 val_x);;
      if (b: bool) then
        _ <- trigger Yield;;
        _ <- trigger (Observe 0 [42]);;
        _ <- trigger Yield;;
        Ret tt
      else UB.

  Definition omod: Mod.t :=
    Mod.mk
      tt
      (Mod.get_funs [("thread1", Mod.wrap_fun thread1);
                     ("thread2", Mod.wrap_fun thread2)])
  .

  Definition mod: Mod.t :=
    OMod.close
      (omod)
      (ModAdd WMem.mod AbsLockW.mod)
  .

End ClientImpl.

Module ClientSpec.
  Definition thread1:
    ktree (programE void unit) unit unit
    :=
    fun _ =>
      _ <- trigger Yield;; Ret tt.

  Definition thread2:
    ktree (programE void unit) unit unit
    :=
    fun _ =>
      _ <- trigger Yield;;
      _ <- trigger (Observe 0 [42]);;
      _ <- trigger Yield;;
      Ret tt.

  Definition mod: Mod.t :=
    Mod.mk
      tt
      (Mod.get_funs [("thread1", Mod.wrap_fun thread1);
                     ("thread2", Mod.wrap_fun thread2)])
  .

End ClientSpec.

From Fairness Require Import
     IProp IPM Weakest ModSim PCM MonotonePCM StateRA FairRA NatStructs NatMapRA.

Section LEMMA.

  Context `{Σ: GRA.t}.
  Variable A: Type.
  Context `{EXCL: @GRA.inG (Excl.t A) Σ}.

  Lemma excl_unique
        a0 a1
    :
    (OwnM (Excl.just a0: Excl.t A))
      -∗
      (OwnM (Excl.just a1: Excl.t A))
      -∗
      ⌜False⌝%I.
  Proof.
    iIntros "I1 I2". iCombine "I1 I2" as "C". iPoseProof (OwnM_valid with "C") as "%C". exfalso. ur in C. ss.
  Qed.

End LEMMA.

Section SIM.

  Context `{Σ: GRA.t}.

  Context `{MONORA: @GRA.inG monoRA Σ}.
  Context `{THDRA: @GRA.inG ThreadRA Σ}.
  Context `{STATESRC: @GRA.inG (stateSrcRA (unit)) Σ}.
  Context `{STATETGT: @GRA.inG (stateTgtRA ((OMod.closed_state ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod)))) Σ}.
  Context `{IDENTSRC: @GRA.inG (identSrcRA (void)) Σ}.
  Context `{IDENTTGT: @GRA.inG (identTgtRA (OMod.closed_ident ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod))%type) Σ}.

  Context `{OBLGRA: @GRA.inG ObligationRA.t Σ}.
  Context `{ARROWRA: @GRA.inG (ArrowRA (OMod.closed_ident ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod))%type) Σ}.
  Context `{EDGERA: @GRA.inG EdgeRA Σ}.
  Context `{ONESHOTSRA: @GRA.inG (@FiniteMap.t (OneShot.t unit)) Σ}.

  Context `{WMEMRA: @GRA.inG wmemRA Σ}.

  Context `{EXCL: @GRA.inG (Excl.t unit) Σ}.
  Context `{EXCL2: @GRA.inG (Excl.t (unit * unit)) Σ}.
  Context `{ONESHOTRA: @GRA.inG (OneShot.t nat) Σ}.
  Context `{REGIONRA: @GRA.inG (Region.t (thread_id * nat)) Σ}.
  Context `{CONSENTRA: @GRA.inG (@FiniteMap.t (Consent.t nat)) Σ}.
  Context `{AUTHNRA: @GRA.inG (Auth.t (Excl.t nat)) Σ}.
  Context `{AUTHVWRA: @GRA.inG (Auth.t (Excl.t View.t)) Σ}.
  Context `{AUTHVWRA2: @GRA.inG (Auth.t (Excl.t (View.t * unit))) Σ}.
  Context `{AUTHNMNRA: @GRA.inG (Auth.t (NatMapRALarge.t nat)) Σ}.

  Definition thread1_will_write (tvw: View.t) : iProp :=
    ∃ k, (∃ n, ObligationRA.black k n)
           ∗
           (ObligationRA.correl_thread k 1%ord)
           ∗
           (OwnM (OneShot.shot k))
           ∗
           ((ObligationRA.pending k (/2)%Qp ∗ wpoints_to loc_X const_0 tvw)
            ∨
              (ObligationRA.shot k ∗ wpoints_to loc_X const_42 tvw)).

  Definition o_w_cor: Ord.t := (Ord.omega × Ord.omega)%ord.

  Definition lock_will_unlock : iProp :=
    ∃ (own: bool) (tvw: View.t) (ing: bool) (mem: WMem.t) (wobl: NatMap.t nat) (j: nat),
      (OwnM (Auth.black (Some wobl: NatMapRALarge.t nat)))
        ∗
        ((OwnM (Auth.black (Excl.just j: Excl.t nat)))
        ∗ (OwnM (Auth.black (Excl.just (tvw, tt): Excl.t (View.t * unit)%type))))
        ∗
        (wmemory_black mem)
        ∗
        (St_tgt (tt, (mem, (((own, tvw), ing), key_set wobl))))
        ∗
        (FairRA.blacks (fun id => exists t, (id = (inr (inr (inr t)))) /\ (~ NatMap.In t wobl)))
        ∗
        (natmap_prop_sum wobl
                         (fun tid idx =>
                            (own_thread tid)
                              ∗
                              (ObligationRA.correl (inr (inr (inr tid))) idx o_w_cor)
                              ∗
                              (ObligationRA.pending idx 1)
                              ∗
                              (ObligationRA.duty (inr (inr (inr tid))) [(idx, o_w_cor)])
        ))
        ∗
        (
          ((⌜own = false⌝)
             ∗ (OwnM (Auth.white (Excl.just j: Excl.t nat)))
             (* points_to view *)
             ∗ (OwnM (Auth.white (Excl.just tvw: Excl.t View.t)))
             (* argument-passing view *)
             ∗ (OwnM (Auth.white (Excl.just (tvw, tt): Excl.t (View.t * unit)%type)))
             ∗ (OwnM (Excl.just tt: Excl.t unit))
          )
          ∨
            ((⌜own = true⌝)
               ∗ (ObligationRA.pending j 1)
               ∗ (ObligationRA.black j o_w_cor)
               ∗ (ObligationRA.correl_thread j 1%ord)
               ∗ (natmap_prop_sum wobl (fun _ idx => ObligationRA.amplifier j idx 1%ord))
            )
        )
        ∗
        (
          ((⌜ing = false⌝)
             ∗ (OwnM (Excl.just (tt, tt): Excl.t (unit * unit)%type))
          )
          ∨
            ((⌜ing = true⌝)
               ∗ (OwnM (Excl.just tt: Excl.t unit))
            (* ∗ (OwnM (Auth.white (Excl.just j: Excl.t nat))) *)
            (* ∗ (∃ tvw', (OwnM (Auth.white (Excl.just tvw': Excl.t View.t))) ∗ (⌜View.le tvw tvw'⌝)) *)
            )
        )
  .

  Let I: list iProp :=
        [(∃ tvw, (OwnM (Auth.black (Excl.just tvw: Excl.t View.t)))
                   ∗ (thread1_will_write tvw))%I;
         lock_will_unlock].

  Section INITIAL.

    Variable tid1 tid2 : nat.
    Let init_ord := (((((Ord.omega × Ord.omega) × Ord.omega) ⊕ ((Ord.S Ord.O) × (o_w_cor))) ⊕ 10)%ord).
    Let init_ths :=
              (NatStructsLarge.NatMap.add tid1 tt
                 (NatStructsLarge.NatMap.add tid2 tt
                    (NatStructsLarge.NatMap.empty unit))).

    Lemma init_sat Invs (H_TID : tid1 <> tid2) :
        (
            OwnM (OneShot.pending nat 1)
        ) ∗ (
            OwnM (Auth.black (Some (NatMap.empty nat) : NatMapRALarge.t nat))
              ∗ OwnM (Auth.black (Excl.just 0 : Excl.t nat))
              ∗ OwnM (Auth.white (Excl.just 0 : Excl.t nat))
              ∗ OwnM (Auth.black (Excl.just View.bot : Excl.t View.t))
              ∗ OwnM (Auth.white (Excl.just View.bot : Excl.t View.t))
              ∗ OwnM (Auth.black (Excl.just (View.bot, ()) : Excl.t (View.t * unit)))
              ∗ OwnM (Auth.white (Excl.just (View.bot, ()) : Excl.t (View.t * unit)))
              ∗ OwnM (Excl.just (tt,tt): Excl.t (unit * unit))
              ∗ OwnM (Excl.just () : Excl.t unit)
              ∗ OwnM (wmem_init_res loc_X (Loc.of_nat 5)))
        ∗
        WSim.initial_prop ClientSpec.mod ClientImpl.mod init_ths init_ord
        ⊢
        MUpd Invs (fairI (ident_tgt:=Mod.ident ClientImpl.mod)) [] [] (
            (∃ tvw, (OwnM (Auth.black (Excl.just tvw: Excl.t View.t))) ∗ (thread1_will_write tvw))
            ∗
            (lock_will_unlock)
            ∗
            (∃ k, (own_thread tid1)
                    ∗ (ObligationRA.duty (inl tid1) [(k, Ord.from_nat 1)])
                    ∗ (ObligationRA.taxes [(k, Ord.from_nat 1)] init_ord)
                    ∗ (OwnM (OneShot.shot k))
                    ∗ (ObligationRA.pending k (/ 2))
            )
            ∗
            ((own_thread tid2) ∗ (ObligationRA.duty (inl tid2) []))
        ).
    Proof.
      iIntros "(PEND & (B1 & B2 & W2 & B3 & W3 & B4 & W4 & E1 & E2 & E3) & INIT)".
      iPoseProof (wmem_init_res_prop with "E3") as "[[WPOINTS _] MBLACK]".

      iMod (ObligationRA.alloc ((1 × Ord.omega) ⊕ ((1 × Ord.omega) × init_ord))%ord) as "[% [[OBLIG1 OBLIG2] OBLIG3]]".
      iMod (OwnM_Upd (OneShot.pending_shot k) with "PEND") as "#SHOT".
      rewrite <- Qp.inv_half_half.
      iPoseProof (ObligationRA.pending_split _ (/ 2)%Qp (/ 2)%Qp with "OBLIG3") as "[OBPEND1 OBPEND2]".

      unfold WSim.initial_prop.
      iDestruct "INIT" as "[[[[[INIT0 INIT1] INIT2] INIT3] INIT4] INIT5]".
      (* make thread_own, duty *)
      assert (NatStructsLarge.NatMap.find tid1 init_ths = Some tt).
      { unfold init_ths. apply NatStructsLarge.nm_find_add_eq. }
      iPoseProof (MonotonePCM.natmap_prop_remove_find _ _ _ H with "INIT2") as "[DU1 INIT2]".
      iPoseProof (MonotonePCM.natmap_prop_remove_find _ _ _ H with "INIT3") as "[TH1 INIT3]".
      clear H.
      assert (NatStructsLarge.NatMap.find tid2 (NatStructsLarge.NatMap.remove tid1 init_ths) = Some tt).
      { unfold init_ths.
        rewrite NatStructsLarge.NatMapP.F.remove_neq_o; ss.
        rewrite NatStructsLarge.nm_find_add_neq; ss.
        rewrite NatStructsLarge.nm_find_add_eq. ss.
      }
      iPoseProof (MonotonePCM.natmap_prop_remove_find _ _ _ H with "INIT2") as "[DU2 INIT2]".
      iPoseProof (MonotonePCM.natmap_prop_remove_find _ _ _ H with "INIT3") as "[TH2 INIT3]".
      clear H.

      iPoseProof (ObligationRA.white_split_eq with "OBLIG2") as "[O0 O1]".
      iPoseProof (ObligationRA.duty_alloc with "DU1 O0") as "> DU".
      iPoseProof (ObligationRA.duty_correl with "DU") as "#CORREL".
      { ss. eauto. }

      iSplitL "B3 OBLIG1 SHOT OBPEND1 WPOINTS".
      { unfold thread1_will_write.
        iModIntro. iExists View.bot. iFrame. iExists k.
        iSplitL "OBLIG1". { iExists _. iFrame. }
        iSplitR. { iExists _.  eauto. }
        iSplitL "SHOT". { iApply "SHOT". }
        iLeft. iFrame. iApply (init_points_to_wpoints_to with "WPOINTS").
      }

      (*
      Check FairRA.blacks_unfold.
      Search FairRA.blacks.
      set (s0 := λ i : nat + OMod.closed_ident ClientImpl.omod (ModAdd WMem.mod AbsLockW.mod),
               match i with
               | inl _ => False%type
               | inr _ => True%type
               end).
      set (s1 := λ i : nat + OMod.closed_ident ClientImpl.omod (ModAdd WMem.mod AbsLockW.mod),
               match i with
               | inl _ => i = inl tid1
               | inr _ => True%type
               end).
      set (s2 := λ i : nat + OMod.closed_ident ClientImpl.omod (ModAdd WMem.mod AbsLockW.mod),
               match i with
               | inl _ => i = inl tid1 \/ i = inl tid2
               | inr _ => True%type
               end).
      Check FairRA.blacks_unfold s1 s0.
       *)
      (* iPoseProof (FairRA.blacks_unfold s1 s0 with "BLACK") as "BLACK". *)

      (* FairRA.blacks_unfold *)
      (* black_to_duty *)

      iSplitL "B1 B2 W2 W3 B4 W4 E1 E2 MBLACK INIT1 INIT5".
      { unfold lock_will_unlock.
        iExists false, View.bot, false, WMem.init, (NatMap.empty nat), 0.
        iModIntro.
        iFrame.
        iSplitL "INIT5". { ss. unfold OMod.closed_st_init, Mod.st_init. ss.
                           rewrite key_set_empty_empty_eq. iFrame. }
        iSplitL "INIT1". { iApply FairRA.blacks_impl.
                           2: { iFrame. }
                           i. des. subst. ss. }
        iSplitR. { ss. }
        iSplitL "W2 W3 W4 E2". { iLeft. iFrame. ss. }
        { iLeft. iFrame. ss. }
      }

      iSplitL "O1 OBPEND2 TH1 DU".
      { iExists k. iSplitL "TH1"; ss. iModIntro. iFrame. auto. }
      iModIntro. iFrame.
    Qed.

      (*
    Definition thread1_will_write (tvw: View.t) : iProp :=
      ∃ k, (∃ n, ObligationRA.black k n)
             ∗
             (ObligationRA.correl_thread k 1%ord)
             ∗
             (OwnM (OneShot.shot k))
             ∗
             ((ObligationRA.pending k (/2)%Qp ∗ wpoints_to loc_X const_0 tvw)
              ∨
                (ObligationRA.shot k ∗ wpoints_to loc_X const_42 tvw)).

    Definition lock_will_unlock : iProp :=
      ∃ (own: bool) (tvw: View.t) (ing: bool) (mem: WMem.t) (wobl: NatMap.t nat) (j: nat),
        (OwnM (Auth.black (Some wobl: NatMapRALarge.t nat)))
          ∗
          ((OwnM (Auth.black (Excl.just j: Excl.t nat)))
          ∗ (OwnM (Auth.black (Excl.just (tvw, tt): Excl.t (View.t * unit)%type))))
          ∗
          (wmemory_black mem)
          ∗
          (St_tgt (tt, (mem, (((own, tvw), ing), key_set wobl))))
          ∗
          (FairRA.blacks (fun id => exists t, (id = (inr (inr (inr t)))) /\ (~ NatMap.In t wobl)))
          ∗
          (natmap_prop_sum wobl
                           (fun tid idx =>
                              (own_thread tid)
                                ∗
                                (ObligationRA.correl (inr (inr (inr tid))) idx o_w_cor)
                                ∗
                                (ObligationRA.pending idx 1)
                                ∗
                                (ObligationRA.duty (inr (inr (inr tid))) [(idx, o_w_cor)])
          ))
          ∗
          (
            ((⌜own = false⌝)
               ∗ (OwnM (Auth.white (Excl.just j: Excl.t nat)))
               ∗ (OwnM (Auth.white (Excl.just tvw: Excl.t View.t)))
               ∗ (OwnM (Auth.white (Excl.just (tvw, tt): Excl.t (View.t * unit)%type)))
               ∗ (OwnM (Excl.just tt: Excl.t unit))
            )
            ∨
              (* ((⌜own = true⌝) *)
              (*    ∗ (ObligationRA.pending j 1) *)
              (*    ∗ (ObligationRA.black j o_w_cor) *)
              (*    ∗ (ObligationRA.correl_thread j 1%ord) *)
              (*    ∗ (natmap_prop_sum wobl (fun _ idx => ObligationRA.amplifier j idx 1%ord)) *)
              (* ) *)
          )
          ∗
          (
            ((⌜ing = false⌝)
               ∗ (OwnM (Excl.just (tt, tt): Excl.t (unit * unit)%type))
            )
            ∨
              (* ((⌜ing = true⌝) *)
              (*    ∗ (OwnM (Excl.just tt: Excl.t unit)) *)
              (* ) *)
          )
    .
      *)
  End INITIAL.

  Lemma AbsLock_lock
        R_src R_tgt tid
        (src: thread void (sE unit) R_src)
        tgt
        r g
        (Q: R_src -> R_tgt -> iProp)
        (l: list (nat * Ord.t)%type)
        (num_line: nat)
        (tvw0: View.t)
    :
    ((own_thread tid)
       ∗
       (ObligationRA.duty (inl tid) l)
       ∗
       (ObligationRA.taxes
          l ((((Ord.omega × Ord.omega) × Ord.omega)
                ⊕
                ((Ord.S Ord.O) × (o_w_cor)))
               ⊕ 9)%ord))
      ∗
      (∀ tvw1,
          ((⌜View.le tvw0 tvw1⌝)
             ∗
             (own_thread tid)
             ∗
             (∃ j, (ObligationRA.duty (inl tid) ((j, Ord.S Ord.O) :: l))
                     ∗
                     (ObligationRA.white j (Ord.omega × (Ord.from_nat num_line))%ord)
                     ∗
                     (OwnM (Auth.white (Excl.just j: Excl.t nat)))
             )
             ∗
             (∃ tvw,
                 (OwnM (Auth.white (Excl.just tvw: Excl.t View.t)))
                   ∗ (OwnM (Auth.white (Excl.just (tvw, tt): Excl.t (View.t * unit))))
                   ∗ (⌜(View.le tvw tvw1)⌝)
             )
             ∗
             (OwnM (Excl.just tt: Excl.t unit))
          )
            -∗
            (stsim I tid (topset I) r g Q
                   false false
                   (trigger Yield;;; src)
                   (tgt tvw1)))
      ⊢
      (stsim I tid (topset I) r g Q
             false false
             (trigger Yield;;; src)
             (tvw' <- (OMod.close_itree ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod) (R:=View.t) (OMod.call "lock" tvw0));; (tgt tvw'))).
  Proof.
    Opaque key_set.
    iIntros "[[TH [DUTY TAXES]] SIM]".
    rewrite close_itree_call. ss. rred. unfold OMod.emb_callee, emb_r. rewrite <- map_event_compose. rewrite <- plmap_compose.
    iPoseProof (ObligationRA.taxes_ord_split_one with "TAXES") as "TAXES".
    { eapply Hessenberg.lt_add_r. apply OrdArith.lt_from_nat. instantiate (1:=8). auto. }
    iMod "TAXES". iDestruct "TAXES" as "[TAXES TAX]".

    iApply (stsim_yieldR with "[DUTY TAX]"). msubtac. iFrame.
    iIntros "DUTY _". rred.
    unfold AbsLockW.lock_fun, Mod.wrap_fun. rred.
    iPoseProof (ObligationRA.taxes_ord_split_one with "TAXES") as "TAXES".
    { eapply Hessenberg.lt_add_r. apply OrdArith.lt_from_nat. instantiate (1:=7). auto. }
    iMod "TAXES". iDestruct "TAXES" as "[TAXES TAX]".

    iApply (stsim_yieldR with "[DUTY TAX]"). msubtac. iFrame.
    iIntros "DUTY _". rred.
    iApply stsim_tidR. rred.
    iopen 1 "I1" "K1". do 6 (iDestruct "I1" as "[% I1]").
    iDestruct "I1" as "[B1 [B2 [MEM [STGT I1]]]]".
    iApply stsim_getR. iSplit. iFrame. rred. rewrite put_rmw. rred.
    iApply (stsim_rmwR with "STGT"). iIntros "STGT". rred.

    iPoseProof (ObligationRA.alloc
                  (((Ord.omega × Ord.omega) × Ord.omega)
                     ⊕ ((Ord.S Ord.O) × (o_w_cor)))%ord) as "A".
    iMod "A" as "[% [[MYB MYW] PEND]]".
    iPoseProof (ObligationRA.white_split_eq with "MYW") as "[MYW YOUW]".
    iDestruct "I1" as "[BLKS [SUM [CASES INGS]]]".

    iAssert (⌜~ NatMap.In tid wobl⌝)%I as "%".
    { iAssert (⌜(NatMap.In tid wobl)⌝ ∨ ⌜(~ NatMap.In tid wobl)⌝)%I as "%".
      { iPureIntro. pose NatMapP.F.In_dec. specialize (s _ wobl tid). destruct s; auto. }
      destruct H as [IN | NI].
      2: auto.
      iPoseProof (natmap_prop_sum_impl with "SUM") as "SUM".
      { instantiate (1:= fun tid0 idx => own_thread tid0). i. iIntros "[F1 F2]". iFrame. }
      apply NatMapP.F.in_find_iff in IN.
      destruct (NatMap.find tid wobl) eqn:FIND; ss.
      iPoseProof (natmap_prop_sum_in with "SUM") as "TH2". eauto.
      iPoseProof (own_thread_unique with "TH TH2") as "F". iPure "F" as F. ss.
    }

    (* update ObligationRA.duty: get [] by black_to_duty, update with MYW; then correl *)
    set (blks2 :=
           (λ id : nat + (Mod.ident ClientImpl.omod + (Mod.ident (WMem.mod) + NatMap.key)),
               (∃ t : NatMap.key, id = inr (inr (inr t)) ∧ ¬ NatMap.In (elt:=nat) t (NatMap.add tid k wobl))%type)).
    iPoseProof (FairRA.blacks_unfold with "BLKS") as "[BLKS MYDUTY]".
    { instantiate (1:=inr (inr (inr tid))). instantiate (1:=blks2). i. des.
      { subst blks2. ss. des. esplits; eauto. ii; apply IN0. apply NatMapP.F.add_in_iff; auto. }
      { subst blks2. ss. esplits; eauto. }
    }
    { subst blks2. ss. ii. des. clarify. apply H1. apply NatMapP.F.add_in_iff. auto. }
    iPoseProof (black_to_duty with "MYDUTY") as "MYDUTY".
    iPoseProof (ObligationRA.duty_alloc with "MYDUTY") as "MYDUTY".
    iPoseProof ("MYDUTY" with "MYW") as "> MYDUTY".
    iPoseProof (ObligationRA.duty_correl with "MYDUTY") as "# MYCOR".
    { ss. left; eauto. }

    (* make (Auth.white singleton tid k) and update wobl *)
    iPoseProof (OwnM_Upd with "B1") as "OWN1".
    { eapply Auth.auth_alloc. instantiate (1:=NatMapRALarge.singleton tid k).
      instantiate (1:=Some (NatMap.add tid k wobl)). eapply NatMapRALarge.add_local_update.
      eapply NatMapP.F.not_find_in_iff; auto.
    }
    iMod "OWN1" as "[OWNB1 MYSING]".

    (* need to make amp; need ObligationRA.black j *)
    iAssert (
        (
  (⌜own = false⌝ **
               (OwnM (Auth.white (Excl.just j: Excl.t nat))
                     ** (OwnM (Auth.white (Excl.just tvw: Excl.t View.t))
                     ** (OwnM (Auth.white (Excl.just (tvw, tt): Excl.t (View.t * unit))) ** OwnM (Excl.just tt: Excl.t unit)))
  ))
   ∨ (⌜own = true⌝ **
               (ObligationRA.pending j 1 **
                (ObligationRA.black j o_w_cor **
                 (ObligationRA.correl_thread j 1 **
            natmap_prop_sum wobl (λ _ idx : nat, ObligationRA.amplifier j idx 1))))))
    ∗
    #=( ObligationRA.edges_sat )=>((⌜own = true⌝) -∗ (ObligationRA.amplifier j k 1))
      )%I
      with "[CASES YOUW]" as "[CASES AMP]".
    { iDestruct "CASES" as "[OWNF | [OT [PEND [JBLK [JCOR ALLAMP]]]]]".
      { iDestruct "OWNF" as "[% OW]". iSplitL "OW". iLeft. iFrame. auto.
        iModIntro. iIntros "OT". iPure "OT" as OT. clarify.
      }
      iPoseProof ("JBLK") as "# JBLK". iSplitR "YOUW".
      { iRight. iFrame. auto. }
      iPoseProof (ObligationRA.amplifier_intro with "JBLK") as "AMP".
      iPoseProof ("AMP" with "YOUW") as "AMP2". iMod "AMP2". iModIntro.
      iIntros "OT". iFrame.
    }
    iMod "AMP".

    (* now close invariant *)
    iMod ("K1" with "[TH OWNB1 B2 MEM SUM CASES INGS STGT PEND BLKS MYDUTY MYCOR AMP]") as "_".
    { unfold lock_will_unlock. iExists own, tvw, ing, mem, (NatMap.add tid k wobl), j. iFrame.
      rewrite key_set_pull_add_eq. iFrame. iSplitL "SUM TH MYDUTY MYCOR PEND".
      { iApply (natmap_prop_sum_add with "SUM"). iFrame. auto. }
      iDestruct "CASES" as "[OWNF | [OT [PEND [JBLK [JCOR ALLAMP]]]]]". iFrame.
      iRight. iPure "OT" as OT. iFrame. iSplit; auto.
      iApply (natmap_prop_sum_add with "ALLAMP"). iApply "AMP". auto.
    }
    { msubtac. }

    (* induction *)
    rred. iApply stsim_discard.
    { instantiate (1:=topset I). msubtac. }
    remember (((Ord.omega × Ord.omega) × Ord.omega)
                ⊕ Ord.S Ord.O × o_w_cor)%ord as wd.
    iPoseProof (ObligationRA.taxes_ord_split_one with "TAXES") as "> [TAXES TAXKEEP]".
    { instantiate (1:= (wd ⊕ 6)%ord). apply Hessenberg.lt_add_r.
      apply OrdArith.lt_from_nat. lia.
    }
    remember (wd ⊕ 6)%ord as credit.
    assert (RICH: (wd < credit)%ord).
    { subst; apply Hessenberg.add_lt_l. rewrite <- Ord.from_nat_O.
      apply OrdArith.lt_from_nat. lia.
    }
    clear Heqwd Heqcredit.
    clear own mem blks2 j H wobl. iClear "MYCOR".
    iStopProof. revert l k credit RICH. pattern wd. revert wd.
    apply (well_founded_induction Ord.lt_well_founded). intros wd IH. intros l k credit RICH.
    iIntros "[SIM [DUTY [MYB [MYW [TAXES TAXKEEP]]]]]".
    rewrite unfold_iter_eq. rred.

    iPoseProof (ObligationRA.taxes_ord_split_one with "TAXES") as "> [TAXES TAX]". eauto.
    iApply (stsim_yieldR with "[DUTY TAX]"). msubtac. iFrame.
    iIntros "DUTY WTH". rred.
    iopen 1 "I1" "K1". do 6 (iDestruct "I1" as "[% I1]").
    iDestruct "I1" as "[B1 [B2 [MEM [STGT I1]]]]".
    iApply stsim_getR. iSplit. iFrame. rred.
    destruct own.

    (* someone is holding the lock *)
    { rred. iApply stsim_tauR. rred.

      iAssert (⌜NatMap.find tid wobl = Some k⌝)%I as "%".
      { iPoseProof (OwnM_valid with "[MYW B1]") as "%".
        { instantiate (1:= (Auth.black (Some wobl: NatMapRALarge.t nat)) ⋅ (Auth.white (NatMapRALarge.singleton tid k: NatMapRALarge.t nat))). iSplitL "B1"; iFrame. }
        eapply Auth.auth_included in H. eapply NatMapRALarge.extends_singleton_iff in H.
        auto.
      }
      rename H into FIND.

      iDestruct "I1" as "[BLKS [SUM [CASES INGS]]]".
      iDestruct "CASES" as "[[%OWNF [LOCK EXCL]] | [%OWNT [JPEND [JBLK [#JCOR AMPs]]]]]".
      { inversion OWNF. }

      (* induction *)
      { iAssert (ObligationRA.amplifier j k 1)%I with "[AMPs]" as "#AMP".
        { iPoseProof (natmap_prop_remove_find with "AMPs") as "[# AMP AMPs]".
          { eapply FIND. }
          auto.
        }
        iPoseProof (ObligationRA.correl_thread_correlate with "JCOR WTH") as "> DEC".
        iDestruct "DEC" as "[DEC | DONE]"; cycle 1.
        { iPoseProof (ObligationRA.pending_not_shot with "JPEND DONE") as "CONTRA". auto. }
        { iPoseProof (ObligationRA.amplifier_amplify with "AMP DEC") as "> DEC".
          iPoseProof (ObligationRA.black_white_decr with "MYB DEC") as "> [% [MYB %]]".
          assert (RENEW: (o2 < wd)%ord).
          { eapply Ord.lt_le_lt. 2: eauto. apply Hessenberg.add_lt_l.
            rewrite <- Ord.from_nat_O. rewrite <- Jacobsthal.mult_from_nat.
            apply OrdArith.lt_from_nat. ss.
          }
          iMod ("K1" with "[B1 B2 MEM STGT BLKS SUM JPEND JBLK AMPs INGS]") as "_".
          { unfold lock_will_unlock. iExists true, tvw1, ing0, mem, wobl, j. iFrame.
            iRight. iFrame. iSplit; auto.
          }
          { msubtac. }
          iApply IH. eapply RENEW. eapply RENEW.
          iFrame.
        }
      }
    }

    (* no one is holding the lock *)
    { rred.
      iClear "TAXES". clear IH credit RICH.
      iApply stsim_getR. iSplit. iFrame. rred.
      iDestruct "I1" as "[BLKS [SUM [[[%VW [LOCK EXCL]] | [%CONTRA _]] INGS]]]".
      2:{ inversion CONTRA. }
      inv VW.
      iDestruct "INGS" as "[[%INGF INGEX] | [_ CONTRA]]".
      2:{ iDestruct "EXCL" as "[_ [_ EXCL]]". iPoseProof (excl_unique with "EXCL CONTRA") as "%C". inv C. }
      subst. rred.

      iApply stsim_chooseR. iIntros "%". destruct x. rename x into tvw'. rred. rewrite put_rmw. rred.
      iApply (stsim_rmwR with "STGT"). iIntros "STGT". rred.

      iAssert (⌜NatMap.find tid wobl = Some k⌝)%I as "%".
      { iPoseProof (OwnM_valid with "[MYW B1]") as "%".
        { instantiate (1:= (Auth.black (Some wobl: NatMapRALarge.t nat)) ⋅ (Auth.white (NatMapRALarge.singleton tid k: NatMapRALarge.t nat))). iSplitL "B1"; iFrame. }
        eapply Auth.auth_included in H. eapply NatMapRALarge.extends_singleton_iff in H.
        auto.
      }
      rename H into FIND.

      iPoseProof (natmap_prop_remove_find with "SUM") as "[[MYTH [_ [MYPEND MYDUTY]]] SUM]".
      eapply FIND. iPoseProof (ObligationRA.pending_shot with "MYPEND") as "> MYDONE".
      iPoseProof (ObligationRA.duty_done with "MYDUTY MYDONE") as "> MYDUTY".
      iApply (stsim_fairR with "[MYDUTY]").
      4:{ instantiate (1:=[(inr (inr tid), [])]). ss. iFrame. }
      { clear. i. unfold prism_fmap in *. des_ifs. ss. eapply Prism.review_preview in Heq. auto. }
      { instantiate (1:= List.map (fun '(j, _) => inr (inr j)) (NatMap.elements (NatMap.remove tid (key_set wobl)))). clear. i. unfold prism_fmap.
        assert (A: exists j, (i = inr (inr j)) /\ (NatMap.In j (NatMap.remove tid (key_set wobl)))).
        { apply in_map_iff in IN. des. des_ifs. destruct u. esplits; eauto.
          remember (NatMap.remove tid (key_set wobl)) as M. clear HeqM.
          apply NatMapP.F.elements_in_iff. exists (). apply SetoidList.InA_alt.
          exists (k, ()). ss.
        }
        des. subst. unfold Prism.preview; ss. des_ifs.
        exfalso. eapply NatMap.remove_1. reflexivity. eapply A0.
      }
      { eapply FinFun.Injective_map_NoDup.
        { unfold FinFun.Injective. i. des_ifs. destruct u, u0. ss. }
        apply NoDupA_NoDup. apply NatMap.elements_3w.
      }
      iIntros "MYDUTY WHITES". rred.

      (* close invariant *)
      iPoseProof (OwnM_Upd with "[B1 MYW]") as "> B1".
      2:{ instantiate (1:= (Auth.black (Some wobl: NatMapRALarge.t nat)) ⋅ (Auth.white (NatMapRALarge.singleton tid k: NatMapRALarge.t nat))). iSplitL "B1"; iFrame. }
      { eapply Auth.auth_dealloc. eapply NatMapRALarge.remove_local_update. }
      rewrite <- key_set_pull_rm_eq in *. remember (NatMap.remove tid wobl) as new_wobl.

      iPoseProof (MonotonePCM.list_prop_sum_cons_unfold with "MYDUTY") as "[MYDUTY _]".
      iPoseProof (duty_to_black with "MYDUTY") as "MYBEX".
      iPoseProof (FairRA.blacks_fold with "[BLKS MYBEX]") as "BLKS".
      2:{ iFrame. }
      { instantiate (1:=
         (λ id : nat + (Mod.ident ClientImpl.omod + (Mod.ident (WMem.mod) + NatMap.key)),
             ∃ t : NatMap.key, id = inr (inr (inr t)) ∧ ¬ NatMap.In (elt:=nat) t new_wobl)).
        i. ss. des. destruct (tid_dec t tid) eqn:DEC.
        - clarify. auto.
        - left. esplits; eauto. ii. apply IN0. subst. apply NatMapP.F.remove_in_iff.
          split; auto.
      }

      ss. repeat (unfold Lens.set; ss).
      iClear "MYB".
      clear Heqnew_wobl FIND wd k wobl.
      iDestruct "B2" as "[B2 B3]".
      iPoseProof (ObligationRA.alloc o_w_cor) as "> [% [[NEWB NEWW] NEWP]]".
      iPoseProof (OwnM_Upd with "[B2 LOCK]") as "> B2".
      2:{ instantiate (1:= (Auth.black (Excl.just j: Excl.t nat)) ⋅ (Auth.white (Excl.just j: Excl.t nat))). iSplitL "B2"; iFrame. }
      { eapply Auth.auth_update. do 2 instantiate (1:=Excl.just k).
        clear. ii. des. split.
        - ur. ss.
        - ur. ur in FRAME. des_ifs.
      }
      iDestruct "B2" as "[B2 LOCK]". clear j.

      iAssert (natmap_prop_sum new_wobl (fun tid0 idx => ObligationRA.correl (inr (inr (inr tid0))) idx (Ord.omega × Ord.omega)%ord)) with "[SUM]" as "#CORs".
      { iApply natmap_prop_sum_impl. 2: iFrame.
        i. iIntros "[_ [CORS _]]".  iFrame.
      }
      iPoseProof (ObligationRA.white_mon with "NEWW") as "> NEWW".
      { unfold o_w_cor. instantiate (1:= (Ord.omega × (Ord.S (Ord.S num_line)))%ord).
        apply Ord.lt_le. apply Jacobsthal.lt_mult_r.
        rewrite <- Ord.from_nat_S. rewrite <- Ord.from_nat_S. apply Ord.omega_upperbound.
        rewrite <- Ord.from_nat_O. apply Ord.omega_upperbound.
      }
      iPoseProof (ObligationRA.white_eq with "NEWW") as "NEWW".
      { apply Jacobsthal.mult_S. }
      iPoseProof (ObligationRA.white_split_eq with "NEWW") as "[NEWW1 NEWW2]".
      iPoseProof (ObligationRA.white_eq with "NEWW2") as "NEWW2".
      { apply Jacobsthal.mult_S. }
      iPoseProof (ObligationRA.white_split_eq with "NEWW2") as "[NEWWTAX NEWW2]".
      iPoseProof (ObligationRA.white_eq with "NEWW1") as "NEWW1".
      { symmetry. apply Jacobsthal.mult_1_l. }
      iPoseProof (ObligationRA.duty_alloc with "DUTY NEWW1") as "> DUTY".
      iPoseProof (ObligationRA.duty_correl_thread with "DUTY") as "#NEWCORTH".
      { ss. left; eauto. }

      (* need amps == need pendings; *)
      iAssert (natmap_prop_sum new_wobl (fun k _ => FairRA.white (inr (inr (inr k))) 1))%I with "[WHITES]" as "WHITES".
      { Transparent key_set. unfold key_set. rewrite <- list_map_elements_nm_map. unfold natmap_prop_sum.
        remember (NatMap.elements new_wobl) as ml. clear Heqml. rewrite List.map_map.
        iClear "CORs NEWCORTH". clear. iStopProof. induction ml.
        { iIntros "SUM". ss. }
        ss. des_ifs. iIntros "[WH SUM]". iFrame. iApply IHml. auto.
      }
      iPoseProof (natmap_prop_sum_impl2 with "[WHITES]") as "CASES".
      2:{ iSplitR "WHITES". iApply "CORs". iApply "WHITES". }
      { i. ss. iIntros "[COR WH]". iApply (ObligationRA.correl_correlate with "COR WH"). }
      Unshelve. 2,3: auto.
      iPoseProof (natmap_prop_sum_pull_bupd with "CASES") as "CASES". iMod "CASES".
      iPoseProof (natmap_prop_sum_or_cases_l with "CASES") as "[WHITEs|SHOT]"; cycle 1.
      { iDestruct "SHOT" as "[% [% [%FIND SHOT]]]".
        iPoseProof (natmap_prop_sum_in with "SUM") as "[_ [_ [PEND _]]]". eapply FIND.
        iPoseProof (ObligationRA.pending_not_shot with "PEND SHOT") as "FALSE". ss.
      }
      iPoseProof "NEWB" as "#NEWB".
      iPoseProof (natmap_prop_sum_sepconj with "[WHITEs]") as "WHITEs".
      { iSplitR "WHITEs". 2: iApply "WHITEs".
        instantiate (1:=fun _ _ => ObligationRA.black k o_w_cor).
        iClear "CORs NEWCORTH". unfold natmap_prop_sum. remember (NatMap.elements new_wobl) as ml.
        clear. iStopProof. induction ml; ss. auto.
        iIntros "#BLK". des_ifs. iSplit; auto. iApply IHml. auto.
      }
      iPoseProof (natmap_prop_sum_impl with "WHITEs") as "AMPs".
      { i. ss. iIntros "[BLK WHI]".
        iPoseProof (ObligationRA.white_eq with "WHI") as "WHI".
        { symmetry. apply Jacobsthal.mult_1_l. }
        iPoseProof (ObligationRA.amplifier_intro with "BLK WHI") as "AMP". iApply "AMP".
      }
      iPoseProof (natmap_prop_sum_pull_bupd with "AMPs") as "> AMPs".

      iDestruct "EXCL" as "[EXCL [EXCL2 EXCL3]]".
      iPoseProof (black_white_update with "B3 EXCL2") as ">[B3 EXCL2]".
      instantiate (1:= (tvw1, tt)).

      iMod ("K1" with "[B1 B2 B3 MEM STGT BLKS SUM NEWP AMPs INGEX]") as "_".
      { unfold lock_will_unlock. iExists true, tvw1, false, mem, new_wobl, k. iFrame. iSplitR "INGEX".
        - iRight. iFrame. auto.
        - iLeft. iFrame. auto.
      }
      { msubtac. }
      iApply stsim_discard. instantiate (1:=topset I). msubtac.

      iApply (stsim_yieldR with "[DUTY TAXKEEP NEWWTAX]"). msubtac.
      { iSplitL "DUTY". iFrame. iFrame. iApply ObligationRA.white_eq.
        { symmetry. apply Jacobsthal.mult_1_l. }
        iFrame.
      }
      iIntros "DUTY _". rred.
      iApply stsim_tauR. rred.

      (* iopen 0 "I0" "K0". iDestruct "I0" as "[% [I0B I0]]". *)
      (* iDestruct "I0" as "[% I0]". iDestruct "I0" as "[I01 [I02 [I03 I04]]]". *)
      (* iPoseProof (black_white_equal with "I0B EXCL") as "%". subst. *)
      (* iAssert ( *)
      (*     ((ObligationRA.pending k0 (/ 2) ** wpoints_to loc_X const_0 tvw1) *)
      (*      ∨ (ObligationRA.shot k0 ** wpoints_to loc_X const_42 tvw1)) *)
      (*       -∗ *)
      (*       ((ObligationRA.pending k0 (/ 2) ** wpoints_to loc_X const_0 tvw') *)
      (*        ∨ (ObligationRA.shot k0 ** wpoints_to loc_X const_42 tvw')) *)
      (*   )%I with "[]" as "I04a". *)
      (* { iIntros "I". iDestruct "I" as "[[A B] | [A B]]". *)
      (*   - iLeft. iFrame. iApply wpoints_to_view_mon. 2: iFrame. *)
      (*     etrans. 2: eapply l0. apply View.join_r. *)
      (*   - iRight. iFrame. iApply wpoints_to_view_mon. 2: iFrame. *)
      (*     etrans. 2: eapply l0. apply View.join_r. *)
      (* } *)
      (* iPoseProof ("I04a" with "I04") as "I04". *)
      (* iPoseProof (black_white_update with "I0B EXCL") as ">[I0B EXCL]". *)
      (* instantiate (1:= tvw1). *)
      (* iMod ("K0" with "[I0B I01 I02 I03 I04]") as "_". *)
      (* { iExists tvw1. iFrame. unfold thread1_will_write. iExists k0. iFrame. } *)
      (* msubtac. *)

      iPoseProof ("SIM" with "[MYTH DUTY NEWW2 EXCL EXCL2 EXCL3 LOCK]") as "SIM".
      { instantiate (1:= tvw'). iFrame. iSplit.
        { iPureIntro. etrans. 2: eapply l0. apply View.join_l. }
        iSplitL "DUTY NEWW2 LOCK". iExists k. iFrame.
        iExists _. iFrame. iPureIntro.
        etrans. 2: eapply l0. apply View.join_r.
      }
      iApply stsim_reset. iFrame.
    }

  Qed.

  Lemma AbsLock_unlock
        R_src R_tgt tid
        (src: thread void (sE unit) R_src)
        tgt
        r g
        (Q: R_src -> R_tgt -> iProp)
        l
        (tvw0 lvw: View.t)
    :
    ((OwnM (Excl.just tt: Excl.t unit))
       ∗
       (OwnM (Auth.white (Excl.just tvw0: Excl.t View.t)))
       ∗
       ((OwnM (Auth.white (Excl.just (lvw, tt): Excl.t (View.t * unit)))) ∗ (⌜View.le lvw tvw0⌝))
       ∗
       (∃ k, (ObligationRA.duty (inl tid) ((k, Ord.S Ord.O) :: l))
               ∗ (OwnM (Auth.white (Excl.just k: Excl.t nat)))
               ∗ (ObligationRA.taxes ((k, Ord.S Ord.O) :: l) 4%ord))
    )
      ∗
      (∀ tvw1,
          ((ObligationRA.duty (inl tid) l)
             ∗ (⌜View.le tvw0 tvw1⌝)
          )
            -∗
            (stsim I tid (topset I) r g Q
                   false false
                   (trigger Yield;;; src)
                   (tgt tvw1)))
      ⊢
      (stsim I tid (topset I) r g Q
             false false
             (trigger Yield;;; src)
             (tvw' <- OMod.close_itree ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod) (R:=View.t) (OMod.call "unlock" tvw0);; (tgt tvw'))).
  Proof.
    iIntros "[[EXCLTT [EXCL [[EXCL2 %LVW] [% [DUTY [LOCK TAXES]]]]]] SIM]".
    iPoseProof (ObligationRA.taxes_ord_split_one with "TAXES") as "> [TAXES TAX]".
    { instantiate (1:= 3%ord). apply OrdArith.lt_from_nat. lia. }
    iPoseProof (ObligationRA.taxes_ord_split_one with "TAXES") as "> [TAXES TAX1]".
    { instantiate (1:= 2%ord). apply OrdArith.lt_from_nat. lia. }
    iPoseProof (ObligationRA.taxes_ord_split_one with "TAXES") as "> [TAXES TAX2]".
    { instantiate (1:= 1%ord). apply OrdArith.lt_from_nat. lia. }
    iPoseProof (ObligationRA.taxes_single_is_tax with "TAXES") as "TAX3".

    rewrite close_itree_call. ss. rred. unfold OMod.emb_callee, emb_r. rewrite <- map_event_compose. rewrite <- plmap_compose.
    iApply (stsim_yieldR with "[DUTY TAX]"). msubtac. iFrame.
    iIntros "DUTY _". rred.
    unfold AbsLockW.unlock_fun, Mod.wrap_fun. rred.
    iApply (stsim_yieldR with "[DUTY TAX1]"). msubtac. iFrame.
    iIntros "DUTY _". rred.
    iopen 1 "I1" "K1". do 6 (iDestruct "I1" as "[% I1]").
    iDestruct "I1" as "[B1 [B2 [MEM [STGT [BLKS [SUM [[CONTRA | CASE] INGS]]]]]]]".
    { iDestruct "CONTRA" as "[_ [_ [EXCL3 _]]]".
      iPoseProof (white_white_excl with "EXCL EXCL3") as "%FF". inversion FF.
    }
    iDestruct "CASE" as "[% [JPEND [JBLK [JCOR AMPs]]]]". subst own.
    iApply stsim_getR. iSplit. iFrame. ss.

    iDestruct "B2" as "[B2 B3]".
    iPoseProof (black_white_equal with "B3 EXCL2") as "%EQ". inv EQ.
    destruct (excluded_middle_informative (View.le lvw tvw0)).
    2:{ rred. exfalso. clarify. }

    rred. iDestruct "INGS" as "[[%INGF INGEXCL] | [_ CONTRA]]".
    2:{ iPoseProof (excl_unique with "EXCLTT CONTRA") as "%FF". inv FF. }
    subst ing. rred. ss. rewrite put_rmw. rred.
    iApply (stsim_rmwR with "STGT"). iIntros "STGT". rred. ss. repeat (unfold Lens.set; ss).

    iPoseProof (black_white_equal with "B2 LOCK") as "%EQ". subst k.
    iMod ("K1" with "[EXCLTT B1 B2 B3 MEM BLKS SUM STGT JPEND JBLK JCOR AMPs]") as "_".
    { unfold lock_will_unlock. iExists true, lvw, true, mem, wobl, j. iFrame. iSplitR "EXCLTT".
      - iRight. iSplit. auto. iFrame.
      - iRight. iSplit. auto. iFrame.
    }
    msubtac.
    iApply (stsim_yieldR with "[DUTY TAX2]"). msubtac. iFrame.
    iIntros "DUTY _". rred.

    iopen 1 "I1" "K1". do 6 (iDestruct "I1" as "[% I1]").
    iDestruct "I1" as "[B1 [B2 [MEM [STGT [BLKS [SUM [[CONTRA | CASE] INGS]]]]]]]".
    { iDestruct "CONTRA" as "[_ [_ [_ [CONTRA _]]]]".
      iPoseProof (white_white_excl with "EXCL2 CONTRA") as "%FF". inversion FF.
    }
    iDestruct "CASE" as "[% [JPEND [JBLK [JCOR AMPs]]]]". subst own.

    iDestruct "B2" as "[B2 B3]".
    iPoseProof (black_white_equal with "B3 EXCL2") as "%EQ". inv EQ.
    iDestruct "INGS" as "[[_ CONTRA] | [%INGT EXCLTT]]".
    { iPoseProof (excl_unique with "INGEXCL CONTRA") as "%FF". inv FF. }
    subst ing. rred.

    iApply stsim_getR. iSplit. iFrame. rred.
    iApply stsim_chooseR. iIntros "%". destruct x. rename x into tvw_V. rewrite put_rmw. rred.
    (* iApply stsim_chooseR. iIntros "%". rename x into tvw_V. rred. *)
    iApply (stsim_rmwR with "STGT"). iIntros "STGT". rred.

    iApply stsim_chooseR. iIntros "%". destruct x. rename x into tvw'. rred.

    iPoseProof (black_white_equal with "B2 LOCK") as "%". subst.
    iPoseProof (black_white_update with "B3 EXCL2") as ">[B3 EXCL2]".
    instantiate (1:= (tvw_V, tt)).
    iopen 0 "I0" "K0". iDestruct "I0" as "[% [I0B I0]]".
    iDestruct "I0" as "[% I0]". iDestruct "I0" as "[I01 [I02 [I03 I04]]]".
    iPoseProof (black_white_equal with "I0B EXCL") as "%". subst.
    iAssert (
  ((ObligationRA.pending k (/ 2) ** wpoints_to loc_X const_0 tvw0)
   ∨ (ObligationRA.shot k ** wpoints_to loc_X const_42 tvw0))
    -∗
  ((ObligationRA.pending k (/ 2) ** wpoints_to loc_X const_0 tvw_V)
   ∨ (ObligationRA.shot k ** wpoints_to loc_X const_42 tvw_V))
      )%I with "[]" as "I04a".
    { iIntros "I". iDestruct "I" as "[[A B] | [A B]]".
      - iLeft. iFrame. iApply wpoints_to_view_mon. 2: iFrame. auto.
      - iRight. iFrame. iApply wpoints_to_view_mon. 2: iFrame. auto.
    }
    iPoseProof ("I04a" with "I04") as "I04".
    iPoseProof (black_white_update with "I0B EXCL") as ">[I0B EXCL]".
    instantiate (1:= tvw_V).

    iMod ("K0" with "[I0B I01 I02 I03 I04]") as "_".
    { iExists tvw_V. iFrame. unfold thread1_will_write. iExists k. iFrame. }
    iMod ("K1" with "[INGEXCL EXCLTT EXCL EXCL2 LOCK B1 B2 B3 MEM BLKS SUM STGT]") as "_".
    { unfold lock_will_unlock. iExists false, tvw_V, false, mem0, wobl0, j. iFrame. iSplitR "INGEXCL".
      - iLeft. iSplit. auto. iFrame.
      - iLeft. iSplit. auto. iFrame.
    }
    { msubtac. }
    iPoseProof (ObligationRA.pending_shot with "JPEND") as "> SHOT".
    iPoseProof (ObligationRA.duty_done with "DUTY SHOT") as "> DUTY".

    (* iApply stsim_chooseR. iIntros "%". destruct x. rename x into tvw''. rred. *)
    (* iApply stsim_tauR. rred. *)

    iApply (stsim_yieldR with "[DUTY TAX3]"). msubtac.
    { iSplitL "DUTY". iFrame.
      iPoseProof (ObligationRA.tax_cons_unfold with "TAX3") as "[_ TAX2]". iFrame.
    }
    iIntros "DUTY _". rred.
    iApply stsim_tauR. rred.
    iApply stsim_reset. iApply "SIM". iFrame.
    iPureIntro. etrans. 2: eapply l2. auto.

  Qed.

  Lemma correct_thread1 tid:
    (∃ k, (own_thread tid)
            ∗ (ObligationRA.duty (inl tid) [(k, Ord.from_nat 1)])
            ∗ (ObligationRA.taxes
                 [(k, Ord.from_nat 1)]
                 ((((Ord.omega × Ord.omega) × Ord.omega) ⊕ ((Ord.S Ord.O) × (o_w_cor))) ⊕ 10)%ord
              )
            ∗ (OwnM (OneShot.shot k))
            ∗ (ObligationRA.pending k (/ 2))
    )
      ⊢
      (stsim I tid (topset I) ibot7 ibot7
             (fun r_src r_tgt => own_thread tid ** ObligationRA.duty (inl tid) [] ** ⌜r_src = r_tgt⌝)
             false false
             (ClientSpec.thread1 tt)
             (OMod.close_itree ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod) (ClientImpl.thread1 tt))).
  Proof.
    iIntros "[% [TH [DUTY [TAXES [#KSHOT KPENDh]]]]]".
    unfold ClientSpec.thread1, ClientImpl.thread1. rred.
    iPoseProof (ObligationRA.taxes_ord_split_one with "TAXES") as "> [TAXES TAX]".
    { apply Hessenberg.lt_add_r. instantiate (1:=9). apply OrdArith.lt_from_nat. auto. }
    iApply AbsLock_lock. iFrame.
    iIntros "% [%VW0 [MYTH [SUM1 [SUM2 EXCLTT]]]]".
    iDestruct "SUM1" as "[% [DUTY [WHI LOCK]]]". iDestruct "SUM2" as "[% [EXCL [EXCL2 %VW1]]]".
    instantiate (1:=9). rred.
    rewrite close_itree_call. ss. unfold OMod.emb_callee, emb_l. rewrite <- map_event_compose. rewrite <- plmap_compose. rred.
    iPoseProof (ObligationRA.white_eq with "WHI") as "WHI".
    { rewrite Ord.from_nat_S. rewrite Jacobsthal.mult_S. reflexivity. }
    iPoseProof (ObligationRA.white_split_eq with "WHI") as "[WHI1 WHI2]".
    iApply (stsim_yieldR with "[DUTY WHI1 TAX]"). msubtac.
    { iSplitL "DUTY". iFrame.
      iApply ObligationRA.tax_cons_fold. iSplitL "WHI1"; auto.
      iApply ObligationRA.white_eq. 2: iFrame. symmetry; apply Jacobsthal.mult_1_l.
    }
    iIntros "DUTY _". rred. unfold WMem.store_fun, Mod.wrap_fun. rred.

    iopen 0 "I0" "K0".
    iDestruct "I0" as "[% [EXCLB I0]]".
    iPoseProof (black_white_equal with "EXCLB EXCL") as "%EQ". subst tvw0.

    iDestruct "I0" as "[% [i0BLK [i0KCOR [#i0KSHOT [i0PEND | i0SHOT]]]]]".
    2:{ iDestruct "i0SHOT" as "[i0SHOT PTR]".
        iPoseProof (OwnM_valid with "[KSHOT i0KSHOT]") as "%AGR".
        { instantiate (1:= (OneShot.shot k) ⋅ (OneShot.shot k0)). iSplitL "KSHOT"; auto. }
        apply OneShot.shot_agree in AGR. subst k0.
        iPoseProof (ObligationRA.pending_not_shot with "KPENDh i0SHOT") as "FALSE". ss.
    }
    iDestruct "i0PEND" as "[i0PENDh i0PTR]".
    iPoseProof (OwnM_valid with "[KSHOT i0KSHOT]") as "%AGR".
    { instantiate (1:= (OneShot.shot k) ⋅ (OneShot.shot k0)). iSplitL "KSHOT"; auto. }
    apply OneShot.shot_agree in AGR. subst k0.
    iPoseProof (ObligationRA.pending_sum with "KPENDh i0PENDh") as "KPEND".

    iopen 1 "I1" "K1". do 6 (iDestruct "I1" as "[% I1]").
    iDestruct "I1" as "[i1B1 [i1B2 [i1MEM [i1STGT I1]]]]".

    iApply stsim_getR. iSplit. iFrame. rred.
    iApply stsim_chooseR. iIntros "%". rred.
    destruct x. destruct x as [[[lc1 to] sc1] mem1]. des. rename y into WRITE.
    iPoseProof (wpoints_to_view_mon with "i0PTR") as "i0PTR". eapply VW1.
    iPoseProof (wmemory_ra_store with "i1MEM i0PTR") as "[%VW2 >[i1MEM i0PTR]]".
    eapply WRITE. eauto. eauto. eauto. eauto.

    iPoseProof (black_white_update with "EXCLB EXCL") as ">[EXCLB EXCL]".
    instantiate (1:= TView.TView.cur (Local.Local.tview lc1)). destruct lc1. ss. rred.
    iApply stsim_fairR.
    { i. instantiate (1:= []). ss. clear - IN.
      unfold prism_fmap, WMem.missed in IN. des_ifs.
    }
    { i. instantiate (1:=[]) in IN. inv IN. }
      (* instantiate (1:= [inr (inl (loc_X, to))]) in IN. *)
    (* inv IN; ss. des_ifs. *)
    { econs. }
    { auto. }
    iIntros "_ _". rred. rewrite put_rmw. rred.
    iApply (stsim_rmwR with "i1STGT"). iIntros "i1STGT". rred. iApply stsim_tauR. rred.

    rewrite Qp.inv_half_half.
    iPoseProof (ObligationRA.pending_shot with "KPEND") as "> #OBLKSHOT".

    iMod ("K0" with "[EXCLB i0BLK i0KCOR i0PTR]") as "_".
    { iExists (TView.TView.cur tview). iFrame.
      unfold thread1_will_write. iExists k. iFrame. iSplitR; auto. }

    iMod ("K1" with "[i1B1 i1B2 i1MEM i1STGT I1]") as "_".
    { unfold lock_will_unlock. iExists own, tvw0, ing, _, wobl, j0. iFrame. }
    msubtac.

    iPoseProof (ObligationRA.white_mon with "WHI2") as ">WHI2".
    { instantiate (1:= (Ord.omega × 4)%ord). apply Jacobsthal.le_mult_r. apply OrdArith.le_from_nat. lia. }

    iPoseProof (ObligationRA.duty_permutation with "DUTY") as "DUTY".
    { eapply perm_swap. }
    iPoseProof (ObligationRA.duty_done with "DUTY OBLKSHOT") as "> DUTY".
    iApply stsim_reset. iApply AbsLock_unlock. iSplitL "EXCL EXCL2 EXCLTT LOCK WHI2 DUTY".
    { iSplitL "EXCLTT". iFrame. iSplitL "EXCL". iFrame. iSplitL "EXCL2".
      { iFrame. iPureIntro. etrans. eapply VW1. auto. }
      iExists j. iFrame. iApply ObligationRA.taxes_cons_fold. iSplitL; auto.
      iApply ObligationRA.white_eq. 2: iFrame.
      rewrite Jacobsthal.mult_1_l. reflexivity.
    }
    iIntros "% [DUTY %VW3]". rred.
    iApply (stsim_sync with "[DUTY]"). msubtac. iFrame.
    iIntros "DUTY _". rred. iApply stsim_tauR. rred.
    iApply stsim_ret. iApply MUpd_intro. iFrame. auto.

  Qed.

  Lemma correct_thread2 tid:
    ((own_thread tid)
       ∗ (ObligationRA.duty (inl tid) [])
    )
      ⊢
      (stsim I tid (topset I) ibot7 ibot7
             (fun r_src r_tgt => own_thread tid ** ObligationRA.duty (inl tid) [] ** ⌜r_src = r_tgt⌝)
             false false
             (ClientSpec.thread2 tt)
             (OMod.close_itree ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod) (ClientImpl.thread2 tt))).
  Proof.
    iIntros "[MYTH DUTY]".
    unfold ClientSpec.thread2, ClientImpl.thread2. rred.
    iopen 0 "I0" "K0".
    iDestruct "I0" as "[% [EXCLB I0]]". iDestruct "I0" as "[% [[% #KBLK] [#KCOR [#KSHOT I0]]]]".
    iMod ("K0" with "[EXCLB I0]") as "_".
    { iExists tvw. iFrame. unfold thread1_will_write. iExists k. iFrame. auto. }
    { msubtac. }

    (* induction *)
    rred. iApply stsim_discard.
    { instantiate (1:=topset I). msubtac. }
    remember View.bot as tvw_base. clear tvw Heqtvw_base.
    iStopProof. revert tid k tvw_base. pattern n. revert n.
    apply (well_founded_induction Ord.lt_well_founded). intros n IH. intros.
    iIntros "[#[KBLK [KCOR KSHOT]] [MYTH DUTY]]".
    rewrite unfold_iter_eq. rred.
    iApply AbsLock_lock. iSplitL "MYTH DUTY".
    { iFrame. }
    iIntros "% [%VW0 [MYTH [SUM1 [SUM2 EXCLTT]]]]".
    iDestruct "SUM1" as "[% [DUTY [WHI LOCK]]]". iDestruct "SUM2" as "[% [EXCL [EXCL2 %VW1]]]".
    instantiate (1:= 9). rred.

    rewrite close_itree_call. ss. unfold OMod.emb_callee, emb_l. rewrite <- map_event_compose. rewrite <- plmap_compose. rred.
    iPoseProof (ObligationRA.white_eq with "WHI") as "WHI".
    { rewrite Ord.from_nat_S. rewrite Jacobsthal.mult_S. reflexivity. }
    iPoseProof (ObligationRA.white_split_eq with "WHI") as "[WHI1 WHI2]".
    iApply (stsim_yieldR with "[DUTY WHI1]"). msubtac.
    { iSplitL "DUTY". iFrame.
      iApply ObligationRA.tax_cons_fold. iSplitL "WHI1"; auto.
      iApply ObligationRA.white_eq. 2: iFrame. symmetry; apply Jacobsthal.mult_1_l.
    }
    iIntros "DUTY OWHTH". rred. unfold WMem.load_fun, Mod.wrap_fun. rred.

    iopen 0 "I0" "K0". iDestruct "I0" as "[% [EXCLB I0]]".
    iPoseProof (black_white_equal with "EXCLB EXCL") as "%EQ". subst tvw0.
    iDestruct "I0" as "[% [i0BLK [i0KCOR [#i0KSHOT [i0PEND | i0SHOT]]]]]".

    (* iterate case *)
    { iDestruct "i0PEND" as "[i0PENDh i0PTR]".
      iPoseProof (OwnM_valid with "[KSHOT i0KSHOT]") as "%AGR".
      { instantiate (1:= (OneShot.shot k) ⋅ (OneShot.shot k0)). iSplitL "KSHOT"; auto. }
      apply OneShot.shot_agree in AGR. subst k0.

      iopen 1 "I1" "K1". do 6 (iDestruct "I1" as "[% I1]").
      iDestruct "I1" as "[i1B1 [i1B2 [i1MEM [i1STGT I1]]]]".
      iApply stsim_getR. iSplit. iFrame. rred.
      iApply stsim_chooseR. iIntros "%".
      destruct x. destruct x as [[lc1 val] to]. des. rename y into READ. rred.
      iPoseProof (wpoints_to_view_mon with "i0PTR") as "i0PTR". eapply VW1.
      iPoseProof (wmemory_ra_load with "i1MEM i0PTR") as "[i1MEM [%VW2 >i0PTR]]".
      eapply READ. eauto. eauto. des. subst val.

      iPoseProof (black_white_update with "EXCLB EXCL") as ">[EXCLB EXCL]".
      instantiate (1:= TView.TView.cur (Local.Local.tview lc1)). destruct lc1. ss. rred.
      iApply stsim_fairR.
      { i. instantiate (1:= []). ss. clear - IN.
        unfold prism_fmap, WMem.missed in IN. des_ifs.
      }
      { i. instantiate (1:=[]) in IN. inv IN. }
      { econs. }
      { auto. }
      iIntros "_ _". rred.
      iApply stsim_tauR. rred.

      iMod ("K0" with "[EXCLB i0BLK i0KCOR i0PTR i0PENDh]") as "_".
      { iExists (TView.TView.cur tview). iFrame. unfold thread1_will_write. iExists k. iFrame. iSplitR; auto. iLeft; iFrame. }
      iMod ("K1" with "[i1B1 i1B2 i1MEM i1STGT I1]") as "_".
      { unfold lock_will_unlock. iExists own, tvw0, ing, mem, wobl, j0. iFrame. }
      msubtac.
      clear own mem wobl j0 released READ.
      iPoseProof (ObligationRA.white_mon with "WHI2") as ">WHI2".
      { instantiate (1:= (Ord.omega × 4)%ord). apply Jacobsthal.le_mult_r. apply OrdArith.le_from_nat. lia. }
      iApply stsim_reset. iApply AbsLock_unlock. iSplitL "LOCK EXCLTT EXCL EXCL2 WHI2 DUTY".
      { iSplitL "EXCLTT". iFrame. iSplitL "EXCL". iFrame. iSplitL "EXCL2".
        { iFrame. iPureIntro. etrans. 2: eauto. auto. }
        iFrame. iExists j. iFrame. iApply ObligationRA.taxes_cons_fold. iSplitL; auto.
        iApply ObligationRA.white_eq. 2: iFrame.
        rewrite Jacobsthal.mult_1_l. reflexivity.
      }
      iIntros "% [DUTY %VW3]". rred. iApply stsim_tauR. rred.
      iClear "i0KSHOT".
      iPoseProof (ObligationRA.correl_thread_correlate with "KCOR OWHTH") as "> [KWHI|#KDONE]".
      (* thread 1 not done; induction *)
      { iPoseProof (ObligationRA.black_white_decr_one with "KBLK KWHI") as "> [% [#KBLK2 %DECR]]".
        iClear "KBLK". iApply stsim_reset. iApply IH. apply DECR. iFrame. eauto.
      }

      (* thread 1 done; exit *)
      { iClear "KBLK KCOR". clear_upto I.
        rewrite unfold_iter_eq. rred.
        iApply stsim_reset. iApply AbsLock_lock. iSplitL "MYTH DUTY".
        { iFrame. }
        iIntros "% [%VW0 [MYTH [SUM1 [SUM2 EXCLTT]]]]".
        iDestruct "SUM1" as "[% [DUTY [WHI LOCK]]]". iDestruct "SUM2" as "[% [EXCL [EXCL2 %VW1]]]".
        instantiate (1:= 9). rred.

        iopen 0 "I0" "K0". iDestruct "I0" as "[% [EXCLB I0]]".
        iDestruct "I0" as "[% [i0BLK [i0KCOR [#i0KSHOT [i0PEND | i0SHOT]]]]]".
        { iDestruct "i0PEND" as "[i0PENDh i0PTR]".
          iPoseProof (OwnM_valid with "[KSHOT i0KSHOT]") as "%AGR".
          { instantiate (1:= (OneShot.shot k) ⋅ (OneShot.shot k0)). iSplitL "KSHOT"; auto. }
          apply OneShot.shot_agree in AGR. subst k0.
          iPoseProof (ObligationRA.pending_not_shot with "i0PENDh KDONE") as "FALSE". ss.
        }
        iDestruct "i0SHOT" as "[_ i0PTR]".
        iPoseProof (OwnM_valid with "[KSHOT i0KSHOT]") as "%AGR".
        { instantiate (1:= (OneShot.shot k) ⋅ (OneShot.shot k0)). iSplitL "KSHOT"; auto. }
        apply OneShot.shot_agree in AGR. subst k0.

        rewrite close_itree_call. ss. unfold OMod.emb_callee, emb_l. rewrite <- map_event_compose. rewrite <- plmap_compose. rred.
        iMod ("K0" with "[EXCLB i0BLK i0KCOR i0PTR]") as "_".
        { iExists _. iFrame. unfold thread1_will_write. iExists _. iFrame. iSplitR; auto. }
        msubtac.
        iPoseProof (ObligationRA.white_eq with "WHI") as "WHI".
        { rewrite Ord.from_nat_S. rewrite Jacobsthal.mult_S. reflexivity. }
        iPoseProof (ObligationRA.white_split_eq with "WHI") as "[WHI1 WHI2]".
        iApply (stsim_yieldR with "[DUTY WHI1]"). msubtac.
        { iSplitL "DUTY". iFrame.
          iApply ObligationRA.tax_cons_fold. iSplitL "WHI1"; auto.
          iApply ObligationRA.white_eq. 2: iFrame. symmetry; apply Jacobsthal.mult_1_l.
        }
        iIntros "DUTY _". rred. unfold WMem.load_fun, Mod.wrap_fun. rred.
        iopen 1 "I1" "K1". do 6 (iDestruct "I1" as "[% I1]").
        iDestruct "I1" as "[i1B1 [i1B2 [i1MEM [i1STGT I1]]]]".
        iApply stsim_getR. iSplit. iFrame. rred.
        iClear "i0KSHOT". iopen 0 "I0" "K0". iDestruct "I0" as "[% [EXCLB I0]]".
        iDestruct "I0" as "[% [i0BLK [i0KCOR [#i0KSHOT [i0PEND | i0SHOT]]]]]".
        { iDestruct "i0PEND" as "[i0PENDh i0PTR]".
          iPoseProof (OwnM_valid with "[KSHOT i0KSHOT]") as "%AGR".
          { instantiate (1:= (OneShot.shot k) ⋅ (OneShot.shot k0)). iSplitL "KSHOT"; auto. }
          apply OneShot.shot_agree in AGR. subst k0.
          iPoseProof (ObligationRA.pending_not_shot with "i0PENDh KDONE") as "FALSE". ss.
        }
        iDestruct "i0SHOT" as "[_ i0PTR]".
        iPoseProof (OwnM_valid with "[KSHOT i0KSHOT]") as "%AGR".
        { instantiate (1:= (OneShot.shot k) ⋅ (OneShot.shot k0)). iSplitL "KSHOT"; auto. }
        apply OneShot.shot_agree in AGR. subst k0.
        iPoseProof (black_white_equal with "EXCLB EXCL") as "%EQ". subst tvw4.

        iApply stsim_chooseR. iIntros "%".
        destruct x. destruct x as [[lc1 val] to]. des. rename y into READ. rred.
        iPoseProof (wpoints_to_view_mon with "i0PTR") as "i0PTR". eapply VW1.
        iPoseProof (wmemory_ra_load with "i1MEM i0PTR") as "[i1MEM [%VW3 >i0PTR]]".
        eapply READ. eauto. eauto. des. subst val.
        iPoseProof (black_white_update with "EXCLB EXCL") as ">[EXCLB EXCL]".
        instantiate (1:= TView.TView.cur (Local.Local.tview lc1)). destruct lc1. ss. rred.
        iApply stsim_fairR.
        { i. instantiate (1:= []). ss. clear - IN.
          unfold prism_fmap, WMem.missed in IN. des_ifs.
        }
        { i. instantiate (1:=[]) in IN. inv IN. }
        { econs. }
        { auto. }
        iIntros "_ _". rred.
        iApply stsim_tauR. rred.

        iMod ("K0" with "[EXCLB i0BLK i0KCOR i0PTR]") as "_".
        { iExists _. iFrame. unfold thread1_will_write. iExists _. iFrame. iSplitR; auto. }
        iMod ("K1" with "[i1B1 i1B2 i1MEM i1STGT I1]") as "_".
        { unfold lock_will_unlock. iExists own, tvw3, ing, mem, wobl, j0. iFrame. }
        msubtac.
        clear own mem wobl j0 promises to released READ.
        iPoseProof (ObligationRA.white_mon with "WHI2") as ">WHI2".
        { instantiate (1:= (Ord.omega × 4)%ord). apply Jacobsthal.le_mult_r. apply OrdArith.le_from_nat. lia. }
        iApply stsim_reset. iApply AbsLock_unlock. iSplitL "LOCK EXCLTT EXCL EXCL2 WHI2 DUTY".
        { iSplitL "EXCLTT". iFrame. iSplitL "EXCL". iFrame. iSplitL "EXCL2".
          { iFrame. iPureIntro. etrans. 2: eauto. auto. }
          iFrame. iExists j. iFrame. iApply ObligationRA.taxes_cons_fold. iSplitL; auto.
          iApply ObligationRA.white_eq. 2: iFrame.
          rewrite Jacobsthal.mult_1_l. reflexivity.
        }
        iIntros "% [DUTY %VW4]". rred.

        iApply (stsim_sync with "[DUTY]"). msubtac. iFrame.
        iIntros "DUTY _". rred. iApply stsim_tauR. rred.
        iApply stsim_observe. iIntros. rred.
        iApply stsim_tauR. rred.
        iApply (stsim_sync with "[DUTY]"). msubtac. iFrame.
        iIntros "DUTY _". rred.
        iApply stsim_tauR. rred.
        iApply stsim_ret.
        iApply MUpd_intro. iFrame. auto.
      }
    }

    { iDestruct "i0SHOT" as "[#KDONE i0PTR]".
      iPoseProof (OwnM_valid with "[KSHOT i0KSHOT]") as "%AGR".
      { instantiate (1:= (OneShot.shot k) ⋅ (OneShot.shot k0)). iSplitL "KSHOT"; auto. }
      apply OneShot.shot_agree in AGR. subst k0.

      iopen 1 "I1" "K1". do 6 (iDestruct "I1" as "[% I1]").
      iDestruct "I1" as "[i1B1 [i1B2 [i1MEM [i1STGT I1]]]]".
      iApply stsim_getR. iSplit. iFrame. rred.
      iApply stsim_chooseR. iIntros "%".
      destruct x. destruct x as [[lc1 val] to]. des. rename y into READ. rred.
      iPoseProof (wpoints_to_view_mon with "i0PTR") as "i0PTR". eapply VW1.
      iPoseProof (wmemory_ra_load with "i1MEM i0PTR") as "[i1MEM [%VW3 >i0PTR]]".
      eapply READ. eauto. eauto. des. subst val.
      iPoseProof (black_white_update with "EXCLB EXCL") as ">[EXCLB EXCL]".
      instantiate (1:= TView.TView.cur (Local.Local.tview lc1)). destruct lc1. ss. rred.
      iApply stsim_fairR.
      { i. instantiate (1:= []). ss. clear - IN.
        unfold prism_fmap, WMem.missed in IN. des_ifs.
      }
      { i. instantiate (1:=[]) in IN. inv IN. }
      { econs. }
      { auto. }
      iIntros "_ _". rred.
      iApply stsim_tauR. rred.

      iMod ("K0" with "[EXCLB i0BLK i0KCOR i0PTR]") as "_".
      { iExists _. iFrame. unfold thread1_will_write. iExists _. iFrame. iSplitR; auto. }
      iMod ("K1" with "[i1B1 i1B2 i1MEM i1STGT I1]") as "_".
      { unfold lock_will_unlock. iExists own, tvw0, ing, mem, wobl, j0. iFrame. }
      msubtac.
      clear own mem wobl j0 promises to released READ.
      iPoseProof (ObligationRA.white_mon with "WHI2") as ">WHI2".
      { instantiate (1:= (Ord.omega × 4)%ord). apply Jacobsthal.le_mult_r. apply OrdArith.le_from_nat. lia. }
      iApply stsim_reset. iApply AbsLock_unlock. iSplitL "LOCK EXCLTT EXCL EXCL2 WHI2 DUTY".
      { iSplitL "EXCLTT". iFrame. iSplitL "EXCL". iFrame. iSplitL "EXCL2".
        { iFrame. iPureIntro. etrans. 2: eauto. auto. }
        iFrame. iExists j. iFrame. iApply ObligationRA.taxes_cons_fold. iSplitL; auto.
        iApply ObligationRA.white_eq. 2: iFrame.
        rewrite Jacobsthal.mult_1_l. reflexivity.
      }
      iIntros "% [DUTY %VW4]". rred.

      iApply (stsim_sync with "[DUTY]"). msubtac. iFrame.
      iIntros "DUTY _". rred. iApply stsim_tauR. rred.
      iApply stsim_observe. iIntros. rred.
      iApply stsim_tauR. rred.
      iApply (stsim_sync with "[DUTY]"). msubtac. iFrame.
      iIntros "DUTY _". rred.
      iApply stsim_tauR. rred.
      iApply stsim_ret.
      iApply MUpd_intro. iFrame. auto.
    }

  Qed.

End SIM.

From Fairness Require Import WeakestAdequacy.

Module LockClientWCorrect.
  Definition config := [("thread1", tt↑); ("thread2", tt↑)].

  Local Instance Σ: GRA.t:=
    GRA.of_list [monoRA;
                 ThreadRA;
                 (stateSrcRA (unit));
                 (stateTgtRA ((OMod.closed_state ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod))));
                 (identSrcRA (void));
                 (identTgtRA (OMod.closed_ident ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod))%type);
                 ObligationRA.t;
                 (ArrowRA (OMod.closed_ident ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod))%type);
                 EdgeRA;
                 (@FiniteMap.t (OneShot.t unit));
                 wmemRA;
                 (Excl.t unit);
                 (Excl.t (unit * unit));
                 (OneShot.t nat);
                 (Region.t (thread_id * nat));
                 (@FiniteMap.t (Consent.t nat));
                 (Auth.t (Excl.t nat));
                 (Auth.t (Excl.t View.t));
                 (Auth.t (Excl.t (View.t * unit)));
                 (Auth.t (NatMapRALarge.t nat))].

  Local Instance MONORA: @GRA.inG monoRA Σ := (@GRA.InG _ _ 0 (@eq_refl _ _)).
  Local Instance THDRA: @GRA.inG ThreadRA Σ := (@GRA.InG _ _ 1 (@eq_refl _ _)).
  Local Instance STATESRC: @GRA.inG (stateSrcRA (unit)) Σ := (@GRA.InG _ _ 2 (@eq_refl _ _)).
  Local Instance STATETGT: @GRA.inG (stateTgtRA ((OMod.closed_state ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod)))) Σ := (@GRA.InG _ _ 3 (@eq_refl _ _)).
  Local Instance IDENTSRC: @GRA.inG (identSrcRA (void)) Σ := (@GRA.InG _ _ 4 (@eq_refl _ _)).
  Local Instance IDENTTGT: @GRA.inG (identTgtRA (OMod.closed_ident ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod))%type) Σ := (@GRA.InG _ _ 5 (@eq_refl _ _)).
  Local Instance OBLGRA: @GRA.inG ObligationRA.t Σ := (@GRA.InG _ _ 6 (@eq_refl _ _)).
  Local Instance ARROWRA: @GRA.inG (ArrowRA (OMod.closed_ident ClientImpl.omod (ModAdd (WMem.mod) AbsLockW.mod))%type) Σ := (@GRA.InG _ _ 7 (@eq_refl _ _)).
  Local Instance EDGERA: @GRA.inG EdgeRA Σ := (@GRA.InG _ _ 8 (@eq_refl _ _)).
  Local Instance ONESHOTSRA: @GRA.inG (@FiniteMap.t (OneShot.t unit)) Σ := (@GRA.InG _ _ 9 (@eq_refl _ _)).
  Local Instance WMEMRA: @GRA.inG wmemRA Σ := (@GRA.InG _ _ 10 (@eq_refl _ _)).
  Local Instance EXCL: @GRA.inG (Excl.t unit) Σ := (@GRA.InG _ _ 11 (@eq_refl _ _)).
  Local Instance EXCL2: @GRA.inG (Excl.t (unit * unit)) Σ := (@GRA.InG _ _ 12 (@eq_refl _ _)).
  Local Instance ONESHOTRA: @GRA.inG (OneShot.t nat) Σ := (@GRA.InG _ _ 13 (@eq_refl _ _)).
  Local Instance REGIONRA: @GRA.inG (Region.t (thread_id * nat)) Σ := (@GRA.InG _ _ 14 (@eq_refl _ _)).
  Local Instance CONSENTRA: @GRA.inG (@FiniteMap.t (Consent.t nat)) Σ := (@GRA.InG _ _ 15 (@eq_refl _ _)).
  Local Instance AUTHNRA: @GRA.inG (Auth.t (Excl.t nat)) Σ := (@GRA.InG _ _ 16 (@eq_refl _ _)).
  Local Instance AUTHVWRA: @GRA.inG (Auth.t (Excl.t View.t)) Σ := (@GRA.InG _ _ 17 (@eq_refl _ _)).
  Local Instance AUTHVWRA2: @GRA.inG (Auth.t (Excl.t (View.t * unit))) Σ := (@GRA.InG _ _ 18 (@eq_refl _ _)).
  Local Instance AUTHNMNRA: @GRA.inG (Auth.t (NatMapRALarge.t nat)) Σ := (@GRA.InG _ _ 19 (@eq_refl _ _)).

  Let init_res :=
        (GRA.embed (OneShot.pending nat 1))
          ⋅ GRA.embed (Auth.black (Some (NatMap.empty nat) : NatMapRALarge.t nat))
          ⋅ GRA.embed (Auth.black (Excl.just 0 : Excl.t nat) ⋅ Auth.white (Excl.just 0 : Excl.t nat))
          ⋅ GRA.embed (Auth.black (Excl.just View.bot : Excl.t View.t) ⋅ Auth.white (Excl.just View.bot : Excl.t View.t))
          ⋅ GRA.embed (Auth.black (Excl.just (View.bot, ()) : Excl.t (View.t * unit))
                                  ⋅ Auth.white (Excl.just (View.bot, ()) : Excl.t (View.t * unit)))
          ⋅ GRA.embed (Excl.just (tt,tt): Excl.t (unit * unit))
          ⋅ GRA.embed (Excl.just () : Excl.t unit)
          ⋅ GRA.embed  (wmem_init_res loc_X (Loc.of_nat 5))
  .

  Lemma correct:
    UserSim.sim ClientSpec.mod ClientImpl.mod (prog2ths ClientSpec.mod config) (prog2ths ClientImpl.mod config).
  Proof.
    eapply WSim.whole_sim_implies_usersim. econs.
    { instantiate (1:=init_res). rr. splits.
      { unfold init_res, default_initial_res. disj_tac. }
      { ndtac. }
      { unfold init_res. grawf_tac.
        { ur. auto. }
        { ur. split; auto.
          { eexists. eapply URA.unit_idl. }
          { ur. auto. }
        }
        { ur. split.
          { eexists _. rewrite URA.unit_idl. eapply URA.unit_id. }
          { ur. ss. }
        }
        { ur. split.
          { eexists _. rewrite URA.unit_idl. eapply URA.unit_id. }
          { ur. ss. }
        }
        { ur. split.
          { eexists _. rewrite URA.unit_idl. eapply URA.unit_id. }
          { ur. ss. }
        }
        { ur. ss. }
        { ur. ss. }
        { apply wmem_init_res_wf. ss. }
      }
    }
    unfold init_res. repeat rewrite <- GRA.embed_add.
    eexists _. iIntros "[[[[[[[[A B] [C0 C1]] [D0 D1]] [E0 E1]] F] G] H] M]".
    iModIntro.
    iExists [(∃ tvw, (OwnM (Auth.black (Excl.just tvw: Excl.t View.t)))
                       ∗ (thread1_will_write tvw))%I;
             lock_will_unlock].
    iPoseProof (init_sat with "[A B C0 C1 D0 D1 E0 E1 F G H M]") as "> [[% [H0 H1]] [H2 [[% [H3 [H5 [H6 [H7 H8]]]]] H4]]]".
    { instantiate (1:=1). instantiate (1:=0). ss. }
    { iFrame. }
    iIntros "INIT".
    iModIntro. ss. iFrame. iSplitL "H0 H1".
    { unfold nth_default. ss. iExists _. iFrame. }
    unfold MonotonePCM.natmap_prop_sum. ss.
    iSplitL "H3 H5 H6 H7 H8".
    { unfold fn2th. ss. unfold Mod.wrap_fun. lred. rred.
      iApply stsim_bind_top. iApply (stsim_wand with "[H3 H5 H6 H7 H8]").
      { iApply correct_thread1. iExists k. iFrame. }
      { iIntros (? ?) "[H %]". iModIntro. rred. iApply stsim_ret. iModIntro.
        iFrame. subst. auto.
      }
    }
    { unfold fn2th. ss. unfold Mod.wrap_fun. iSplitL; auto. lred. rred.
      iApply stsim_bind_top. iApply (stsim_wand with "[H4]").
      { iApply correct_thread2. iFrame. }
      { iIntros (? ?) "[H %]". iModIntro. rred. iApply stsim_ret. iModIntro.
        iFrame. subst. auto.
      }
    }
  Qed.
End LockClientWCorrect.