LogrelCC.examples.refinement.oneshotCC.oneshotCC_LR2

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 oneshotCC_rules oneshotCC_LR2_helper.

Section refinement.
  Context `{heapG Σ, cfgSG Σ}.
  Context `{inG Σ (authR (gsetUR loc))}.

  Lemma call_cc'_call_cc_refinement :
    [] call_cc' log call_cc : call_cc_type.
  Proof.
    iIntros (Δ vvs ρ ) "[#Hcfg _]".
    iIntros (KK j) "[Hj HKK] /=".
    asimpl.
    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" $! (RecV _, LamV _)); iFrame; clear KK j.
    iAlways. iIntros ([f f']) "#Hff /=".
    iIntros ([K K'] j) "[Hj #HKK] /=".
    iApply wp_rec; eauto using to_of_val; iNext.
    iMod (step_Lam with "[$Hj]") as "Hj"; eauto.
    asimpl.
    iApply (wp_alloc (AppRCtx (RecV _) :: _)); eauto.
    iNext. iIntros (l) "Hl /=".
    iApply wp_rec; eauto; iNext.
    iMod (step_callcc with "[Hj]") as "Hj"; eauto.
    asimpl.
    rewrite G_eq.
    iApply wp_rec; eauto using to_of_val; rewrite -G_eq.
    asimpl. iNext.
    rewrite call_cc1_eq.
    iApply (wp_tapp (AppLCtx _ :: LetInCtx _ :: _)); eauto.
    iNext. simpl.
    iApply (wp_Lam (LetInCtx _:: _)); eauto.
    rewrite /= -call_cc1_inner_body_eq. asimpl.
    iNext.
    iApply (wp_alloc (LetInCtx _ :: LetInCtx _ :: _)); eauto.
    iNext. iIntros (b) "Hb".
    iApply (wp_LetIn (LetInCtx _ :: _)); eauto. simpl.
    asimpl. iNext.
    iApply (wp_callcc (LetInCtx _ :: _)); eauto. simpl.
    asimpl. iNext.
    iApply (wp_Lam (LetInCtx _ :: _)); eauto.
    rewrite call_cc1_inner_body_eq -call_cc1_eq /=.
    asimpl. iNext.
    iApply (wp_store (LetInCtx _ :: LetInCtx _ :: _)); eauto; iFrame.
    iNext. iIntros "Hl /=".
    iApply (wp_LetIn (LetInCtx _ :: _)); eauto.
    simpl; asimpl. iNext.
    iMod (make_used_locs_own (λ b, bv, b ↦ᵢ (#♭v bv))%I with "[]")
      as (γ) "Hul"; first done.
    iMod (used_locs_own_alloc with "[Hul Hb]") as "[#Hb Hul]";
      try iFrame; eauto; first done.
    iMod (inv_alloc (nroot.@"cc") _ (call_cc'_call_cc_refinement_inv γ l K)
          with "[Hl Hul]") as "#Hinv".
    { iNext. iExists _, _; iFrame.
      by iPureIntro; rewrite left_id; apply elem_of_singleton. }
    iSpecialize ("Hff" $! (ContV _, ContV _) with "[]");
      last iApply ("Hff" $! (LetInCtx _ :: _, _)); simpl; iFrame; clear j.
    - iExists _, _; iSplit; eauto.
      iAlways. iIntros (vv j) "[Hj #Hvv] /=".
      iApply (wp_atomic_under_ectx _ _ [ThrowRCtx _]); eauto.
      iInv (nroot.@"cc") as (M b') ">[Hul [#HbM Hl]]" "Hclose"; iModIntro.
      iApply wp_load'; iFrame. iNext. iIntros "Hl".
      iApply wp_value; eauto.
      iDestruct "HbM" as %HbM.
      iMod (loc_is_used with "Hul") as "[#Hb' Hul]"; eauto.
      iMod ("Hclose" with "[Hul Hl]") as "_".
      { iNext; by iExists _, _; iFrame. }
      clear M HbM.
      iModIntro. simpl.
      iApply (wp_throw []); eauto using to_of_val.
      iNext; simpl.
      rewrite call_cc1_ectx_eq; simpl.
      asimpl.
      iApply (wp_LetIn []); eauto using to_of_val.
      asimpl. iNext.
      iApply (wp_atomic_under_ectx _ _ [IfCtx _ _]); eauto.
      iInv (nroot.@"cc") as (M b'') ">[Hul [% Hl]]" "Hclose"; iModIntro.
      iDestruct (used_loc_elem_of with "[Hul Hb']") as %Hb'; eauto.
      iDestruct (get_used_loc _ _ b' with "Hul") as "[Hulo Hb'l]"; auto.
      iDestruct "Hb'l" as (bv) "Hb'l".
      iApply wp_load'; iFrame. iNext. iIntros "Hb'l".
      iApply wp_value; eauto.
      iDestruct (put_back_used_loc _ _ b' with "[Hulo Hb'l]") as "Hul";
        eauto; first iFrame; eauto.
      iMod ("Hclose" with "[Hul Hl]") as "_".
      { iNext; by iExists _, _; iFrame. }
      iModIntro. simpl.
      destruct bv.
      { iApply (wp_if_true []). iNext; simpl.
        iApply wp_mono; last iApply (wp_OMEGA _ []).
        iIntros (?) "?"; auto. }
      iApply (wp_if_false []); simpl; iNext.
      iApply (wp_atomic_under_ectx _ _ [LetInCtx _]); eauto.
      clear dependent b'' M.
      iInv (nroot.@"cc") as (M b3) ">[Hul [% Hl]]" "Hclose"; iModIntro.
      iDestruct (used_loc_elem_of with "[Hul Hb']") as %Hb'; eauto.
      iDestruct (get_used_loc _ _ b' with "Hul") as "[Hulo Hb'l]"; auto.
      iDestruct "Hb'l" as (bv) "Hb'l".
      iApply (wp_store' with "[-]"); eauto; iFrame.
      iNext. iIntros "Hb'l".
      iApply wp_value; eauto.
      iDestruct (put_back_used_loc _ _ b' with "[Hulo Hb'l]") as "Hul";
        eauto; first iFrame; eauto.
      iMod ("Hclose" with "[Hul Hl]") as "_".
      { iNext; by iExists _, _; iFrame. }
      iModIntro; simpl.
      iApply (wp_LetIn []); eauto.
      asimpl. iNext.
      iApply (wp_throw []); eauto. simpl.
      iNext. iApply call_cc'_call_cc_refinement_helper; iFrame "#".
      iApply "HKK"; eauto.
    - iAlways. iIntros (vv j) "[Hj #Hvv]".
      iApply call_cc'_call_cc_refinement_helper; iFrame "#".
      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.