Require Import Bool.
Require Import List.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
Require Import Event.
From PromisingLib Require Import Language.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.
Require Import Progress.

Require Import FulfillStep.
Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import Compatibility.
Require Import SimThread.

Require Import ReorderStep.
Require Import ProgressStep.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Inductive reorder_update r1 l1 rmw1 or1 ow1: forall (i2:Instr.t), Prop :=
| reorder_update_load
    r2 l2 o2
    (ORDW1: Ordering.le ow1 Ordering.relaxed)
    (ORD2: Ordering.le o2 Ordering.relaxed)
    (LOC: l1 <> l2)
    (REGS: RegSet.disjoint (Instr.regs_of (Instr.update r1 l1 rmw1 or1 ow1))
                           (Instr.regs_of (Instr.load r2 l2 o2))):
    reorder_update r1 l1 rmw1 or1 ow1 (Instr.load r2 l2 o2)
| reorder_update_store
    l2 v2 o2
    (ORDW1: Ordering.le ow1 Ordering.relaxed)
    (ORD2: Ordering.le or1 Ordering.acqrel \/ Ordering.le o2 Ordering.acqrel)
    (LOC: l1 <> l2)
    (REGS: RegSet.disjoint (Instr.regs_of (Instr.update r1 l1 rmw1 or1 ow1))
                           (Instr.regs_of (Instr.store l2 v2 o2))):
    reorder_update r1 l1 rmw1 or1 ow1 (Instr.store l2 v2 o2)
| reorder_update_update
    r2 l2 rmw2 or2 ow2
    (ORDW1: Ordering.le ow1 Ordering.relaxed)
    (ORDR2: Ordering.le or2 Ordering.relaxed)
    (ORDW2: Ordering.le or1 Ordering.acqrel \/ Ordering.le ow2 Ordering.acqrel)
    (LOC: l1 <> l2)
    (REGS: RegSet.disjoint (Instr.regs_of (Instr.update r1 l1 rmw1 or1 ow1))
                           (Instr.regs_of (Instr.update r2 l2 rmw2 or2 ow2))):
    reorder_update r1 l1 rmw1 or1 ow1 (Instr.update r2 l2 rmw2 or2 ow2)
.

Inductive sim_update: forall (st_src:lang.(Language.state)) (lc_src:Local.t) (sc1_src:TimeMap.t) (mem1_src:Memory.t)
                        (st_tgt:lang.(Language.state)) (lc_tgt:Local.t) (sc1_tgt:TimeMap.t) (mem1_tgt:Memory.t), Prop :=
| sim_update_intro
    r1 l1 from1 to1 vr1 vret1 vw1 releasedr1 releasedw1 rmw1 or1 ow1 i2 rs
    lc1_src sc1_src mem1_src
    lc1_tgt sc1_tgt mem1_tgt
    lc2_src
    lc3_src sc3_src
    (RMW: RegFile.eval_rmw rs rmw1 vr1 = (vret1, vw1))
    (REORDER: reorder_update r1 l1 rmw1 or1 ow1 i2)
    (READ: Local.read_step lc1_src mem1_src l1 from1 vr1 releasedr1 or1 lc2_src)
    (FULFILL: match vw1 with
              | Some val => fulfill_step lc2_src sc1_src l1 from1 to1 val releasedr1 releasedw1 ow1 lc3_src sc3_src
              | None => lc3_src = lc2_src /\ sc3_src = sc1_src
              end)
    (LOCAL: sim_local lc3_src lc1_tgt)
    (SC: TimeMap.le sc3_src sc1_tgt)
    (MEMORY: sim_memory mem1_src mem1_tgt)
    (WF_SRC: Local.wf lc1_src mem1_src)
    (WF_TGT: Local.wf lc1_tgt mem1_tgt)
    (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
    (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
    (MEM_SRC: Memory.closed mem1_src)
    (MEM_TGT: Memory.closed mem1_tgt):
    sim_update
      (State.mk rs [Stmt.instr i2; Stmt.instr (Instr.update r1 l1 rmw1 or1 ow1)]) lc1_src sc1_src mem1_src
      (State.mk (RegFun.add r1 vret1 rs) [Stmt.instr i2]) lc1_tgt sc1_tgt mem1_tgt
.

Lemma sim_update_mon
      st_src lc_src sc1_src mem1_src
      st_tgt lc_tgt sc1_tgt mem1_tgt
      sc2_src mem2_src
      sc2_tgt mem2_tgt
      (SIM1: sim_update st_src lc_src sc1_src mem1_src
                       st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future mem1_tgt mem2_tgt)
      (SC1: TimeMap.le sc2_src sc2_tgt)
      (MEM1: sim_memory mem2_src mem2_tgt)
      (WF_SRC: Local.wf lc_src mem2_src)
      (WF_TGT: Local.wf lc_tgt mem2_tgt)
      (SC_SRC: Memory.closed_timemap sc2_src mem2_src)
      (SC_TGT: Memory.closed_timemap sc2_tgt mem2_tgt)
      (MEM_SRC: Memory.closed mem2_src)
      (MEM_TGT: Memory.closed mem2_tgt):
  sim_update st_src lc_src sc2_src mem2_src
             st_tgt lc_tgt sc2_tgt mem2_tgt.
Proof.
  inv SIM1.
  exploit Local.read_step_future; eauto. i. des.
  exploit future_read_step; try exact READ; eauto. i. des.
  exploit Local.read_step_future; eauto. i. des.
  destruct vw1 as [vw1|]; cycle 1.
  { ss; des; subst. econs; [eauto|..]; s; eauto; etrans; eauto. }
  exploit future_fulfill_step; try exact FULFILL; eauto.
  { by inv REORDER. }
  i. des.
  exploit sim_local_fulfill; try apply x0; try exact LOCAL0; try refl;
    try exact WF0; try by viewtac.
  { econs.
    - apply WF2.
    - eapply TView.future_closed; eauto. apply WF2.
    - inv READ. apply WF_SRC.
    - apply WF2.
  }
  i. des.
  econs; [eauto|..]; s; eauto; etrans; eauto.
Grab Existential Variables.
{ econs 2. }
{ econs. econs 3. }
Qed.

Lemma sim_update_future
      st_src lc_src sc1_src mem1_src
      st_tgt lc_tgt sc1_tgt mem1_tgt
      sc2_src mem2_src
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (SIM1: sim_update st_src lc_src sc1_src mem1_src
                       st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (MEM_FUTURE_SRC: Memory.future mem1_src mem2_src)
      (WF_SRC: Local.wf lc_src mem2_src)
      (SC_SRC: Memory.closed_timemap sc2_src mem2_src)
      (MEM_SRC: Memory.closed mem2_src):
  exists lc'_src sc2_tgt mem2_tgt,
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>> /\
    <<SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt>> /\
    <<MEM_FUTURE_TGT: Memory.future mem1_tgt mem2_tgt>> /\
    <<WF_TGT: Local.wf lc_tgt mem2_tgt>> /\
    <<SC_TGT: Memory.closed_timemap sc2_tgt mem2_tgt>> /\
    <<MEM_TGT: Memory.closed mem2_tgt>> /\
    <<SIM2: sim_update st_src lc'_src sc2_src mem2_src
                       st_tgt lc_tgt sc2_tgt mem2_tgt>>.
Proof.
  inv SIM1.
  destruct vw1 as [vw1|]; cycle 1.
  { ss. des. subst.
    exploit future_read_step; try exact READ; eauto. i. des.
    exploit SimPromises.future; try apply MEM1; eauto.
    { inv LOCAL. apply SimPromises.sem_bot_inv in PROMISES; auto. rewrite <- PROMISES.
      inv READ. ss. apply SimPromises.sem_bot.
    }
    i. des.

    esplits.
    - etrans.
      + apply Memory.max_timemap_spec; eauto. viewtac.
      + apply sim_memory_max_timemap; eauto.
    - eauto.
    - etrans.
      + apply Memory.max_timemap_spec; eauto. viewtac.
      + apply Memory.future_max_timemap; eauto.
    - auto.
    - auto.
    - apply Memory.max_timemap_closed. viewtac.
    - auto.
    - econs; [eauto|..]; s; eauto.
      + etrans; eauto.
      + etrans.
        * apply Memory.max_timemap_spec; eauto. viewtac.
        * apply sim_memory_max_timemap; eauto.
      + apply Memory.max_timemap_closed. viewtac.
  }

  exploit Local.read_step_future; eauto. i. des.
  exploit fulfill_step_future; eauto; try by viewtac. i. des.
  exploit future_read_step; try exact READ; eauto. i. des.
  exploit Local.read_step_future; eauto. i. des.
  exploit future_fulfill_step; try exact FULFILL; eauto; try refl; try by viewtac.
  { by inv REORDER. }
  i. des.
  exploit fulfill_step_future; try apply x0; try exact WF1; eauto; try by viewtac.
  { econs.
    - apply WF2.
    - eapply TView.future_closed; eauto. apply WF2.
    - inv READ. apply WF_SRC.
    - apply WF2.
  }
  i. des.
  exploit sim_local_fulfill; try exact x0; try exact LOCAL0; try refl; eauto.
  { econs.
    - apply WF2.
    - eapply TView.future_closed; eauto. apply WF2.
    - inv READ. apply WF_SRC.
    - apply WF2.
  }
  i. des.
  exploit fulfill_step_future; eauto. i. des.
  exploit SimPromises.future; try apply MEM1; eauto.
  { inv LOCAL. apply SimPromises.sem_bot_inv in PROMISES; auto. rewrite <- PROMISES.
    apply SimPromises.sem_bot.
  }
  i. des. esplits.
  - etrans.
    + apply Memory.max_timemap_spec; eauto. viewtac.
    + apply sim_memory_max_timemap; eauto.
  - eauto.
  - etrans.
    + apply Memory.max_timemap_spec; eauto. viewtac.
    + apply Memory.future_max_timemap; eauto.
  - auto.
  - auto.
  - apply Memory.max_timemap_closed. viewtac.
  - auto.
  - econs; [eauto|..]; s; eauto.
    + etrans; eauto.
    + etrans.
      * apply Memory.max_timemap_spec; eauto. viewtac.
      * apply sim_memory_max_timemap; eauto.
    + apply Memory.max_timemap_closed. viewtac.
Grab Existential Variables.
{ econs 2. }
{ econs. econs 3. }
Qed.

Lemma sim_update_step
      st1_src lc1_src sc1_src mem1_src
      st1_tgt lc1_tgt sc1_tgt mem1_tgt
      (SIM: sim_update st1_src lc1_src sc1_src mem1_src
                       st1_tgt lc1_tgt sc1_tgt mem1_tgt):
  _sim_thread_step lang lang ((sim_thread (sim_terminal eq)) \8/ sim_update)
                   st1_src lc1_src sc1_src mem1_src
                   st1_tgt lc1_tgt sc1_tgt mem1_tgt.
Proof.
  inv SIM. ii.
  exploit Local.read_step_future; eauto. i. des.
  destruct vw1 as [vw1|]; cycle 1.
  { ss. des. subst.
    inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
      try (inv STATE; inv INSTR; inv REORDER); ss.
    - (* promise *)
      exploit Local.promise_step_future; eauto. i. des.
      exploit sim_local_promise; eauto. i. des.
      exploit reorder_read_promise; try exact READ; try exact STEP_SRC; eauto. i. des.
      exploit Local.promise_step_future; eauto. i. des.
      esplits; try apply SC; eauto.
      + econs 2. econs. econs; eauto.
      + eauto.
      + right. econs; [eauto|..]; s; eauto. etrans; eauto.
    - (* load *)
      exploit sim_local_read; (try by etrans; eauto); eauto; try refl. i. des.
      exploit reorder_read_read; try exact READ; try exact STEP_SRC; try by eauto. i. des.
      esplits.
      + econs 2; [|econs 1]. econs.
        * econs. econs 2. econs; [|econs 2]; eauto. econs. econs.
        * eauto.
      + econs 2. econs 2. econs; [|econs 2]; eauto. econs. econs.
        erewrite RegFile.eq_except_rmw; eauto; cycle 1.
        * apply RegFile.eq_except_singleton.
        * ii. eapply REGS; eauto.
          apply RegSet.add_spec. auto.
      + eauto.
      + eauto.
      + eauto.
      + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
        apply RegFun.add_add. ii. subst. eapply REGS; cycle 1.
        * apply RegSet.singleton_spec. eauto.
        * apply RegSet.add_spec. auto.
    - (* update-load *)
      guardH ORDW2.
      exploit sim_local_read; (try by etrans; eauto); eauto; try refl. i. des.
      exploit reorder_read_read; try exact READ; try exact STEP_SRC; try by eauto. i. des.
      esplits.
      + econs 2; [|econs 1]. econs.
        * econs. econs 2. econs; [|econs 2]; eauto. econs. econs.
          erewrite <- RegFile.eq_except_rmw; eauto; try apply RegFile.eq_except_singleton.
          ii. eapply REGS; eauto.
          { eapply RegSet.add_spec. left. apply RegSet.singleton_spec. eauto. }
          { eapply RegSet.add_spec. eauto. }
        * eauto.
      + econs 2. econs 2. econs; [|econs 2]; eauto. econs. econs.
        erewrite RegFile.eq_except_rmw; eauto; cycle 1.
        * apply RegFile.eq_except_singleton.
        * ii. eapply REGS; eauto.
          { eapply RegSet.add_spec. right. eauto. }
          { eapply RegSet.add_spec. left. apply RegSet.singleton_spec. eauto. }
      + eauto.
      + eauto.
      + eauto.
      + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
        apply RegFun.add_add. ii. subst. eapply REGS.
        * apply RegSet.add_spec. left. eauto.
        * apply RegSet.add_spec. left. eauto.
    - (* store *)
      guardH ORD2.
      hexploit sim_local_write; try exact LOCAL1; try exact SC;
        try exact WF2; try refl; eauto; try by viewtac. i. des.
      exploit reorder_read_write; try exact READ; try exact STEP_SRC; eauto; try by viewtac. i. des.
      esplits.
      + econs 2; [|econs 1]. econs.
        * econs. econs 2. econs; [|econs 3]; eauto. econs.
          s. erewrite RegFile.eq_except_value; eauto. econs.
          ii. apply RegFun.add_spec_neq. ii. subst. apply REG.
          eapply RegSet.add_spec. auto.
        * eauto.
      + econs 2. econs 2. econs; [|econs 2]; eauto. econs. econs. eauto.
      + eauto.
      + eauto.
      + etrans; eauto.
      + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss. etrans; eauto.
    - (* update *)
      guardH ORDW2.
      exploit Local.read_step_future; try exact LOCAL1; eauto. i. des.
      exploit sim_local_read; try exact LOCAL1; eauto; try refl. i. des.
      exploit Local.read_step_future; try exact STEP_SRC; eauto. i. des.
      hexploit sim_local_write; try exact LOCAL2; try exact SC; eauto; try refl. i. des.
      exploit reorder_read_read; try exact READ; try exact STEP_SRC; eauto; try congr. i. des.
      exploit Local.read_step_future; try exact STEP1; eauto. i. des.
      exploit reorder_read_write; try exact STEP2; try exact STEP_SRC0; eauto; try congr. i. des.
      esplits.
      + econs 2; [|econs 1]. econs.
        * econs. econs 2. econs; [|econs 4]; eauto. econs. econs.
          erewrite <- RegFile.eq_except_rmw; eauto; try apply RegFile.eq_except_singleton.
          ii. eapply REGS; eauto.
          { eapply RegSet.add_spec. left. apply RegSet.singleton_spec. eauto. }
          { eapply RegSet.add_spec. eauto. }
        * eauto.
      + econs 2. econs 2. econs; [|econs 2]; eauto. econs. econs.
        erewrite RegFile.eq_except_rmw; cycle 2.
        * apply RegFile.eq_except_singleton.
        * eauto.
        * ii. apply RegSet.singleton_spec in LHS. subst.
          eapply REGS; eauto.
          { eapply RegSet.add_spec. right. eauto. }
          { eapply RegSet.add_spec. eauto. }
      + eauto.
      + eauto.
      + etrans; eauto.
      + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
        * apply RegFun.add_add. ii. subst. eapply REGS.
          { apply RegSet.add_spec. left. eauto. }
          { apply RegSet.add_spec. left. eauto. }
        * etrans; eauto.
  }

  exploit fulfill_step_future; eauto. i. des.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv REORDER); ss.
  - (* promise *)
    exploit Local.promise_step_future; eauto. i. des.
    exploit sim_local_promise; try apply LOCAL0; (try by etrans; eauto); eauto. i. des.
    exploit reorder_update_promise; try exact READ; try exact FULFILL; try exact STEP_SRC; eauto. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    esplits.
    + eauto.
    + econs 2. econs 1. econs; eauto.
    + auto.
    + etrans; eauto.
    + auto.
    + right. econs; [eauto|..]; s; eauto.
      * etrans; eauto.
      * etrans; eauto.
      * eapply Memory.future_closed_timemap; eauto.
  - (* load *)
    apply RegSet.disjoint_add in REGS. des.
    exploit sim_local_read; try apply LOCAL0; (try by etrans; eauto); eauto; try refl. i. des.
    exploit reorder_update_read; try exact FULFILL; try exact READ; try exact STEP_SRC; eauto. i. des.
    exploit Local.read_step_future; try exact STEP1; eauto. i. des.
    exploit Local.read_step_future; try exact STEP2; eauto. i. des.
    exploit fulfill_write; eauto. i. des.
    esplits.
    + econs 2; eauto. econs.
      * econs. econs 2. econs; [|econs 2]; eauto. econs. econs.
      * auto.
    + econs 2. econs 2. econs; [|econs 4]; eauto. econs. econs.
      erewrite RegFile.eq_except_rmw; eauto; cycle 1.
      * apply RegFile.eq_except_singleton.
      * symmetry. eauto.
    + auto.
    + auto.
    + etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      apply RegFun.add_add. ii. subst. eapply REGS.
      apply RegSet.Facts.singleton_iff. auto.
  - (* update-load *)
    guardH ORDW2.
    apply RegSet.disjoint_add in REGS. des.
    exploit sim_local_read; try apply LOCAL0; (try by etrans; eauto); eauto; try refl. i. des.
    exploit reorder_update_read; try exact FULFILL; try exact READ; try exact STEP_SRC; eauto. i. des.
    exploit Local.read_step_future; try exact STEP1; eauto. i. des.
    exploit Local.read_step_future; try exact STEP2; eauto. i. des.
    exploit fulfill_write; eauto. i. des.
    esplits.
    + econs 2; eauto. econs.
      * econs. econs 2. econs; [|econs 2]; eauto. econs. econs.
        erewrite RegFile.eq_except_rmw; eauto; cycle 1.
        { symmetry. apply RegFile.eq_except_singleton. }
        { ii. apply RegSet.singleton_spec in LHS. subst. contradict REGS. apply RegSet.add_spec. auto. }
      * auto.
    + econs 2. econs 2. econs; [|econs 4]; eauto. econs. econs.
      erewrite RegFile.eq_except_rmw; eauto; cycle 1.
      * apply RegFile.eq_except_singleton.
      * ii. apply RegSet.singleton_spec in LHS. subst.
        eapply REGS0; eauto. apply RegSet.add_spec. auto.
    + auto.
    + auto.
    + etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      apply RegFun.add_add. ii. subst.
      eapply REGS. apply RegSet.add_spec. auto.
  - (* store *)
    guardH ORD2.
    apply RegSet.disjoint_add in REGS. des.
    hexploit sim_local_write; try exact LOCAL1; try exact LOCAL; try exact SC; try exact WF0; try refl; eauto; try by viewtac. i. des.
    hexploit reorder_update_write; try exact READ; try exact FULFILL; try exact STEP_SRC; eauto; try by viewtac.
    { ii. subst. inv FULFILL. eapply Time.lt_strorder. eauto. }
    i. des.
    exploit Local.write_step_future; try exact STEP1; eauto; try by viewtac. i. des.
    exploit Local.read_step_future; try exact STEP2; eauto; try by viewtac. i. des.
    exploit fulfill_write; eauto. i. des.
    esplits.
    + econs 2; eauto. econs.
      * econs. econs 2. econs; [|econs 3]; eauto. econs.
        erewrite RegFile.eq_except_value; cycle 2.
        { apply RegFile.eq_except_singleton. }
        { econs. }
        { ii. apply RegSet.singleton_spec in LHS. subst. congr. }
      * auto.
    + econs 2. econs 2. econs; [|econs 4]; eauto. econs. econs. eauto.
    + auto.
    + etrans; eauto.
    + etrans; eauto. etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      etrans; eauto.
  - (* update *)
    guardH ORDW2.
    apply RegSet.disjoint_add in REGS. des.
    symmetry in REGS0. apply RegSet.disjoint_add in REGS0. des.
    exploit fulfill_step_future; try exact FULFILL; eauto; try by viewtac. i. des.
    exploit Local.read_step_future; try exact LOCAL1; eauto; try by viewtac. i. des.
    exploit sim_local_read; try exact LOCAL1; (try by etrans; eauto); eauto; try refl. i. des.
    exploit Local.read_step_future; try exact STEP_SRC; eauto. i. des.
    hexploit sim_local_write; try exact LOCAL2; eauto; try refl; try by viewtac. i. des.
    hexploit ReorderStep.reorder_update_update; try exact FULFILL; try exact READ; try exact STEP_SRC0; eauto.
    { ii. subst. inv FULFILL. eapply Time.lt_strorder. eauto. }
    i. des.
    exploit Local.read_step_future; try exact STEP1; eauto. i. des.
    exploit Local.write_step_future; try exact STEP2; eauto. i. des.
    exploit Local.read_step_future; try exact STEP3; eauto. i. des.
    exploit fulfill_write; eauto. i. des.
    esplits.
    + econs 2; eauto. econs.
      * econs. econs 2. econs; [|econs 4]; eauto. econs. econs.
        erewrite RegFile.eq_except_rmw; eauto; cycle 1.
        { symmetry. apply RegFile.eq_except_singleton. }
        { ii. apply RegSet.singleton_spec in LHS. subst. contradict REGS. apply RegSet.add_spec. auto. }
      * auto.
    + econs 2. econs 2. econs; [|econs 4]; eauto. econs. econs.
      erewrite RegFile.eq_except_rmw; cycle 2.
      * apply RegFile.eq_except_singleton.
      * eauto.
      * ii. apply RegSet.singleton_spec in LHS. subst. congr.
    + auto.
    + etrans; eauto.
    + etrans; eauto. etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      * apply RegFun.add_add. ii. subst. apply REGS. apply RegSet.add_spec. auto.
      * etrans; eauto.
Grab Existential Variables.
{ econs 2. }
{ econs. econs 3. }
Qed.

Lemma sim_update_sim_thread:
  sim_update <8= (sim_thread (sim_terminal eq)).
Proof.
  pcofix CIH. i. pfold. ii. ss. splits; ss; ii.
  - inv TERMINAL_TGT. inv PR; ss.
  - exploit sim_update_mon; eauto. i.
    exploit sim_update_future; try apply x0; eauto. i. des.
    esplits; eauto.
  - exploit sim_update_mon; eauto. i.
    inversion x0. subst. i.
    exploit (progress_program_step (RegFun.add r1 (fst (RegFile.eval_rmw rs rmw1 vr1)) rs) i2 nil); eauto. i. des.
    destruct th2. exploit sim_update_step; eauto.
    { rewrite RMW in *. ss. econs 2. eauto. }
    i. des.
    + exploit program_step_promise; eauto. i.
      exploit Thread.rtc_tau_step_future; eauto. s. i. des.
      exploit Thread.opt_step_future; eauto. s. i. des.
      exploit Thread.program_step_future; eauto. s. i. des.
      punfold SIM. exploit SIM; try apply SC3; eauto; try refl. s. i. des.
      exploit PROMISES; eauto. i. des.
      esplits; [|eauto].
	    etrans; eauto. etrans; [|eauto].
      inv STEP_SRC; eauto. econs 2; eauto. econs.
      * econs. eauto.
      * etrans; eauto.
        destruct e; by inv STEP; inv STATE; inv INSTR; inv REORDER.
    + inv SIM. inv STEP; inv STATE.
  - exploit sim_update_mon; eauto. i. des.
    exploit sim_update_step; eauto. i. des.
    + esplits; eauto.
      left. eapply paco9_mon; eauto. ss.
    + esplits; eauto.
Qed.


Require Import Sail.Base.
Require Import String.
Require Import List.
Require Import Lia.
Import List.ListNotations.
Open Scope Z.

Definition MEMr {regval a e} (addr : mword a) size `{ArithFact (size >=? 0)}            : monad regval (mword (8 * size)) e := read_mem Read_plain a addr size.
Definition MEMr_reserve {regval a e} (addr : mword a) size `{ArithFact (size >=? 0)}    : monad regval (mword (8 * size)) e := read_mem Read_reserve a addr size.
Definition MEM_sync {rv e} (_:unit) : monad rv unit e := barrier (Barrier_MIPS_SYNC tt).

Definition MEMr_tagged {rv a e} (addr : mword a) size (allowTag : bool) `{ArithFact (size >? 0)} : monad rv (bool * mword (size * 8)) e :=
  (if allowTag then
    read_memt Read_plain addr size
  else
    (read_mem Read_plain a addr size >>= fun v => returnm (v, B0))) >>= fun '(v, t) =>
  maybe_fail "bool_of_bitU" (bool_of_bitU t) >>= fun t =>
  returnm (t, v).

Definition MEMr_tagged_reserve {rv a e} (addr : mword a) size (allowTag : bool) `{ArithFact (size >? 0)} : monad rv (bool * mword (size * 8)) e :=
  (if allowTag then
     read_memt Read_plain addr size
   else
     (read_mem Read_plain a addr size >>= fun v => returnm (v, B0))) >>= fun '(v, t) =>
  maybe_fail "bool_of_bitU" (bool_of_bitU t) >>= fun t =>
  returnm (t, v).

Definition MEMea {regval a e} (addr : mword a) size                : monad regval unit e := write_mem_ea Write_plain a addr size.
Definition MEMea_conditional {regval a e} (addr : mword a) size    : monad regval unit e := write_mem_ea Write_conditional a addr size.

Definition MEMval {regval a e} (addr : mword a) (size : Z) (v : mword (8 * size))                      : monad regval unit e := write_mem Write_plain a addr size v >>= fun _ => returnm tt.
Definition MEMval_conditional {regval a e} (addr : mword a) (size : Z) (v : mword (8 * size))          : monad regval bool e := write_mem Write_conditional a addr size v.

Definition MEMval_tagged {rv a e} (addr : mword a) size t (v : mword (size * 8)) : monad rv unit e            := write_memt Write_plain addr size v (bitU_of_bool t) >>= fun _ => returnm tt.
Definition MEMval_tagged_conditional {rv a e} (addr : mword a) size t (v : mword (size * 8)) :monad rv bool e := write_memt Write_conditional addr size v (bitU_of_bool t).

Definition MEMw_tagged {rv a e} (addr : mword a) size t (v : mword (size * 8)) : monad rv unit e := MEMea addr size             >> MEMval_tagged addr size t v.
Definition MEMw_tagged_conditional {rv a e} (addr : mword a) size t (v : mword (size * 8)) : monad rv bool e := MEMea_conditional addr size >> MEMval_tagged_conditional addr size t v.

(* Some wrappers copied from aarch64_extras *)
(* TODO: Harmonise into a common library *)
(*
Definition get_slice_int_bl len n lo :=
  (* TODO: Is this the intended behaviour? *)
  let hi := lo + len - 1 in
  let bs := bools_of_int (hi + 1) n in
  subrange_list false bs hi lo

val get_slice_int : forall 'a. Bitvector 'a => integer -> integer -> integer -> 'a
Definition get_slice_int len n lo := of_bools (get_slice_int_bl len n lo)
*)
Definition write_ram {rv e} m size (_ : mword m) (addr : mword m) (data : mword (8 * size)) : monad rv unit e :=
  MEMea addr size >>
  MEMval addr size data.

Definition read_ram {rv e} m size `{ArithFact (size >=? 0)} (_ : mword m) (addr : mword m) : monad rv (mword (8 * size)) e := MEMr addr size.
(*
Definition string_of_bits bs := string_of_bv (bits_of bs).
Definition string_of_int := show

Definition _sign_extend bits len := maybe_failwith (of_bits (exts_bv len bits))
Definition _zero_extend bits len := maybe_failwith (of_bits (extz_bv len bits))
*)
Definition shift_bits_left {rv e a b} (v : mword a) (n : mword b) : monad rv (mword a) e :=
  maybe_fail "shift_bits_left" (unsigned n) >>= fun n =>
  returnm (shiftl v n).

Definition shift_bits_right {rv e a b} (v : mword a) (n : mword b) : monad rv (mword a) e :=
  maybe_fail "shift_bits_right" (unsigned n) >>= fun n =>
  returnm (shiftr v n).

Definition shift_bits_right_arith {rv e a b} (v : mword a) (n : mword b) : monad rv (mword a) e :=
  maybe_fail "shift_bits_right" (unsigned n) >>= fun n =>
  returnm (arith_shiftr v n).

(* Use constants for undefined values for now *)
Definition internal_pick {rv a e} (vs : list a) : monad rv a e :=
match vs with
| (h::_) => returnm h
| _ => Fail "empty list in internal_pick"
end.
Definition undefined_string {rv e} (_:unit) : monad rv string e := returnm ""%string.
Definition undefined_unit {rv e} (_:unit) : monad rv unit e := returnm tt.
Definition undefined_int {rv e} (_:unit) : monad rv Z e := returnm (0:ii).
(*val undefined_vector : forall 'rv 'a 'e. integer -> 'a -> monad 'rv (list 'a) 'e*)
Definition undefined_vector {rv a e} len (u : a) `{ArithFact (len >=? 0)} : monad rv (vec a len) e := returnm (vec_init u len).
(*val undefined_bitvector : forall 'rv 'a 'e. Bitvector 'a => integer -> monad 'rv 'a 'e*)
Definition undefined_bitvector {rv e} len `{ArithFact (len >=? 0)} : monad rv (mword len) e := returnm (mword_of_int 0).
(*val undefined_bits : forall 'rv 'a 'e. Bitvector 'a => integer -> monad 'rv 'a 'e*)
Definition undefined_bits {rv e} := @undefined_bitvector rv e.
Definition undefined_bit {rv e} (_:unit) : monad rv bitU e := returnm BU.
(*Definition undefined_real {rv e} (_:unit) : monad rv real e := returnm (realFromFrac 0 1).*)
Definition undefined_range {rv e} i j `{ArithFact (i <=? j)} : monad rv {z : Z & ArithFact (i <=? z <=? j)} e := returnm (build_ex i).
Definition undefined_atom {rv e} i : monad rv Z e := returnm i.
Definition undefined_nat {rv e} (_:unit) : monad rv Z e := returnm (0:ii).

Definition skip {rv e} (_:unit) : monad rv unit e := returnm tt.

(*val elf_entry : unit -> integer*)
Definition elf_entry (_:unit) : Z := 0.
(*declare ocaml target_rep function elf_entry := `Elf_loader.elf_entry`*)

(*Definition print_bits msg bs := prerr_endline (msg ^ (string_of_bits bs))

val get_time_ns : unit -> integer*)
Definition get_time_ns (_:unit) : Z := 0.
(*declare ocaml target_rep function get_time_ns := `(fun () -> Big_int.of_int (int_of_float (1e9 *. Unix.gettimeofday ())))`*)

Definition eq_bit (x : bitU) (y : bitU) : bool :=
  match x, y with
  | B0, B0 => true
  | B1, B1 => true
  | BU, BU => true
  | _,_ => false
  end.

Require Import Zeuclid.
Definition euclid_modulo (m n : Z) `{ArithFact (n >? 0)} : {z : Z & ArithFact (0 <=? z <=? n-1)}.
refine (existT _ (ZEuclid.modulo m n) _).
constructor.
destruct H.
unbool_comparisons; unbool_comparisons_goal.
assert (Z.abs n = n). { rewrite Z.abs_eq; auto with zarith. }
rewrite <- H at 3.
lapply (ZEuclid.mod_always_pos m n); lia.
Qed.

(* Override the more general version *)

Definition mults_vec {n} (l : mword n) (r : mword n) : mword (2 * n) := mults_vec l r.
Definition mult_vec {n} (l : mword n) (r : mword n) : mword (2 * n) := mult_vec l r.

Definition print_endline (_:string) : unit := tt.
Definition prerr_endline (_:string) : unit := tt.
Definition prerr_string (_:string) : unit := tt.
Definition putchar {T} (_:T) : unit := tt.
Require DecimalString.
Definition string_of_int z := DecimalString.NilZero.string_of_int (Z.to_int z).

Lemma __MIPS_read_lemma : forall width, 8 * width = 8 * (8 * width ÷ 8).
intros.
rewrite Z.mul_comm.
rewrite Z.quot_mul; auto with zarith.
Qed.
Hint Resolve __MIPS_read_lemma : sail.

Lemma MEMr_wrapper_lemma : forall size : Z, 8 * size = 8 * (8 * (8 * size ÷ 8) ÷ 8).
intros.
rewrite Z.mul_comm.
rewrite Z.quot_mul; auto with zarith.
rewrite Z.mul_comm with (m := size).
rewrite Z.quot_mul; auto with zarith.
Qed.
Hint Resolve MEMr_wrapper_lemma : sail.

Lemma getCapOffset_lemma {x0 x1 x2 x : Z} :
 0 <= x0 <= 18446744073709551616 - 1 ->
 0 <= x1 <= 18446744073709551616 - 1 ->
 18446744073709551616 <= x2 <= 18446744073709551616 ->
 x = ZEuclid.modulo (x0 - x1) x2 ->
 0 <= x <= 18446744073709551616 - 1.
intros.
match goal with H:context [ZEuclid.modulo ?X ?Y] |- _ => pose proof (ZEuclid.mod_always_pos X Y) end.
lia.
Qed.
Hint Resolve getCapOffset_lemma : sail.


From Coq Require Import ssreflect.
From stdpp Require Import strings gmap.
From melocoton.mlanguage Require Import mlanguage.
From iris.algebra Require Import stepindex.

Module Link.
Section Linking.
  Context {val : Type}.
  Context (public_state : Type).
  Context (Λ1 Λ2 : mlanguage val).
  Context {lk1: linkable Λ1 public_state}.
  Context {lk2: linkable Λ2 public_state}.

  Definition func : Type :=
    (Λ1.(func) + Λ2.(func)).

  Inductive simple_expr : Type :=
  (* The linked module produces a value
     (following one of the underlying modules producing a value) *)
  | ExprV (v : val)
  (* The linked module performs a call (corresponding to an external call
     performed by one of the underlying modules). This is not necessarily an
     external call of the linked module, it can correspond to a function
     implemented in the other linked module. *)
  | ExprCall (fn_name : string) (args : list val)
  (* Incoming call of one of the functions implemented by the linked module. It
     will be dispatched against the corresponding underlying module. *)
  | RunFunction (fn : func) (args : list val)
  (* Execution of code belonging to the first underlying module. *)
  | Expr1 (e : Λ1.(mlanguage.expr))
  (* Execution of code belonging to the second underlying module. *)
  | Expr2 (e : Λ2.(mlanguage.expr)).

  Definition cont : Type :=
    list (Λ1.(cont) + Λ2.(cont)).

  (* expr need to be wrapped in a fresh inductive for the language canonical
     structure to work when using WP *)
  Inductive expr : Type :=
    LkE (se: simple_expr) (k: cont).

  Definition private_state : Type :=
    (lk1.(private_state) * lk2.(private_state)).

  Inductive state : Type :=
    | St (pubσ : public_state)
             (privσ1 : lk1.(mlanguage.private_state))
             (privσ2 : lk2.(mlanguage.private_state))
    | St1 (σ1 : Λ1.(mlanguage.state)) (privσ2 : lk2.(mlanguage.private_state))
    | St2 (privσ1 : lk1.(mlanguage.private_state)) (σ2 : Λ2.(mlanguage.state)).

  Inductive split_state : state → public_state → private_state → Prop :=
    | LinkSplitSt pubσ privσ1 privσ2 :
      split_state (St pubσ privσ1 privσ2) pubσ (privσ1, privσ2).

  Definition of_val (v:val) : expr := LkE (ExprV v) [].
  Definition to_val (e:expr) : option val := match e with
    LkE (ExprV v) [] => Some v
  | _ => None end.

  Definition comp_cont (K1 K2 : cont) : cont :=
    K2 ++ K1.

  Definition resume_with (K : cont) (e : expr) : expr :=
    let 'LkE se k := e in
    LkE se (k ++ K).

  Definition apply_func (fn : func) (args : list val) : option expr :=
    Some (LkE (RunFunction fn args) []).

  Definition is_call e (fn_name:string) args C := e = LkE (ExprCall fn_name args) C.

  Local Notation prog := (gmap string func).

  Definition proj1_prog (p : prog) : mlanguage.prog Λ1 :=
    omap (λ fn, match fn with inl fn1 => Some fn1 | inr _ => None end) p.
  Definition proj2_prog (p : prog) : mlanguage.prog Λ2 :=
    omap (λ fn, match fn with inl _ => None | inr fn2 => Some fn2 end) p.

  Implicit Types X : expr * state → Prop.

  Inductive prim_step_mrel (p : prog) : expr * state → (expr * state → Prop) → Prop :=
  (* Internal step of an underlying module. *)
  | Step1S e1 C σ1 privσ2 (X1 X : _ → Prop) :
    mlanguage.to_val e1 = None →
    mlanguage.prim_step (proj1_prog p) (e1, σ1) X1 →
    (∀ e1' σ1',
      X1 (e1', σ1') →
      X (LkE (Expr1 e1') C, St1 σ1' privσ2)) →
    prim_step_mrel p (LkE (Expr1 e1) C, St1 σ1 privσ2) X
  | Step2S e2 C σ2 privσ1 (X2 X : _ → Prop) :
    mlanguage.to_val e2 = None →
    mlanguage.prim_step (proj2_prog p) (e2, σ2) X2 →
    (∀ e2' σ2',
       X2 (e2', σ2') →
       X (LkE (Expr2 e2') C, St2 privσ1 σ2')) →
    prim_step_mrel p (LkE (Expr2 e2) C, St2 privσ1 σ2) X
  (* Stuck module calls bubble up as calls at the level of the linking module.
     (They may get unstuck then, if they match a function implemented by the
     other module.) *)
  | MakeCall1S e1 C σ1 pubσ privσ1 privσ2 fn_name arg k1 X :
    mlanguage.is_call e1 fn_name arg k1 →
    proj1_prog p !! fn_name = None →
    mlanguage.split_state σ1 pubσ privσ1 →
    X (LkE (ExprCall fn_name arg) (inl k1 :: C), St pubσ privσ1 privσ2) →
    prim_step_mrel p (LkE (Expr1 e1) C, St1 σ1 privσ2) X
  | MakeCall2S e2 C σ2 pubσ privσ1 privσ2 fn_name arg k2 X :
    mlanguage.is_call e2 fn_name arg k2 →
    proj2_prog p !! fn_name = None →
    mlanguage.split_state σ2 pubσ privσ2 →
    X (LkE (ExprCall fn_name arg) (inr k2 :: C), St pubσ privσ1 privσ2) →
    prim_step_mrel p (LkE (Expr2 e2) C, St2 privσ1 σ2) X
  (* Producing a value when execution is finished *)
  | Val1S e1 C σ1 v pubσ privσ1 privσ2 X :
    mlanguage.to_val e1 = Some v →
    (* Splitting the state is angelic, the underlying language can choose a concrete splitting. *)
    (* If no such splitting exists, we have UB *)
    mlanguage.split_state σ1 pubσ privσ1 →
    X (LkE (ExprV v) C, St pubσ privσ1 privσ2) →
    prim_step_mrel p (LkE (Expr1 e1) C, St1 σ1 privσ2) X
  | Val2S e2 C σ2 v pubσ privσ1 privσ2 X :
    mlanguage.to_val e2 = Some v →
    (* Splitting the state is angelic, the underlying language can choose a concrete splitting. *)
    (* If no such splitting exists, we have UB *)
    mlanguage.split_state σ2 pubσ privσ2 →
    X (LkE (ExprV v) C, St pubσ privσ1 privσ2) →
    prim_step_mrel p (LkE (Expr2 e2) C, St2 privσ1 σ2) X
  (* Entering a function. Change the view of the heap in the process.
     Merging the state is angelic. *)
  | RunFunction1S fn1 args C e1 σ1 pubσ privσ1 privσ2 X :
    mlanguage.apply_func fn1 args = Some e1 →
    mlanguage.split_state σ1 pubσ privσ1 →
    X (LkE (Expr1 e1) C, St1 σ1 privσ2) →
    prim_step_mrel p (LkE (RunFunction (inl fn1) args) C, St pubσ privσ1 privσ2) X
  | RunFunction2S fn2 args C e2 σ2 pubσ privσ1 privσ2 X :
    mlanguage.apply_func fn2 args = Some e2 →
    mlanguage.split_state σ2 pubσ privσ2 →
    X (LkE (Expr2 e2) C, St2 privσ1 σ2) →
    prim_step_mrel p (LkE (RunFunction (inr fn2) args) C, St pubσ privσ1 privσ2) X
  (* Continuing execution by returning a value to its caller. *)
  | Ret1S v k1 C σ1 pubσ privσ1 privσ2 X :
    mlanguage.split_state σ1 pubσ privσ1 →
    X (LkE (Expr1 (mlanguage.resume_with k1 (mlanguage.of_val Λ1 v))) C, St1 σ1 privσ2) →
    prim_step_mrel p (LkE (ExprV v) (inl k1 :: C), St pubσ privσ1 privσ2) X
  | Ret2S v k2 C σ2 pubσ privσ1 privσ2 X :
    mlanguage.split_state σ2 pubσ privσ2 →
    X (LkE (Expr2 (mlanguage.resume_with k2 (mlanguage.of_val Λ2 v))) C, St2 privσ1 σ2) →
    prim_step_mrel p (LkE (ExprV v) (inr k2 :: C), St pubσ privσ1 privσ2) X
  (* Resolve an internal call to a module function *)
  | CallS fn_name fn arg σ C X :
    p !! fn_name = Some fn →
    X (LkE (RunFunction fn arg) C, σ) →
    prim_step_mrel p (LkE (ExprCall fn_name arg) C, σ) X
  (* Terminate execution with NB on values *)
  | ValStopS v σ X :
    prim_step_mrel p (LkE (ExprV v) [], σ) X.

  Program Definition prim_step (p : prog) : umrel (expr * state) :=
    {| mrel := prim_step_mrel p |}.
  Next Obligation.
    intros p. intros [[se k] σ] X Y Hstep HXY. inversion Hstep; subst;
      [ eapply Step1S | eapply Step2S | eapply MakeCall1S | eapply MakeCall2S
      | eapply Val1S | eapply Val2S | eapply RunFunction1S | eapply RunFunction2S
      | eapply Ret1S | eapply Ret2S | eapply CallS | eapply ValStopS ];
      eauto; naive_solver.
  Qed.

  Lemma mlanguage_mixin :
    MlanguageMixin (val:=val) of_val to_val is_call resume_with comp_cont
      apply_func prim_step.
  Proof using.
    constructor.
    - intros v. done.
    - intros e c. destruct e as [e [|]]; destruct e; cbn; intros; by simplify_eq.
    - intros *. eapply ValStopS.
    - intros p e fn_name arg C σ X ->. split.
      + inversion 1; simplify_eq. do 2 eexists. repeat split; eauto.
      + intros (?&[]&?&?&?). unfold apply_func in *. simplify_eq.
        econstructor; eauto.
    - intros e [v Hv] f vs C ->. done.
    - intros ? C1 C2 s vv ->. cbn. done.
    - intros [] C [v Hv]; cbn in Hv. repeat case_match; simplify_eq.
      apply app_eq_nil in H0 as [-> ->]. done.
    - intros [] C1 C2. rewrite /= app_assoc //.
    - intros p C [es eC] σ X Hnv. inversion 1; simplify_eq.
      1,2: econstructor; eauto; intros; eexists (LkE _ _); by eauto. (* StepS *)
      { eapply MakeCall1S; eauto; eexists (LkE _ _); split; eauto;
          unfold resume_with; by eauto. }
      { eapply MakeCall2S; eauto; eexists (LkE _ _); split; eauto;
          unfold resume_with; by eauto. }
      { eapply Val1S; eauto. eexists (LkE _ _). split; eauto. }
      { eapply Val2S; eauto. eexists (LkE _ _). split; eauto. }
      1,2: econstructor; eauto; eexists (LkE _ _); split; eauto. (* RunFunctionS *)
      1,2: econstructor; eauto; eexists (LkE _ _); split; eauto. (* RetS *)
      eapply CallS; eauto; eexists (LkE _ _); split; eauto.
    - intros p [[] eC] σ Hnv; simplify_eq;
        try by (intros _; inversion 1; simplify_eq; eauto).
      + destruct eC as [|[] eC']; first done; intros _;
          inversion 1; simplify_eq; eauto.
      + intros _. inversion 1; simplify_eq; eauto.
        eapply prim_step_no_NB in H5 as (e1 & σ1' & ?); eauto.
      + intros _. inversion 1; simplify_eq; eauto.
        eapply prim_step_no_NB in H5 as (e2 & σ2' & ?); eauto.
  Qed.
End Linking.
End Link.

Arguments Link.ExprV {_ _ _} _.
Arguments Link.ExprCall {_ _ _} _ _.
Arguments Link.RunFunction {_ _ _} _ _.
Arguments Link.Expr1 {_ _ _} _.
Arguments Link.Expr2 {_ _ _} _.
Arguments Link.St {_ _ _ _ _ _} _ _ _.
Arguments Link.St1 {_ _ _ _ _ _} _ _.
Arguments Link.St2 {_ _ _ _ _ _} _ _.

Arguments Link.LkE {_ _ _} _ _.
Notation LkSE se := (Link.LkE se []).

Canonical Structure link_lang {val public_state} Λ1 Λ2 {lk1 lk2} : mlanguage val :=
  Mlanguage (@Link.mlanguage_mixin val public_state Λ1 Λ2 lk1 lk2).

Global Program Instance link_linkable
  {val public_state} (Λ1 Λ2 : mlanguage val)
  (lk1 : linkable Λ1 public_state)
  (lk2 : linkable Λ2 public_state) :
linkable (link_lang Λ1 Λ2) public_state := {
  mlanguage.private_state := Link.private_state _ Λ1 Λ2;
  mlanguage.split_state := Link.split_state _ Λ1 Λ2;
}.

Definition link_prog {val public_state} (Λ1 Λ2 : mlanguage val)
  {lk1 : linkable Λ1 public_state} {lk2 : linkable Λ2 public_state}
  (p1 : mlang_prog Λ1) (p2 : mlang_prog Λ2) :
mlang_prog (link_lang Λ1 Λ2) :=
  fmap inl p1 ∪ fmap inr p2.


From cap_machine Require Export logrel.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import weakestpre adequacy lifting.
From stdpp Require Import base.
From cap_machine Require Import ftlr_base monotone.
From cap_machine Require Import rules_base interp_weakening.
From cap_machine.rules Require Import rules_Lea.

Section fundamental.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          {stsg : STSG Addr region_type Σ} {heapg : heapG Σ}
          {nainv: logrel_na_invs Σ}
          `{MachineParameters}.

  Notation STS := (leibnizO (STS_states * STS_rels)).
  Notation STS_STD := (leibnizO (STS_std_states Addr region_type)).
  Notation WORLD := (prodO STS_STD STS).
  Implicit Types W : WORLD.

  Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ).
  Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ).
  Implicit Types w : (leibnizO Word).
  Implicit Types interp : (D).

  Lemma lea_case (W : WORLD) (r : leibnizO Reg) (p : Perm)
        (g : Locality) (b e a : Addr) (w : Word) (ρ : region_type) (dst : RegName) (r0 : Z + RegName) (P:D):
    ftlr_instr W r p g b e a w (Lea dst r0) ρ P.
  Proof.
    intros Hp Hsome i Hbae Hpers Hpwl Hregion Hnotrevoked Hnotmonostatic Hnotuninitialized Hi.
    iIntros "#IH #Hinv #Hreg #Hinva #Hrcond #Hwcond Hmono Hw Hsts Hown".
    iIntros "Hr Hstate Ha HPC Hmap".
    rewrite delete_insert_delete.
    iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /=";
      [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl.
    iApply (wp_lea with "[$Ha $Hmap]"); eauto.
    { by rewrite lookup_insert. }
    { rewrite /subseteq /map_subseteq /set_subseteq. intros rr _.
      apply elem_of_gmap_dom. apply lookup_insert_is_Some'; eauto. }

    iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]".
    destruct HSpec as [ * Hdst ? Hz Hoffset HUa HincrPC |].
    { apply incrementPC_Some_inv in HincrPC as (p''&g''&b''&e''&a''& ? & HPC & Z & Hregs' & XX).

      assert (p'' = p ∧ g'' = g ∧ b'' = b ∧ e'' = e) as (-> & -> & -> & ->).
      { destruct (decide (PC = dst)); simplify_map_eq; auto. }

      iApply wp_pure_step_later; auto. iNext.
      iDestruct (region_close with "[$Hstate $Hr $Ha $Hmono Hw]") as "Hr"; eauto.
      { destruct ρ;auto;[|specialize (Hnotmonostatic g1)|specialize (Hnotuninitialized w0)];contradiction. }
      iApply ("IH" $! _ regs' with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]").
      { cbn. intros. subst regs'. by repeat (apply lookup_insert_is_Some'; right). }
      { iIntros (ri Hri). subst regs'.
        erewrite locate_ne_reg; [ | | reflexivity]; auto.
        destruct (decide (ri = dst)).
        { subst ri. unshelve iSpecialize ("Hreg" $! dst _); eauto.
          erewrite locate_eq_reg; [ | reflexivity]; auto. simplify_map_eq.
          rewrite /RegLocate Hdst. iApply interp_weakening; eauto; try solve_addr.
          - destruct p0; simpl; auto.
          - eapply PermFlowsToReflexive.
          - destruct g0; auto. }
        { repeat (erewrite locate_ne_reg; [ | | reflexivity]; auto).
          iApply "Hreg"; auto. } }
      { subst regs'. rewrite insert_insert. iApply "Hmap". }
      { iPureIntro. tauto. }
      eauto. }
    { iApply wp_pure_step_later; auto. iNext.
      iApply wp_value; auto. iIntros; discriminate. }
  Qed.

End fundamental.


From iris.algebra Require Import gmap auth agree gset coPset excl csum.
From Perennial.base_logic.lib Require Export fancy_updates.
From stdpp Require Export namespaces.
From Perennial.base_logic.lib Require Import wsat invariants ae_invariants saved_prop.
From Perennial.Helpers Require Import Qextra.
From iris.algebra Require Import gmap.
From iris.proofmode Require Import tactics.
From Perennial.program_logic Require Export step_fupd_extra crash_weakestpre ae_invariants_mutable later_res private_invariants staged_invariant_alt.
From iris.prelude Require Import options.

Set Default Proof Using "Type".

#[global]
Existing Instances pri_inv_tok_timeless later_tok_timeless.

Section def.
Context `{IRISG: !irisGS Λ Σ, !generationGS Λ Σ}.
Context `{!pri_invG IRISG}.
Context `{!later_tokG IRISG}.
Context `{!stagedG Σ}.

Definition staged_value_inuse e E1' E1 mj mj_wp mj_ukeep Φ Φc P :=
  (∃ E2 mj_wp_init mj_ishare mj_ushare γsaved γfinished γstatus γprop γprop',
      ⌜ E1 ⊆ E1' ⌝ ∗
      ⌜ to_val e = None ⌝ ∗
      ⌜ (1 < mj + mj_ukeep)%Qp ⌝ ∗
      ⌜ (mj_ukeep + mj_ushare = /2)%Qp ⌝ ∗
      ⌜ (mj_wp ≤ mj) ⌝%Qp ∗
      ⌜ (mj_wp ≤ / 2 + mj_ishare) ⌝%Qp ∗
      own γsaved (◯ Excl' (γprop, γprop')) ∗
      own γstatus (◯ Excl' (inuse mj_wp mj_ushare)) ∗
      saved_prop_own γprop DfracDiscarded (wpc0 NotStuck mj_wp E1 e
                     (λ v : val Λ, (wpc_crash_modality E1 mj_wp P) ∗ (wpc_crash_modality E1 mj_wp Φc ∧ Φ v))
                     (Φc ∗ P)) ∗
      saved_prop_own γprop' DfracDiscarded Φc ∗
      later_tok ∗
      pri_inv_tok mj_ukeep E2 ∗
      ⌜ /2 < mj ⌝%Qp ∗
      pri_inv E2 (staged_inv_inner E1' E2 mj_wp_init mj_ishare γsaved γfinished γstatus P))%I.

End def.

Section inv.
Context `{IRISG: !irisGS Λ Σ, !generationGS Λ Σ}.
Context `{!pri_invG IRISG}.
Context `{!later_tokG IRISG}.
Context `{!stagedG Σ}.
Implicit Types i : positive.
Implicit Types N : namespace.
Implicit Types P Q R : iProp Σ.

Lemma wpc_staged_inv_aux e E1' mj mj_wp mj_ukeep Φ Φc P :
  staged_value_inuse e E1' ⊤ mj mj_wp mj_ukeep Φ Φc P -∗
  wpc0 NotStuck mj ⊤ e Φ Φc.
Proof.
  iIntros "Hsv".
  iLöb as "IH" forall (e).
  iDestruct "Hsv" as (????????? Hsub)
    "(%Hnval&%Hinvalid&%Heq_mj&%Hle2&%Hinvalid2&Hown&Hownstat&#Hsaved1&#Hsaved2&Hltok&Hitok&%Hlt2&#Hinv)".
  iEval (rewrite wpc0_unfold).
  rewrite /wpc_pre. iSplit; last first.
  {
    iIntros (g1 ns D' κs) "Hg #HC Hlc".
    iDestruct (pri_inv_tok_disj with "[$]") as %[Hdisj|Hval]; last first.
    { exfalso. apply Qp.lt_nge in Hinvalid. revert Hval. rewrite frac_valid. eauto. }
    iMod (pri_inv_acc with "[$]") as "(Hinner&Hclo)".
    { set_solver. }
    iEval (rewrite staged_inv_inner_unfold) in "Hinner".
    iDestruct "Hinner" as (?????) "(>Hown'&#Hsaved1'&#Hsaved2'&>Hstatus'&>Hitok_ishare&Hinner)".
    iDestruct (own_valid_2 with "Hown' Hown") as "#H".
    iDestruct "H" as %[Heq%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
    iDestruct (own_valid_2 with "Hstatus' Hownstat") as "#Heq_status".
    iDestruct "Heq_status" as %[Heq_status%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
    inversion Heq; subst.
    iMod (later_tok_decr with "[$]") as (ns' Hlt') "Hg".
    iMod (fupd2_mask_subseteq ∅ ∅) as "Hclo'"; [set_solver+..|].
    iModIntro. iApply (step_fupd2N_le (S (S (num_laters_per_step ns')))).
    { etransitivity; last eapply (num_laters_per_step_exp ns'); lia. }
    iDestruct (saved_prop_agree with "Hsaved1 Hsaved1'") as "Hequiv1".
    iDestruct (saved_prop_agree with "Hsaved2 Hsaved2'") as "Hequiv2".
    iEval (simpl).
    iModIntro. iModIntro. iModIntro.
    iDestruct "Hinner" as "[(%Hlt''&HPs&Hs)|Hfin]"; last first.
    {
      iDestruct "Hfin" as "(HPR&Hrest)".
      iMod (saved_prop_alloc True%I) as (γprop_remainder') "#Hsaved2''".
      { apply dfrac_valid_discarded. }
      iMod (own_update_2 _ _ _ (● Excl' (γprop_stored, γprop_remainder') ⋅
                                  ◯ Excl' (γprop_stored, γprop_remainder'))
              with "Hown' Hown") as "[Hown' Hown]".
      { by apply auth_update, option_local_update, exclusive_local_update. }
      iApply step_fupd2N_later. iModIntro. iNext. iModIntro. iNext.
      iMod "Hclo'".
      iMod ("Hclo" with "[-Hg HPR]").
      { iNext. iEval (rewrite staged_inv_inner_unfold). iExists _, _, _, _, _. iFrame "∗ #". }
      iRewrite "Hequiv2". iFrame.
      iMod (global_state_interp_le with "[$]") as "$"; auto.
      lia.
    }
    iModIntro. iNext.
    iDestruct "Hs" as "(Hitok'&#Hwand)".
    iMod "Hclo'".
    iDestruct (pri_inv_tok_join with "Hitok Hitok'") as "Hitok".
    rewrite Heq_mj.
    iDestruct (pri_inv_tok_join with "Hitok Hitok_ishare") as "Hitok".
    iDestruct (pri_inv_tok_global_le_acc _ _ _ mj_wp with "[] Hg") as "(Hg_inv&Hg_inv_clo)".
    { iPureIntro; split; naive_solver. }
    iDestruct (pri_inv_tok_le_acc mj_wp with "Hitok") as "(Hitok_wp&Hitok_inv_clo)".
    { naive_solver. }
    iMod (pri_inv_tok_disable_reenable with "[$]") as "(Hg&Hreenable)".
    iRewrite -"Hequiv1" in "HPs".
    iEval (rewrite wpc0_unfold /wpc_pre) in "HPs".
    iDestruct "HPs" as "(_&HPs)".

    rewrite /wpc_crash_modality.
    replace (⊤ ∖ D' ∖ E2) with (⊤ ∖ (E2 ∪ D')) by set_solver.
    iDestruct (lc_weaken with "Hlc") as "Hlc".
    { apply (num_laters_per_step_exp ns'). lia. }
    iDestruct "Hlc" as "[[Hlc1 Hlc2] Hlc3]".
    iSpecialize ("HPs" with "[$] [$] [$]").
    iMod "HPs".
    iModIntro. iApply (step_fupd2N_wand with "HPs"). iIntros "HPs".
    iMod "HPs" as "(Hg&HPr&HP)".
    iMod ("Hreenable" with "[$Hg]") as "(Hitok&Hg)".
    iDestruct ("Hitok_inv_clo" with "[$]") as "Hitok".
    iDestruct (pri_inv_tok_split with "Hitok") as "(Hitok&Hitok_ishare)".
    rewrite -Heq_mj.
    iDestruct (pri_inv_tok_split with "Hitok") as "(Hitok_ukeep&Hitok_ushare)".
    iMod (saved_prop_alloc True%I) as (γprop_remainder') "#Hsaved2''".
    { apply dfrac_valid_discarded. }
    iMod (own_update_2 _ _ _ (● Excl' (γprop_stored, γprop_remainder') ⋅
                                ◯ Excl' (γprop_stored, γprop_remainder'))
            with "Hown' Hown") as "[Hown' Hown]".
    { by apply auth_update, option_local_update, exclusive_local_update. }
    iDestruct ("Hg_inv_clo" with "[$]") as "Hg".

    iMod ("Hclo" with "[-HPr Hg]").
    { iNext. iEval (rewrite staged_inv_inner_unfold). iExists _, _, _, _, _. iFrame "∗ #". iRight. iFrame. }
    iFrame.
    iMod (global_state_interp_le _ ns with "[$]"); first lia. iModIntro; iFrame.
  }
  {
    rewrite Hnval.
    iIntros (q σ1 g1 ns D κ κs nt) "Hσ Hg HNC Hlc".
    iDestruct (pri_inv_tok_disj with "[$]") as %[Hdisj|Hval]; last first.
    { exfalso. apply Qp.lt_nge in Hinvalid. revert Hval. rewrite frac_valid. eauto. }
    iMod (pri_inv_acc with "[$]") as "(Hinner&Hclo)".
    { set_solver. }
    iEval (rewrite staged_inv_inner_unfold) in "Hinner".
    iDestruct "Hinner" as (?????) "(>Hown'&#Hsaved1'&#Hsaved2'&>Hstatus'&>Hitok_ishare&Hinner)".
    iDestruct (own_valid_2 with "Hown' Hown") as "#H".
    iDestruct "H" as %[Heq%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
    iDestruct (own_valid_2 with "Hstatus' Hownstat") as "#Heq_status".
    iDestruct "Heq_status" as %[Heq_status%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
    inversion Heq; subst.
    iMod (later_tok_decr with "[$]") as (ns' Hlt') "Hg".
    iMod (fupd2_mask_subseteq ∅ ∅) as "Hclo'"; [set_solver+..|].
    iModIntro. iApply (step_fupd2N_le (S (S (S (num_laters_per_step ns'))))).
    { assert (ns' < ns) as Hlt by lia. apply num_laters_per_step_exp in Hlt. lia. }
    iDestruct (saved_prop_agree with "Hsaved1 Hsaved1'") as "Hequiv1".
    iDestruct (saved_prop_agree with "Hsaved2 Hsaved2'") as "Hequiv2".
    iEval (simpl).
    iModIntro. iModIntro. iModIntro.
    iDestruct "Hinner" as "[(%Hlt''&HPs&Hs)|Hfin]"; last first.
    {
      iDestruct "Hfin" as "(HPR&HC&Hrest)".
      iDestruct (NC_C with "[$] [$]") as %[].
    }
    iModIntro. iNext.
    iDestruct "Hs" as "(Hitok'&#Hwand)".
    iMod "Hclo'".
    iDestruct (pri_inv_tok_join with "Hitok Hitok'") as "Hitok".
    rewrite Heq_mj.
    iDestruct (pri_inv_tok_join with "Hitok Hitok_ishare") as "Hitok".
    iDestruct (pri_inv_tok_global_le_acc _ _ _ mj_wp with "[] Hg") as "(Hg_inv&Hg_inv_clo)".
    { iPureIntro; split; naive_solver. }
    iDestruct (pri_inv_tok_le_acc mj_wp with "Hitok") as "(Hitok_wp&Hitok_inv_clo)".
    { naive_solver. }
    iMod (pri_inv_tok_disable_reenable with "[$]") as "(Hg&Hreenable)".
    iRewrite -"Hequiv1" in "HPs".
    iEval (rewrite wpc0_unfold /wpc_pre) in "HPs".
    iDestruct "HPs" as "(Hwp&_)".
    rewrite Hnval.
    replace (⊤ ∖ D ∖ E2) with (⊤ ∖ (E2 ∪ D)) by set_solver.
    iMod ("Hwp" with "[$] [$] [$] [Hlc]") as "Hwp".
    { iApply (lc_weaken with "Hlc").
      apply num_laters_per_step_lt in Hlt'. lia. }
    iModIntro. iApply (step_fupd2N_wand with "Hwp").
    iIntros "($&Hwp)".
    iIntros. iMod ("Hwp" with "[//]") as "($&Hg&H&Hefs&HNC)".
    destruct (to_val e2) eqn:Heq_val.
    {
      iEval (rewrite wpc0_unfold /wpc_pre) in "H".
      iDestruct "H" as "(H&_)".
      rewrite Heq_val.
      iMod ("H" with "[$] [$]") as "H".
      iDestruct "H" as "((Hcm&Hv)&Hg&HNC)".
      iMod (saved_prop_alloc (wpc_crash_modality ⊤ mj_wp P)) as (γprop_stored') "#Hsaved1''".
      { apply dfrac_valid_discarded. }
      iMod (saved_prop_alloc True%I) as (γprop_remainder') "#Hsaved2''".
      { apply dfrac_valid_discarded. }
      iMod (own_update_2 _ _ _ (● Excl' (γprop_stored', γprop_remainder') ⋅
                                ◯ Excl' (γprop_stored', γprop_remainder'))
              with "Hown' Hown") as "[Hown' Hown]".
      { by apply auth_update, option_local_update, exclusive_local_update. }
      iMod ("Hreenable" with "[$Hg]") as "(Hitok&Hg)".
      iDestruct ("Hitok_inv_clo" with "[$]") as "Hitok".
      iDestruct (pri_inv_tok_split with "[$Hitok]") as "(Hitok&Hitok_ishare)".
      iEval (rewrite -Heq_mj) in "Hitok".
      iDestruct (pri_inv_tok_split with "[$Hitok]") as "(Hitok_ukeep&Hitok_ushare)".
      iMod ("Hclo" with "[Hown' Hstatus' Hcm Hitok_ishare Hitok_ushare]").
      { iNext.
        iEval (rewrite staged_inv_inner_unfold).
        iExists _, _, _, _, _. iFrame "∗ #".
        iLeft.
        iSplit.
        { iPureIntro. split_and!; auto; try naive_solver. }
        iFrame.
        iModIntro. iIntros "Hwpc".
        assert (E1' = ⊤) as -> by set_solver.
        rewrite /wpc_crash_modality.
        iIntros (????) "Hg HC Hlc".
        iSpecialize ("Hwpc" with "[$] [$] [$]").
        iApply (step_fupd2N_inner_wand with "Hwpc"); auto.
        iIntros "($&$)"; eauto.
      }
      iMod (later_tok_incr with "[$]") as "(Hg&Hltok)".
      iDestruct ("Hg_inv_clo" with "Hg") as "Hg".
      iMod (global_state_interp_le with "Hg") as "$".
      { apply Nat.le_succ_l, step_count_next_mono; lia. }
      iModIntro. iFrame.
      iSplitR "Hefs".
      - iEval (rewrite wpc0_unfold /wpc_pre).
        rewrite Heq_val.
        iSplit.
        * iIntros. iModIntro. iFrame. iDestruct "Hv" as "(_&$)".
        * iDestruct "Hv" as "(H&_)". iIntros.
          iDestruct (pri_inv_tok_global_le_acc _ _ _  mj_wp with "[] [$]") as "(Hg&Hg_clo)".
          { iPureIntro; naive_solver. }
          iSpecialize ("H" with "[$] [$] [$]").
          iApply (step_fupd2N_inner_wand with "H"); auto.
          iIntros "(Hg&$)".
          iApply "Hg_clo". iFrame.
      - iApply (big_sepL_mono with "Hefs").
        iIntros. iApply (wpc0_mj_le); last by iFrame.
        split; auto. naive_solver.
    }
    iFrame "HNC".
    iMod (saved_prop_alloc
            (wpc0 NotStuck mj_wp ⊤ e2
              (λ v : val Λ, wpc_crash_modality ⊤ mj_wp P ∗ (wpc_crash_modality ⊤ mj_wp Φc ∧ Φ v))
              (Φc ∗ P))%I) as (γprop_stored') "#Hsaved1''".
    { apply dfrac_valid_discarded. }
    iMod (saved_prop_alloc Φc) as (γprop_remainder') "#Hsaved2''".
    { apply dfrac_valid_discarded. }
    iMod (own_update_2 _ _ _ (● Excl' (γprop_stored', γprop_remainder') ⋅
                              ◯ Excl' (γprop_stored', γprop_remainder'))
            with "Hown' Hown") as "[Hown' Hown]".
    { by apply auth_update, option_local_update, exclusive_local_update. }
    iMod (own_update_2 _ _ _ (● Excl' (inuse mj_wp mj_ushare) ⋅ ◯ Excl' (inuse mj_wp mj_ushare))
            with "Hstatus' Hownstat") as "[Hstatus' Hownstat]".
    { by apply auth_update, option_local_update, exclusive_local_update. }
    iMod ("Hreenable" with "[$Hg]") as "(Hitok&Hg)".
    iDestruct ("Hitok_inv_clo" with "[$]") as "Hitok".
    iDestruct (pri_inv_tok_split with "[$Hitok]") as "(Hitok&Hitok_ishare)".
    iEval (rewrite -Heq_mj) in "Hitok".
    iDestruct (pri_inv_tok_split with "[$Hitok]") as "(Hitok_ukeep&Hitok_ushare)".
    iMod ("Hclo" with "[Hown' Hstatus' H Hitok_ishare Hitok_ushare]").
    { iNext.
      iEval (rewrite staged_inv_inner_unfold).
      iExists _, _, _, _, _. iFrame "∗ #".
      iLeft.
      iSplit.
      { iPureIntro. split_and!; auto; try naive_solver. }
      iFrame.
      iModIntro. iIntros "Hwpc".
      iEval (rewrite wpc0_unfold) in "Hwpc". iDestruct "Hwpc" as "(_&Hwpc)".
      rewrite /wpc_crash_modality.
      iIntros (????) "Hg HC Hlc".
      iSpecialize ("Hwpc" with "[$] [$] [$]").
      iApply (step_fupd2N_inner_wand with "Hwpc"); auto.
    }
    iDestruct ("Hg_inv_clo" with "Hg") as "Hg".
    iMod (later_tok_incr with "[$]") as "(Hg&Hltok)".
    iMod (global_state_interp_le with "Hg") as "$".
    { apply Nat.le_succ_l, step_count_next_mono; lia. }
    iModIntro. iSplitR "Hefs"; last first.
    { iApply (big_sepL_mono with "Hefs").
      iIntros. iApply (wpc0_mj_le); last by iFrame.
      split; auto. naive_solver.
    }
    iApply "IH".
    iExists _, _, mj_ishare, _, _, _, _, _. iExists _. iFrame "∗".
    iSplit; first eauto.
    iFrame "Hsaved1'' Hsaved2''".
    iSplit; first eauto.
    iSplit; first eauto.
    iSplit.
    { iPureIntro. rewrite /mj_wp. naive_solver. }
    iSplit; first eauto.
    iSplit; first eauto.
    iSplit; first eauto.
    iExact "Hinv".
  }
Qed.

Lemma wpc_staged_inv_inuse E1 e Φ Φc Qs P :
  to_val e = None →
  staged_value ⊤ Qs P ∗
  ((∀ mj_wp, wpc_crash_modality E1 mj_wp Φc) ∧
   (Qs -∗ ∀ mj_wp, ⌜ (/2 < mj_wp)%Qp ⌝ → WPC e @ E1
                                 {{λ v, wpc_crash_modality ⊤ mj_wp P ∗ (wpc_crash_modality E1 mj_wp Φc ∧ Φ v)}}
                                 {{ Φc ∗ P }}))
  ⊢ WPC e @ E1 {{ Φ }} {{ Φc }}.
Proof.
  iIntros (Hnval) "(Hstaged&Hwp)".
  iDestruct "Hstaged" as (??????) "(Hown&Hownstat&#Hsaved1&#Hsaved2&Hltok&Hitok&Hinv)".
  iDestruct "Hinv" as (mj_wp_init mj_ishare Hlt) "#Hinv".
  rewrite /staged_inv.
  rewrite wpc_eq /wpc_def. iIntros (mj).

  iLöb as "IH" forall (γprop γprop' Qs) "Hsaved1 Hsaved2".

  (* Base case *)
  iEval (rewrite wpc0_unfold).
  rewrite /wpc_pre. iSplit; last first.
  {
    iDestruct "Hwp" as "(Hwp&_)".
    iIntros (g1 ns D' κs) "Hg #HC Hlc".
    iSpecialize ("Hwp" $! mj with "[$] [$] [$]").
    iApply (step_fupd2N_inner_wand with "Hwp"); auto.
  }
  rewrite Hnval.
  iIntros (q σ1 g1 ns D κ κs nt) "Hσ Hg HNC Hlc".
  iDestruct (pri_inv_tok_disj_inv_half with "[$]") as %Hdisj.
  iMod (pri_inv_acc with "[$]") as "(Hinner&Hclo)".
  { set_solver. }
  iEval (rewrite staged_inv_inner_unfold) in "Hinner".
  iDestruct "Hinner" as (?????) "(>Hown'&#Hsaved1'&#Hsaved2'&>Hstatus'&>Hitok_ishare&Hinner)".
  iDestruct (own_valid_2 with "Hown' Hown") as "#H".
  iDestruct "H" as %[Heq%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
  iDestruct (own_valid_2 with "Hstatus' Hownstat") as "#Heq_status".
  iDestruct "Heq_status" as %[Heq_status%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
  inversion Heq; subst.
  iMod (later_tok_decr with "[$]") as (ns' Hlt') "Hg".
  iMod (fupd2_mask_subseteq ∅ ∅) as "Hclo'"; [set_solver+..|].
  iModIntro. simpl. iModIntro. iNext. iModIntro. iApply (step_fupd2N_le (S (S (num_laters_per_step ns')))).
  { etransitivity; last eapply (num_laters_per_step_exp ns'); lia. }
  simpl.
  iDestruct (saved_prop_agree with "Hsaved1 Hsaved1'") as "Hequiv1".
  iDestruct (saved_prop_agree with "Hsaved2 Hsaved2'") as "Hequiv2".
  iModIntro. iModIntro. iModIntro.
  iDestruct "Hinner" as "[(HPs&_)|Hfin]"; last first.
  { (* Impossible, since we have NC token. *)
    iDestruct "Hfin" as "(_&HC&_)". iDestruct (NC_C with "[$] [$]") as %[]. }
  iRewrite -"Hequiv1" in "HPs".
  iDestruct "Hwp" as "(_&Hwp)".
  iSpecialize ("Hwp" with "[$]").

  iDestruct (pri_inv_tok_global_valid with "Hg") as %(Hmin&Hvalid).
  destruct (Qp_plus_inv_2_gt_1_split mj) as (mj_ukeep&mj_ushare&Heq_mj&Hinvalid); first auto.
  set (mj_wp := (mj_wp_init `min` mj `min` (/2 + mj_ishare) `min` (/2 + mj_ushare))%Qp).
  assert (/ 2 < mj_wp)%Qp.
  {
    - rewrite /mj_wp. apply Qp_min_glb1_lt; auto.
      * apply Qp_min_glb1_lt; auto.
        ** apply Qp_min_glb1_lt; auto.
        ** apply Qp.lt_add_l.
      * apply Qp.lt_add_l.
  }
  iDestruct (pri_inv_tok_global_le_acc _ _ _ mj_wp with "[] Hg") as "(Hg_inv&Hg_inv_clo)".
  { iPureIntro; split; auto.
    rewrite /mj_wp.
    etransitivity; first eapply Qp.le_min_l.
    etransitivity; first eapply Qp.le_min_l.
    apply Qp.le_min_r.
  }

  iDestruct (pri_inv_tok_join with "[$Hitok] [$]") as "Hitok".
  iDestruct (pri_inv_tok_le_acc mj_wp with "Hitok") as "(Hitok_wp&Hitok_inv_clo)".
  { rewrite /mj_wp.
    etransitivity; first eapply Qp.le_min_l.
    apply Qp.le_min_r. }

  iMod (pri_inv_tok_disable_reenable with "[$]") as "(Hg&Hreenable)".
  unshelve (iSpecialize ("Hwp" $! mj_wp _ mj_wp)).
  { rewrite //=. }
  iEval (rewrite wpc0_unfold) in "Hwp".
  iDestruct "Hwp" as "(Hwp&_)".
  iMod ("Hclo'").
  rewrite Hnval.
  replace (⊤ ∖ D ∖ E2) with (⊤ ∖ (E2 ∪ D)) by set_solver.
  iMod ("Hwp" with "[$] [$] [$] [Hlc]") as "Hwp".
  { iApply (lc_weaken with "Hlc").
    apply num_laters_per_step_lt in Hlt'. lia. }
  simpl. iMod "Hwp". iModIntro. iNext. iMod "Hwp". iModIntro.
  iApply (step_fupd2N_wand with "Hwp"). iIntros "(%Hred&Hwp)".
  iSplit. { eauto. }
  iIntros (e2 σ2 g2 efs Hstep). iMod ("Hwp" with "[//]") as "($&Hg&H&Hefs&HNC)".
  iMod (later_tok_incr with "[$]") as "(Hg&Hltok)".

  destruct (to_val e2) eqn:Heq_val.
  {
    iEval (rewrite wpc0_unfold /wpc_pre) in "H".
    iDestruct "H" as "(H&_)".
    rewrite Heq_val.
    iMod ("H" with "[$] [$]") as "H".

      iDestruct "H" as "((Hcm&Hv)&Hg&HNC)".
      iMod (saved_prop_alloc (wpc_crash_modality ⊤ mj_wp P)) as (γprop_stored') "#Hsaved1''".
      { apply dfrac_valid_discarded. }
      iMod (saved_prop_alloc True%I) as (γprop_remainder') "#Hsaved2''".
      { apply dfrac_valid_discarded. }
      iMod (own_update_2 _ _ _ (● Excl' (γprop_stored', γprop_remainder') ⋅
                                ◯ Excl' (γprop_stored', γprop_remainder'))
              with "Hown' Hown") as "[Hown' Hown]".
      { by apply auth_update, option_local_update, exclusive_local_update. }
      iMod (own_update_2 _ _ _ (● Excl' (inuse mj_wp mj_ushare) ⋅ ◯ Excl' (inuse mj_wp mj_ushare))
              with "Hstatus' Hownstat") as "[Hstatus' Hownstat]".
      { by apply auth_update, option_local_update, exclusive_local_update. }
      iMod ("Hreenable" with "[$Hg]") as "(Hitok&Hg)".
      iDestruct ("Hitok_inv_clo" with "[$]") as "Hitok".
      iDestruct (pri_inv_tok_split with "[$Hitok]") as "(Hitok&Hitok_ishare)".
      iEval (rewrite -Heq_mj) in "Hitok".
      iDestruct (pri_inv_tok_split with "[$Hitok]") as "(Hitok_ukeep&Hitok_ushare)".
      iMod ("Hclo" with "[Hown' Hstatus' Hcm Hitok_ishare Hitok_ushare]").
      { iNext.
        iEval (rewrite staged_inv_inner_unfold).
        iExists _, _, _, _, _. iFrame "∗ #".
        iLeft.
        iSplit.
        { iPureIntro. split_and!; auto; try naive_solver.
          - etransitivity; first eapply Qp.le_min_r. reflexivity.
          - etransitivity; first eapply Qp.le_min_l.
            etransitivity; first eapply Qp.le_min_l.
            eapply Qp.le_min_l. }
        iFrame.
        iModIntro. iIntros "Hwpc".
        rewrite /wpc_crash_modality.
        iIntros (????) "Hg HC Hlc".
        iSpecialize ("Hwpc" with "[$] [$] [$]").
        iApply (step_fupd2N_inner_wand with "Hwpc"); auto.
        iIntros "($&$)"; eauto.
      }
      iDestruct ("Hg_inv_clo" with "Hg") as "Hg".
      iMod (global_state_interp_le with "Hg") as "$".
      { apply Nat.le_succ_l, step_count_next_mono; lia. }
      iModIntro. iFrame.
      iSplitR "Hefs".
      - iEval (rewrite wpc0_unfold /wpc_pre).
        rewrite Heq_val.
        iSplit.
        * iIntros. iModIntro. iFrame. iDestruct "Hv" as "(_&$)".
        * iDestruct "Hv" as "(H&_)". iIntros.
          iDestruct (pri_inv_tok_global_le_acc _ _ _  mj_wp with "[] [$]") as "(Hg&Hg_clo)".
          { iPureIntro; split; auto.
            etransitivity; first eapply Qp.le_min_l.
            etransitivity; first eapply Qp.le_min_l.
            eapply Qp.le_min_r. }
          iSpecialize ("H" with "[$] [$] [$]").
          iApply (step_fupd2N_inner_wand with "H"); auto.
          iIntros "(Hg&$)".
          iApply "Hg_clo". iFrame.
      - iApply (big_sepL_mono with "Hefs").
        iIntros. iApply (wpc0_mj_le); last by iFrame.
        split; auto.
        etransitivity; first eapply Qp.le_min_l.
        etransitivity; first eapply Qp.le_min_l.
        eapply Qp.le_min_r. }

  iFrame "HNC".
  iMod (saved_prop_alloc
          (wpc0 NotStuck mj_wp ⊤ e2
            (λ v : val Λ, wpc_crash_modality ⊤ mj_wp P ∗ (wpc_crash_modality ⊤ mj_wp Φc ∧ Φ v))
            (Φc ∗ P))%I) as (γprop_stored') "#Hsaved1''".
  { apply dfrac_valid_discarded. }
  iMod (saved_prop_alloc Φc) as (γprop_remainder') "#Hsaved2''".
  { apply dfrac_valid_discarded. }
  iMod (own_update_2 _ _ _ (● Excl' (γprop_stored', γprop_remainder') ⋅
                            ◯ Excl' (γprop_stored', γprop_remainder'))
          with "Hown' Hown") as "[Hown' Hown]".
  { by apply auth_update, option_local_update, exclusive_local_update. }
  iMod (own_update_2 _ _ _ (● Excl' (inuse mj_wp mj_ushare) ⋅ ◯ Excl' (inuse mj_wp mj_ushare))
          with "Hstatus' Hownstat") as "[Hstatus' Hownstat]".
  { by apply auth_update, option_local_update, exclusive_local_update. }
  iMod ("Hreenable" with "[$Hg //]") as "(Hitok&Hg)".
  iDestruct ("Hitok_inv_clo" with "[$]") as "Hitok".
  iDestruct (pri_inv_tok_split with "[$Hitok]") as "(Hitok&Hitok_ishare)".
  iEval (rewrite -Heq_mj) in "Hitok".
  iDestruct (pri_inv_tok_split with "[$Hitok]") as "(Hitok_ukeep&Hitok_ushare)".
  iMod ("Hclo" with "[Hown' Hstatus' H Hitok_ishare Hitok_ushare]").
  { iNext.
    iEval (rewrite staged_inv_inner_unfold).
    iExists _, _, _, _, _. iFrame "∗ #".
    iLeft.
    iSplit.
    { iPureIntro. split_and!; auto.
      - rewrite /mj_wp. apply Qp.le_min_r.
      - rewrite /mj_wp.
        etransitivity; first eapply Qp.le_min_l.
        etransitivity; first eapply Qp.le_min_l.
        eapply Qp.le_min_l.
    }
    iSplitL "H".
    { iApply (wpc0_strong_mono with "H"); auto.
      iSplit; last by (iIntros; iModIntro; iFrame).
      iIntros (?) "($&H)". iModIntro.
      iSplit.
      - iDestruct "H" as "(H&_)". iApply (wpc_crash_modality_strong_wand with "[$]"); auto.
      - iDestruct "H" as "(_&$)".
    }
    iFrame.
    iModIntro. iIntros "Hwpc".
    iEval (rewrite wpc0_unfold) in "Hwpc". iDestruct "Hwpc" as "(_&Hwpc)".
    rewrite /wpc_crash_modality.
    iIntros (????) "Hg HC Hlc".
    iSpecialize ("Hwpc" with "[$] [$] [$]").
    iApply (step_fupd2N_inner_wand with "Hwpc"); auto.
  }
  iDestruct ("Hg_inv_clo" with "Hg") as "Hg".
  iMod (global_state_interp_le with "Hg") as "$".
  { apply Nat.le_succ_l, step_count_next_mono; lia. }
  iModIntro. iSplitR "Hefs"; last first.
  { iApply (big_sepL_mono with "Hefs").
    iIntros. iApply (wpc0_mj_le); last by iFrame.
    split; auto.
      - rewrite /mj_wp.
        etransitivity; first eapply Qp.le_min_l.
        etransitivity; first eapply Qp.le_min_l.
        eapply Qp.le_min_r.
  }
  iAssert (staged_value_inuse e2 ⊤ ⊤ mj mj_wp mj_ukeep Φ Φc P) with "[-]" as "Hsv".
  {
    iExists _, _, mj_ishare, _, _, _, _, _. iExists _. iFrame "∗".
    iSplit; first eauto.
    iFrame "Hsaved1'' Hsaved2''".
    iSplit; first eauto.
    iSplit; first eauto.
    iSplit; first eauto.
    iSplit.
    { iPureIntro. rewrite /mj_wp.
      etransitivity; first eapply Qp.le_min_l.
      etransitivity; first eapply Qp.le_min_l.
      eapply Qp.le_min_r. }
    iSplit.
    { iPureIntro. rewrite /mj_wp.
      etransitivity; first eapply Qp.le_min_l.
      eapply Qp.le_min_r. }
    iSplit; first eauto.
    iExact "Hinv".
  }
  iApply (wpc_staged_inv_aux with "[$]").
Qed.

End inv.


From cap_machine Require Export logrel.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import weakestpre adequacy lifting.
From stdpp Require Import base.
From cap_machine Require Import ftlr_base_binary.
From cap_machine Require Export rules_UnSeal.
From cap_machine.ftlr_binary Require Import interp_weakening.
From cap_machine.rules_binary Require Import rules_binary_base.

Section fundamental.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          {nainv: logrel_na_invs Σ} {cfgsg: cfgSG Σ}
          `{MachineParameters}.

  Notation D := ((prodO (leibnizO Word) (leibnizO Word)) -n> iPropO Σ).
  Notation R := ((prodO (leibnizO Reg) (leibnizO Reg)) -n> iPropO Σ).
  Implicit Types ww : (prodO (leibnizO Word) (leibnizO Word)).
  Implicit Types w : (leibnizO Word).
  Implicit Types interp : (D).

  Lemma unseal_case (r : prodO (leibnizO Reg) (leibnizO Reg)) (p : Perm)
        (b e a : Addr) (w w' : Word) (dst : RegName) (src1 src2 : RegName) (P : D):
    ftlr_instr r p b e a w w' (UnSeal dst src1 src2) P.
  Proof.
    intros Hp Hsome HisCorrect Hbae Hi.
    iIntros "#IH #Hspec #Hinv #Hreg #Hinva #Hread Hsmap Hown Hs Ha Ha' HP Hcls HPC Hmap".
    rewrite delete_insert_delete.
    iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /=";
      [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl.
    iApply (wp_UnSeal with "[$Ha $Hmap]"); eauto.
    { eapply lookup_insert. }
    { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _.
      apply elem_of_dom. apply lookup_insert_is_Some'; eauto. destruct Hsome with rr; eauto. }
    iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]".

    (* we assert that w = w' *)
    iAssert (⌜w = w'⌝)%I as %Heqw.
    { iDestruct "Hread" as "[Hread _]". iSpecialize ("Hread" with "HP"). by iApply interp_eq. }
    destruct r as [r1 r2]. simpl in *.
    iDestruct (interp_reg_eq r1 r2 (WCap p b e a) with "[]") as %Heq;[iSplit;auto|]. rewrite -!Heq.

    destruct HSpec; cycle 1.
    - (* In case of failure, we do not necessarily get a contradiction, but the proof is trivial *)
      iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[Ha Ha' HP]"); [iExists w,w'; iFrame|iModIntro].
      iNext; iIntros "_".
      iApply wp_value; auto. iIntros; discriminate.
    - destruct (decide (src1 = PC)) as [->|Hnesp]; simplify_map_eq.
      specialize (Hsome src1) as (_ & (vr2 & Hsr1')).
      iAssert (interp(_,vr2)) as "HFalse".
      { iApply ("Hreg" $! src1); eauto. }
      rewrite !fixpoint_interp1_eq /=. done.
Qed.

End fundamental.