LogrelCC.examples.refinement.oneshotCC.oneshotCC_LR1

From iris.algebra Require Import auth gset.
From iris.program_logic Require Import adequacy.
From LogrelCC Require Import rules_unary rules_binary soundness_binary.
From iris.proofmode Require Import tactics.
From LogrelCC Require Import typing.
From LogrelCC.examples.refinement.oneshotCC Require Import oneshotCC_progs.

Section refinement.
  Context `{heapG Σ, cfgSG Σ}.

  Opaque difference.

  Lemma call_cc_call_cc'_refinement_helper ρ E K j l v w :
    nclose specN E
    spec_ctx ρ
    l ↦ₛ w
    j fill K
    (LetIn (of_val v)
           (App (TApp call_cc1)
                (Lam (App (G (Loc l)) (Lam (Throw (ids 2) (ids 1))))))) ={E}=∗
     b, b ↦ₛ (#♭v false) l ↦ₛ ContV
    (call_cc1_ectx
       (Loc b)
       (Cont (LetInCtx
                (App (TApp call_cc1)
                     (Lam (App (G (Loc l))
                               (Lam (Throw (ids 2) (ids 1)))))) :: K)))
               j fill K (of_val v).
  Proof.
    iIntros (HE) "[#Hspec [Hl Hj]]".
    iMod (step_LetIn with "[Hj]") as "Hj";
      eauto using to_of_val; auto.
    asimpl.
    iMod (step_call_cc_1 (LamV _) with "[Hj]")
      as (b') "[Hb' Hj]"; simpl; eauto. asimpl.
    iMod (step_Lam with "[Hj]") as "Hj"; simpl; eauto; try iFrame; eauto.
    asimpl.
    iMod (step_G _ (LamV _) with "[Hj]") as "Hj"; eauto. asimpl.
    iMod (step_call_cc_1 (LamV _) ((LetInCtx _) :: _) with "[Hj]")
      as (b'') "[Hb'' Hj]"; simpl; eauto; simpl.
    asimpl.
    iMod (step_Lam _ _ _ ((LetInCtx _) :: _) with "[Hj]")
      as "Hj"; eauto; simpl; eauto.
    asimpl.
    iMod (step_store _ _ _ ((LetInCtx _) :: (LetInCtx _) :: _)
            with "[Hl Hj]") as "[Hj Hl]"; eauto; simpl; try iFrame; eauto.
    iMod (step_LetIn _ _ _ ((LetInCtx _) :: _) with "[Hj]")
      as "Hj"; eauto; simpl; eauto. asimpl.
    iMod (step_Lam _ _ _ ((LetInCtx _) :: _) with "[Hj]")
      as "Hj"; eauto; simpl; eauto. asimpl.
    iMod (step_throw _ _ _ ((LetInCtx _) :: _) with "[Hj]")
      as "Hj"; eauto using to_of_val.
    rewrite [ (call_cc1_ectx (Loc b') (Cont K))]call_cc1_ectx_eq /=.
    iMod (step_LetIn _ _ _ [] with "[Hj]") as "Hj"; eauto using to_of_val.
    asimpl.
    iMod (step_load _ _ _ [IfCtx _ _] with "[Hj Hb']") as "[Hj Hb']";
      eauto; iFrame; eauto.
    iMod (step_if_false _ _ _ [] with "[Hj]") as "Hj";
      first solve_ndisj; simpl; iFrame; eauto.
    iMod (step_store _ _ _ [LetInCtx _] with "[Hj Hb']") as "[Hj Hb']";
      eauto; simpl; try iFrame; eauto.
    iMod (step_LetIn _ _ _ [] with "[Hj]") as "Hj"; eauto; simpl; eauto. asimpl.
    iMod (step_throw _ _ _ [] with "[Hj]") as "Hj"; eauto using to_of_val.
    iModIntro. iExists _; iFrame.
  Qed.

  Lemma call_cc_call_cc'_refinement :
    [] call_cc log call_cc' : call_cc_type.
  Proof.
    iIntros (Δ vvs ρ ) "[#Hcfg _]".
    iIntros (KK j) "[Hj HKK] /=".
    iApply ("HKK" $! (TLamV _, TLamV _)); iFrame; clear KK j; asimpl.
    iAlways. iIntrosi Hτi KK j) "[Hj HKK] /=".
    iApply wp_tapp; iNext. iMod (step_tlam with "[Hj]") as "Hj"; eauto.
    iApply ("HKK" $! (LamV _, RecV _)); iFrame; clear KK j.
    iAlways. iIntros ([f f']) "#Hff /=".
    iIntros ([K K'] j) "[Hj #HKK] /=".
    iApply wp_Lam; eauto using to_of_val; iNext.
    iMod (step_rec with "[Hj]") as "Hj"; eauto using to_of_val.
    asimpl.
    iMod (step_alloc _ _ _ (AppRCtx (RecV _) :: K') with "[Hj]")
      as (l) "[Hj Hl]"; eauto; simpl; eauto.
    iMod (step_rec _ _ _ _ _ _ (LocV _) with "[Hj]") as "Hj";
      eauto using to_of_val.
    asimpl.
    iMod (step_G with "[Hj]") as "Hj"; eauto.
    iMod (step_call_cc_1 (LamV _) ((LetInCtx _) :: K') with "[Hj]")
      as (b) "[Hb Hj]"; simpl; eauto; simpl.
    iMod (step_Lam _ _ _ ((LetInCtx _) :: K') with "[Hj]")
      as "Hj"; eauto; simpl; eauto.
    asimpl.
    iMod (step_store _ _ _ ((LetInCtx _) :: (LetInCtx _) :: K')
          _ _ _ (ContV _) with "[Hj $Hl]") as "[Hj Hl]"; eauto; simpl; eauto.
    iApply wp_callcc; iNext. asimpl.
    iMod (step_LetIn _ _ _ ((LetInCtx _) :: K') with "[Hj]")
      as "Hj"; eauto; simpl; eauto.
    asimpl.
    iMod (inv_alloc (nroot.@"cc") _
           ( b, b ↦ₛ (#♭v false)
                    l ↦ₛ ContV
                   (call_cc1_ectx
                      (Loc b)
                      (Cont (LetInCtx
                               (App (TApp call_cc1)
                                    (Lam
                                       (App
                                          (G (Loc l))
                                          (Lam (Throw (ids 2) (ids 1))))))
                               :: K'))))%I
          with "[Hl Hb]") as "#Hinv".
    { iNext. iExists _; iFrame. }
    clear b.
    iSpecialize ("Hff" $! (ContV _, ContV _) with "[]");
      last iApply ("Hff" $! (_, (LetInCtx _) :: _)); simpl; iFrame; clear j.
    - iExists _, _; iSplit; eauto. iAlways.
      iIntros (vv j) "[Hj #Hvv] /=".
      iApply fupd_wp.
      iInv (nroot.@"cc") as (b) ">[Hb Hl]" "Hclose".
      iMod (step_load _ _ _ ([ThrowRCtx _]) with "[Hj Hl]") as "[Hj Hl]"; simpl;
        first (by solve_ndisj); iFrame; eauto; simpl.
      iMod (step_throw _ _ _ [] with "[Hj]") as "Hj"; eauto using to_of_val;
        first solve_ndisj.
      rewrite {2}call_cc1_ectx_eq; simpl.
      asimpl.
      iMod (step_LetIn _ _ _ [] with "[Hj]") as "Hj"; eauto using to_of_val;
        first solve_ndisj.
      rewrite /= OMEGA_closed call_cc1_closed G_subst; simpl.
      asimpl.
      iMod (step_load _ _ _ [IfCtx _ _] with "[Hj Hb]") as "[Hj Hb]";
        first solve_ndisj; simpl; iFrame; eauto.
      iMod (step_if_false _ _ _ [] with "[Hj]") as "Hj";
        first solve_ndisj; simpl; iFrame; eauto.
      iMod (step_store _ _ _ [LetInCtx _] with "[Hj Hb]") as "[Hj Hb]";
      try iFrame; eauto; first solve_ndisj.
      iMod (step_LetIn _ _ _ [] with "[Hj]") as "Hj";
      try iFrame; eauto; first solve_ndisj.
      asimpl.
      iMod (step_throw _ _ _ [] with "[Hj]") as "Hj"; eauto using to_of_val;
        first solve_ndisj.
      simpl.
      iMod (call_cc_call_cc'_refinement_helper with "[$Hj $Hl]") as
          (b') "(Hb' & Hl & Hj)"; auto; first solve_ndisj.
      iMod ("Hclose" with "[Hb' Hl]") as "_"; first (iNext; iExists b'; iFrame).
      iApply "HKK"; eauto.
    - iAlways. iIntros (vv j) "[Hj #Hvv]".
      iApply fupd_wp. iInv (nroot.@"cc") as (b'') ">[Hb'' Hl]" "Hclose".
      iMod (call_cc_call_cc'_refinement_helper with "[$Hj $Hl]") as
          (b') "(Hb' & Hl & Hj)"; auto; first solve_ndisj.
      iMod ("Hclose" with "[Hb' Hl]") as "_"; first (iNext; iExists b'; iFrame).
      iModIntro.
      iApply "HKK"; eauto.
  Qed.

End refinement.

Theorem call_cc'_call_cc_ctx_refinement :
  [] call_cc ctx call_cc' : call_cc_type.
Proof.
  set (Σ := #[invΣ ; gen_heapΣ loc val ;
              GFunctor (authR cfgUR) ; GFunctor (authR (gsetUR loc)) ]).
  set (HG := soundness_unary.HeapPreIG Σ _ _).
  eapply (binary_soundness Σ _); auto.
  intros. apply call_cc_call_cc'_refinement.
Qed.