LogrelCC.examples.refinement.stack.CG_stack
From iris.proofmode Require Import tactics.
From iris.base_logic Require Import invariants.
From LogrelCC.examples.refinement Require Import lock.
Import uPred.
Definition CG_StackType τ :=
TRec (TSum TUnit (TProd τ.[ren (+1)] (TVar 0))).
(* Coarse-grained push *)
Definition CG_push (st : expr) : expr :=
Lam (Store
(st.[ren (+1)]) (Fold (InjR (Pair (Var 0) (Load st.[ren (+ 1)]))))).
Definition CG_locked_push (st l : expr) := with_lock (CG_push st) l.
Definition CG_locked_pushV (st l : expr) : val := with_lockV (CG_push st) l.
Definition CG_pop (st : expr) : expr :=
Lam (Case (Unfold (Load st.[ren (+ 1)]))
(InjL Unit)
(LetIn
(Store st.[ren (+ 2)] (Snd (Var 0)))
(InjR (Fst (Var 1))))).
Definition CG_locked_pop (st l : expr) := with_lock (CG_pop st) l.
Definition CG_locked_popV (st l : expr) : val := with_lockV (CG_pop st) l.
Definition CG_snap (st l : expr) := with_lock (Lam (Load st.[ren (+1)])) l.
Definition CG_snapV (st l : expr) : val := with_lockV (Lam (Load st.[ren (+1)])) l.
Definition CG_iter (f : expr) : expr :=
Rec (Case (Unfold (Var 1))
Unit
(LetIn
(App f.[ren (+3)] (Fst (Var 0)))
((App (Var 2) (Snd (Var 1)))))).
Definition CG_iterV (f : expr) : val :=
RecV (Case (Unfold (Var 1))
Unit
(LetIn
(App f.[ren (+3)] (Fst (Var 0)))
((App (Var 2) (Snd (Var 1)))))).
Definition CG_snap_iter (st l : expr) : expr :=
Lam (App (CG_iter (Var 0)) (App (CG_snap st.[ren (+1)] l.[ren (+1)]) Unit)).
Definition CG_stack_body (st l : expr) : expr :=
Pair (Pair (CG_locked_push st l) (CG_locked_pop st l))
(CG_snap_iter st l).
Definition CG_stack : expr :=
TLam (LetIn newlock (LetIn
(Alloc (Fold (InjL Unit)))
(CG_stack_body (Var 0) (Var 1)))).
Section CG_Stack.
Context `{heapG Σ, cfgSG Σ}.
Lemma CG_push_type st Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ (CG_push st) (TArrow τ TUnit).
Proof.
intros H1. repeat econstructor.
eapply (context_weakening [_]); eauto.
repeat constructor; asimpl; trivial.
eapply (context_weakening [_]); eauto.
Qed.
Lemma CG_push_closed (st : expr) :
(∀ f, st.[f] = st) → ∀ f, (CG_push st).[f] = CG_push st.
Proof. intros Hst f. unfold CG_push. asimpl. rewrite ?Hst; trivial. Qed.
Lemma CG_push_subst (st : expr) f : (CG_push st).[f] = CG_push st.[f].
Proof. unfold CG_push; asimpl; trivial. Qed.
Lemma steps_CG_push E ρ j K st v w :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ v ∗ j ⤇ fill K (App (CG_push (Loc st)) (of_val w))
⊢ |={E}=> j ⤇ fill K Unit ∗ st ↦ₛ FoldV (InjRV (PairV w v)).
Proof.
intros HNE. iIntros "[#Hspec [Hx Hj]]". unfold CG_push.
iMod (step_Lam _ _ j K with "[Hj]") as "Hj"; eauto; eauto.
asimpl.
iMod (step_load _ _ j (PairRCtx _ :: InjRCtx :: FoldCtx :: StoreRCtx (LocV _) :: K)
with "[Hj Hx]") as "[Hj Hx]"; eauto.
{ simpl. iFrame "Hspec Hj"; trivial. }
simpl.
iMod (step_store _ _ j K with "[Hj Hx]") as "[Hj Hx]"; try iFrame; eauto.
Qed.
Global Opaque CG_push.
Lemma CG_locked_push_to_val st l :
to_val (CG_locked_push st l) = Some (CG_locked_pushV st l).
Proof. trivial. Qed.
Lemma CG_locked_push_of_val st l :
of_val (CG_locked_pushV st l) = CG_locked_push st l.
Proof. trivial. Qed.
Global Opaque CG_locked_pushV.
Lemma CG_locked_push_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_locked_push st l) (TArrow τ TUnit).
Proof.
intros H1 H2. repeat econstructor.
eapply with_lock_type; auto using CG_push_type.
Qed.
Lemma CG_locked_push_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_locked_push st l).[f] = CG_locked_push st l.
Proof.
intros H1 H2 f. asimpl. unfold CG_locked_push.
rewrite with_lock_closed; trivial. apply CG_push_closed; trivial.
Qed.
Lemma CG_locked_push_subst (st l : expr) f :
(CG_locked_push st l).[f] = CG_locked_push st.[f] l.[f].
Proof. by rewrite with_lock_subst CG_push_subst. Qed.
Lemma steps_CG_locked_push E ρ j K st w v l :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ v ∗ l ↦ₛ (#♭v false)
∗ j ⤇ fill K (App (CG_locked_push (Loc st) (Loc l)) (of_val w))
⊢ |={E}=> j ⤇ fill K Unit ∗ st ↦ₛ FoldV (InjRV (PairV w v)) ∗ l ↦ₛ (#♭v false).
Proof.
intros HNE. iIntros "[#Hspec [Hx [Hl Hj]]]". unfold CG_locked_push.
iMod (steps_with_lock _ _ j K _ _ (st ↦ₛ _) (st ↦ₛ _) UnitV
with "[$Hj $Hx $Hl]")%I as "Hj";
eauto; try iFrame; eauto.
- iIntros (K') "[#Hspec [Hx Hj]]".
iMod (steps_CG_push with "[$Hj $Hx]") as "[Hj Hx]"; auto; by iFrame.
Qed.
Global Opaque CG_locked_push.
(* Coarse-grained pop *)
Lemma CG_pop_type st Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ (CG_pop st) (TArrow TUnit (TSum TUnit τ)).
Proof.
intros H1.
econstructor.
eapply (Case_typed _ _ _ _ TUnit);
[| repeat constructor
| repeat econstructor; eapply (context_weakening [_; _]); eauto].
replace (TSum TUnit (TProd τ (CG_StackType τ))) with
((TSum TUnit (TProd τ.[ren (+1)] (TVar 0))).[(CG_StackType τ)/])
by (by asimpl).
repeat econstructor.
eapply (context_weakening [_]); eauto.
Qed.
Lemma CG_pop_closed (st : expr) :
(∀ f, st.[f] = st) → ∀ f, (CG_pop st).[f] = CG_pop st.
Proof. intros Hst f. unfold CG_pop. asimpl. rewrite ?Hst; trivial. Qed.
Lemma CG_pop_subst (st : expr) f : (CG_pop st).[f] = CG_pop st.[f].
Proof. unfold CG_pop; asimpl; trivial. Qed.
Lemma steps_CG_pop_suc E ρ j K st v w :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ FoldV (InjRV (PairV w v)) ∗
j ⤇ fill K (App (CG_pop (Loc st)) Unit)
⊢ |={E}=> j ⤇ fill K (InjR (of_val w)) ∗ st ↦ₛ v.
Proof.
intros HNE. iIntros "[#Hspec [Hx Hj]]". unfold CG_pop.
iMod (step_Lam _ _ j K with "[Hj]") as "Hj"; eauto; eauto.
asimpl.
iMod (step_load _ _ j (UnfoldCtx :: CaseCtx _ _ :: K)
with "[Hj Hx]") as "[Hj Hx]"; eauto.
{ rewrite ?fill_app. simpl. iFrame "Hspec Hj"; trivial. }
simpl.
iMod (step_Fold _ _ j (CaseCtx _ _ :: K) with "[Hj]") as "Hj"; eauto; eauto.
simpl.
iMod (step_case_inr _ _ j K with "[Hj]") as "Hj"; eauto; eauto.
asimpl.
iMod (step_snd _ _ j (StoreRCtx (LocV _) :: (LetInCtx _) :: K)
with "[Hj]") as "Hj"; eauto; eauto.
simpl.
iMod (step_store _ _ j ((LetInCtx _) :: K)
with "[$Hj Hx]") as "[Hj Hx]"; eauto.
simpl.
iMod (step_LetIn _ _ j K with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_fst _ _ j (InjRCtx :: K) with "[Hj]") as "Hj"; eauto; eauto.
simpl.
iModIntro. iFrame "Hj Hx"; trivial.
Qed.
Lemma steps_CG_pop_fail E ρ j K st :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ FoldV (InjLV UnitV) ∗
j ⤇ fill K (App (CG_pop (Loc st)) Unit)
⊢ |={E}=> j ⤇ fill K (InjL Unit) ∗ st ↦ₛ FoldV (InjLV UnitV).
Proof.
iIntros (HNE) "[#Hspec [Hx Hj]]". unfold CG_pop.
iMod (step_Lam _ _ j K with "[Hj]") as "Hj"; eauto; eauto.
asimpl.
iMod (step_load _ _ j (UnfoldCtx :: CaseCtx _ _ :: K)
_ _ _ with "[$Hj Hx]") as "[Hj Hx]"; eauto.
simpl.
iMod (step_Fold _ _ j (CaseCtx _ _ :: K) with "[$Hj]") as "Hj"; eauto.
iMod (step_case_inl _ _ j K with "[$Hj]") as "Hj"; eauto.
asimpl.
iModIntro. iFrame "Hj Hx"; trivial.
Qed.
Global Opaque CG_pop.
Lemma CG_locked_pop_to_val st l :
to_val (CG_locked_pop st l) = Some (CG_locked_popV st l).
Proof. trivial. Qed.
Lemma CG_locked_pop_of_val st l :
of_val (CG_locked_popV st l) = CG_locked_pop st l.
Proof. trivial. Qed.
Global Opaque CG_locked_popV.
Lemma CG_locked_pop_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_locked_pop st l) (TArrow TUnit (TSum TUnit τ)).
Proof.
intros H1 H2. repeat econstructor.
eapply with_lock_type; auto using CG_pop_type.
Qed.
Lemma CG_locked_pop_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_locked_pop st l).[f] = CG_locked_pop st l.
Proof.
intros H1 H2 f. asimpl. unfold CG_locked_pop.
rewrite with_lock_closed; trivial. apply CG_pop_closed; trivial.
Qed.
Lemma CG_locked_pop_subst (st l : expr) f :
(CG_locked_pop st l).[f] = CG_locked_pop st.[f] l.[f].
Proof. by rewrite with_lock_subst CG_pop_subst. Qed.
Lemma steps_CG_locked_pop_suc E ρ j K st v w l :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ FoldV (InjRV (PairV w v)) ∗ l ↦ₛ (#♭v false)
∗ j ⤇ fill K (App (CG_locked_pop (Loc st) (Loc l)) Unit)
⊢ |={E}=> j ⤇ fill K (InjR (of_val w)) ∗ st ↦ₛ v ∗ l ↦ₛ (#♭v false).
Proof.
iIntros (HNE) "[#Hspec [Hx [Hl Hj]]]". unfold CG_locked_pop.
iMod (steps_with_lock _ _ j K _ _ (st ↦ₛ _) _ (InjRV w) UnitV
with "[$Hj $Hx $Hl]")%I as "Hj"; eauto.
iIntros (K') "[#Hspec Hxj]".
iApply steps_CG_pop_suc; first done. iFrame; trivial.
Qed.
Lemma steps_CG_locked_pop_fail E ρ j K st l :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ FoldV (InjLV UnitV) ∗ l ↦ₛ (#♭v false)
∗ j ⤇ fill K (App (CG_locked_pop (Loc st) (Loc l)) Unit)
⊢ |={E}=> j ⤇ fill K (InjL Unit) ∗ st ↦ₛ FoldV (InjLV UnitV) ∗ l ↦ₛ (#♭v false).
Proof.
iIntros (HNE) "[#Hspec [Hx [Hl Hj]]]". unfold CG_locked_pop.
iMod (steps_with_lock _ _ j K _ _ (st ↦ₛ _) _ (InjLV UnitV) UnitV
with "[$Hj $Hx $Hl]")%I as "Hj"; eauto.
iIntros (K') "[#Hspec Hxj] /=".
iApply steps_CG_pop_fail; first done. iFrame; trivial.
Qed.
Global Opaque CG_locked_pop.
Lemma CG_snap_to_val st l : to_val (CG_snap st l) = Some (CG_snapV st l).
Proof. trivial. Qed.
Lemma CG_snap_of_val st l : of_val (CG_snapV st l) = CG_snap st l.
Proof. trivial. Qed.
Global Opaque CG_snapV.
Lemma CG_snap_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_snap st l) (TArrow TUnit (CG_StackType τ)).
Proof.
intros H1 H2. repeat econstructor.
eapply with_lock_type; trivial. do 2 constructor.
eapply (context_weakening [_]); eauto.
Qed.
Lemma CG_snap_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_snap st l).[f] = CG_snap st l.
Proof.
intros H1 H2 f. asimpl. unfold CG_snap.
rewrite with_lock_closed; trivial.
intros f'. by asimpl; rewrite ?H1.
Qed.
Lemma CG_snap_subst (st l : expr) f :
(CG_snap st l).[f] = CG_snap st.[f] l.[f].
Proof. unfold CG_snap; rewrite ?with_lock_subst. by asimpl. Qed.
Lemma steps_CG_snap E ρ j K st v l :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ v ∗ l ↦ₛ (#♭v false)
∗ j ⤇ fill K (App (CG_snap (Loc st) (Loc l)) Unit)
⊢ |={E}=> j ⤇ (fill K (of_val v)) ∗ st ↦ₛ v ∗ l ↦ₛ (#♭v false).
Proof.
iIntros (HNE) "[#Hspec [Hx [Hl Hj]]]". unfold CG_snap.
iMod (steps_with_lock _ _ j K _ _ (st ↦ₛ v) _ v UnitV
with "[$Hj $Hx $Hl]")%I as "Hj"; eauto.
iIntros (K') "[#Hspec [Hx Hj]]".
iMod (step_Lam _ _ j K' with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_load _ _ j K' with "[$Hj $Hx]") as "[Hj Hx]"; eauto.
by iFrame "#"; iFrame.
Qed.
Global Opaque CG_snap.
(* Coarse-grained iter *)
Lemma CG_iter_folding (f : expr) :
CG_iter f =
Rec (Case (Unfold (Var 1))
Unit
(LetIn
(App f.[ren (+3)] (Fst (Var 0)))
((App (Var 2) (Snd (Var 1)))))).
Proof. trivial. Qed.
Lemma CG_iter_type f Γ τ :
typed Γ f (TArrow τ TUnit) →
typed Γ (CG_iter f) (TArrow (CG_StackType τ) TUnit).
Proof.
intros H1.
econstructor.
eapply (Case_typed _ _ _ _ TUnit);
[| repeat constructor
| repeat econstructor; eapply (context_weakening [_; _; _]); eauto].
replace (TSum TUnit (TProd τ (CG_StackType τ))) with
((TSum TUnit (TProd τ.[ren (+1)] (TVar 0))).[(CG_StackType τ)/])
by (by asimpl).
repeat econstructor.
Qed.
Lemma CG_iter_to_val f : to_val (CG_iter f) = Some (CG_iterV f).
Proof. trivial. Qed.
Lemma CG_iter_of_val f : of_val (CG_iterV f) = CG_iter f.
Proof. trivial. Qed.
Global Opaque CG_iterV.
Lemma CG_iter_closed (f : expr) :
(∀ g, f.[g] = f) → ∀ g, (CG_iter f).[g] = CG_iter f.
Proof. intros Hf g. unfold CG_iter. asimpl. rewrite ?Hf; trivial. Qed.
Lemma CG_iter_subst (f : expr) g : (CG_iter f).[g] = CG_iter f.[g].
Proof. unfold CG_iter; asimpl; trivial. Qed.
Lemma steps_CG_iter E ρ j K f v w :
nclose specN ⊆ E →
spec_ctx ρ
∗ j ⤇ fill K (App (CG_iter (of_val f))
(Fold (InjR (Pair (of_val w) (of_val v)))))
⊢ |={E}=>
j ⤇ fill K
(LetIn (App (of_val f) (of_val w))
(App
(CG_iter (of_val f)).[ren (+1)]
(Snd (Pair (of_val w).[ren (+1)] (of_val v).[ren (+1)])))).
Proof.
iIntros (HNE) "[#Hspec Hj]". unfold CG_iter.
iMod (step_rec _ _ j K with "[$Hj]") as "Hj"; eauto.
rewrite -CG_iter_folding. Opaque CG_iter. asimpl.
iMod (step_Fold _ _ j (CaseCtx _ _ :: K) with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_case_inr _ _ j K with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_fst _ _ j (AppRCtx f :: (LetInCtx _) :: K) with "[$Hj]") as "Hj";
eauto.
Qed.
Transparent CG_iter.
Lemma steps_CG_iter_end E ρ j K f :
nclose specN ⊆ E →
spec_ctx ρ ∗ j ⤇ fill K (App (CG_iter (of_val f)) (Fold (InjL Unit)))
⊢ |={E}=> j ⤇ fill K Unit.
Proof.
iIntros (HNE) "[#Hspec Hj]". unfold CG_iter.
iMod (step_rec _ _ j K with "[$Hj]") as "Hj"; eauto.
rewrite -CG_iter_folding. Opaque CG_iter. asimpl.
iMod (step_Fold _ _ j (CaseCtx _ _ :: K) with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_case_inl _ _ j K with "[$Hj]") as "Hj"; eauto.
Qed.
Global Opaque CG_iter.
Lemma CG_snap_iter_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_snap_iter st l) (TArrow (TArrow τ TUnit) TUnit).
Proof.
intros H1 H2; repeat econstructor.
- eapply CG_iter_type; by constructor.
- eapply CG_snap_type; by eapply (context_weakening [_]).
Qed.
Lemma CG_snap_iter_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_snap_iter st l).[f] = CG_snap_iter st l.
Proof.
intros H1 H2 f. unfold CG_snap_iter. asimpl. rewrite H1 H2.
rewrite CG_snap_closed; auto.
Qed.
Lemma CG_snap_iter_subst (st l : expr) g :
(CG_snap_iter st l).[g] = CG_snap_iter st.[g] l.[g].
Proof.
unfold CG_snap_iter; asimpl.
rewrite CG_snap_subst CG_iter_subst. by asimpl.
Qed.
Lemma CG_stack_body_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_stack_body st l)
(TProd
(TProd (TArrow τ TUnit) (TArrow TUnit (TSum TUnit τ)))
(TArrow (TArrow τ TUnit) TUnit)
).
Proof.
intros H1 H2.
repeat (econstructor; eauto using CG_locked_push_type,
CG_locked_pop_type, CG_snap_iter_type).
Qed.
Opaque CG_snap_iter.
Lemma CG_stack_body_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_stack_body st l).[f] = CG_stack_body st l.
Proof.
intros H1 H2 f. unfold CG_stack_body. asimpl.
rewrite CG_locked_push_closed; trivial.
rewrite CG_locked_pop_closed; trivial.
by rewrite CG_snap_iter_closed.
Qed.
Lemma CG_stack_type Γ :
typed Γ CG_stack
(TForall
(TProd
(TProd
(TArrow (TVar 0) TUnit)
(TArrow TUnit (TSum TUnit (TVar 0)))
)
(TArrow (TArrow (TVar 0) TUnit) TUnit)
)).
Proof.
repeat econstructor;
eauto using CG_locked_push_type, CG_locked_pop_type,
CG_snap_iter_type, newlock_type, typed.
asimpl. repeat constructor.
Qed.
Lemma CG_stack_closed f : CG_stack.[f] = CG_stack.
Proof.
unfold CG_stack.
asimpl; rewrite ?CG_locked_push_subst ?CG_locked_pop_subst.
asimpl. rewrite ?CG_snap_iter_subst. by asimpl.
Qed.
End CG_Stack.
From iris.base_logic Require Import invariants.
From LogrelCC.examples.refinement Require Import lock.
Import uPred.
Definition CG_StackType τ :=
TRec (TSum TUnit (TProd τ.[ren (+1)] (TVar 0))).
(* Coarse-grained push *)
Definition CG_push (st : expr) : expr :=
Lam (Store
(st.[ren (+1)]) (Fold (InjR (Pair (Var 0) (Load st.[ren (+ 1)]))))).
Definition CG_locked_push (st l : expr) := with_lock (CG_push st) l.
Definition CG_locked_pushV (st l : expr) : val := with_lockV (CG_push st) l.
Definition CG_pop (st : expr) : expr :=
Lam (Case (Unfold (Load st.[ren (+ 1)]))
(InjL Unit)
(LetIn
(Store st.[ren (+ 2)] (Snd (Var 0)))
(InjR (Fst (Var 1))))).
Definition CG_locked_pop (st l : expr) := with_lock (CG_pop st) l.
Definition CG_locked_popV (st l : expr) : val := with_lockV (CG_pop st) l.
Definition CG_snap (st l : expr) := with_lock (Lam (Load st.[ren (+1)])) l.
Definition CG_snapV (st l : expr) : val := with_lockV (Lam (Load st.[ren (+1)])) l.
Definition CG_iter (f : expr) : expr :=
Rec (Case (Unfold (Var 1))
Unit
(LetIn
(App f.[ren (+3)] (Fst (Var 0)))
((App (Var 2) (Snd (Var 1)))))).
Definition CG_iterV (f : expr) : val :=
RecV (Case (Unfold (Var 1))
Unit
(LetIn
(App f.[ren (+3)] (Fst (Var 0)))
((App (Var 2) (Snd (Var 1)))))).
Definition CG_snap_iter (st l : expr) : expr :=
Lam (App (CG_iter (Var 0)) (App (CG_snap st.[ren (+1)] l.[ren (+1)]) Unit)).
Definition CG_stack_body (st l : expr) : expr :=
Pair (Pair (CG_locked_push st l) (CG_locked_pop st l))
(CG_snap_iter st l).
Definition CG_stack : expr :=
TLam (LetIn newlock (LetIn
(Alloc (Fold (InjL Unit)))
(CG_stack_body (Var 0) (Var 1)))).
Section CG_Stack.
Context `{heapG Σ, cfgSG Σ}.
Lemma CG_push_type st Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ (CG_push st) (TArrow τ TUnit).
Proof.
intros H1. repeat econstructor.
eapply (context_weakening [_]); eauto.
repeat constructor; asimpl; trivial.
eapply (context_weakening [_]); eauto.
Qed.
Lemma CG_push_closed (st : expr) :
(∀ f, st.[f] = st) → ∀ f, (CG_push st).[f] = CG_push st.
Proof. intros Hst f. unfold CG_push. asimpl. rewrite ?Hst; trivial. Qed.
Lemma CG_push_subst (st : expr) f : (CG_push st).[f] = CG_push st.[f].
Proof. unfold CG_push; asimpl; trivial. Qed.
Lemma steps_CG_push E ρ j K st v w :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ v ∗ j ⤇ fill K (App (CG_push (Loc st)) (of_val w))
⊢ |={E}=> j ⤇ fill K Unit ∗ st ↦ₛ FoldV (InjRV (PairV w v)).
Proof.
intros HNE. iIntros "[#Hspec [Hx Hj]]". unfold CG_push.
iMod (step_Lam _ _ j K with "[Hj]") as "Hj"; eauto; eauto.
asimpl.
iMod (step_load _ _ j (PairRCtx _ :: InjRCtx :: FoldCtx :: StoreRCtx (LocV _) :: K)
with "[Hj Hx]") as "[Hj Hx]"; eauto.
{ simpl. iFrame "Hspec Hj"; trivial. }
simpl.
iMod (step_store _ _ j K with "[Hj Hx]") as "[Hj Hx]"; try iFrame; eauto.
Qed.
Global Opaque CG_push.
Lemma CG_locked_push_to_val st l :
to_val (CG_locked_push st l) = Some (CG_locked_pushV st l).
Proof. trivial. Qed.
Lemma CG_locked_push_of_val st l :
of_val (CG_locked_pushV st l) = CG_locked_push st l.
Proof. trivial. Qed.
Global Opaque CG_locked_pushV.
Lemma CG_locked_push_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_locked_push st l) (TArrow τ TUnit).
Proof.
intros H1 H2. repeat econstructor.
eapply with_lock_type; auto using CG_push_type.
Qed.
Lemma CG_locked_push_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_locked_push st l).[f] = CG_locked_push st l.
Proof.
intros H1 H2 f. asimpl. unfold CG_locked_push.
rewrite with_lock_closed; trivial. apply CG_push_closed; trivial.
Qed.
Lemma CG_locked_push_subst (st l : expr) f :
(CG_locked_push st l).[f] = CG_locked_push st.[f] l.[f].
Proof. by rewrite with_lock_subst CG_push_subst. Qed.
Lemma steps_CG_locked_push E ρ j K st w v l :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ v ∗ l ↦ₛ (#♭v false)
∗ j ⤇ fill K (App (CG_locked_push (Loc st) (Loc l)) (of_val w))
⊢ |={E}=> j ⤇ fill K Unit ∗ st ↦ₛ FoldV (InjRV (PairV w v)) ∗ l ↦ₛ (#♭v false).
Proof.
intros HNE. iIntros "[#Hspec [Hx [Hl Hj]]]". unfold CG_locked_push.
iMod (steps_with_lock _ _ j K _ _ (st ↦ₛ _) (st ↦ₛ _) UnitV
with "[$Hj $Hx $Hl]")%I as "Hj";
eauto; try iFrame; eauto.
- iIntros (K') "[#Hspec [Hx Hj]]".
iMod (steps_CG_push with "[$Hj $Hx]") as "[Hj Hx]"; auto; by iFrame.
Qed.
Global Opaque CG_locked_push.
(* Coarse-grained pop *)
Lemma CG_pop_type st Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ (CG_pop st) (TArrow TUnit (TSum TUnit τ)).
Proof.
intros H1.
econstructor.
eapply (Case_typed _ _ _ _ TUnit);
[| repeat constructor
| repeat econstructor; eapply (context_weakening [_; _]); eauto].
replace (TSum TUnit (TProd τ (CG_StackType τ))) with
((TSum TUnit (TProd τ.[ren (+1)] (TVar 0))).[(CG_StackType τ)/])
by (by asimpl).
repeat econstructor.
eapply (context_weakening [_]); eauto.
Qed.
Lemma CG_pop_closed (st : expr) :
(∀ f, st.[f] = st) → ∀ f, (CG_pop st).[f] = CG_pop st.
Proof. intros Hst f. unfold CG_pop. asimpl. rewrite ?Hst; trivial. Qed.
Lemma CG_pop_subst (st : expr) f : (CG_pop st).[f] = CG_pop st.[f].
Proof. unfold CG_pop; asimpl; trivial. Qed.
Lemma steps_CG_pop_suc E ρ j K st v w :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ FoldV (InjRV (PairV w v)) ∗
j ⤇ fill K (App (CG_pop (Loc st)) Unit)
⊢ |={E}=> j ⤇ fill K (InjR (of_val w)) ∗ st ↦ₛ v.
Proof.
intros HNE. iIntros "[#Hspec [Hx Hj]]". unfold CG_pop.
iMod (step_Lam _ _ j K with "[Hj]") as "Hj"; eauto; eauto.
asimpl.
iMod (step_load _ _ j (UnfoldCtx :: CaseCtx _ _ :: K)
with "[Hj Hx]") as "[Hj Hx]"; eauto.
{ rewrite ?fill_app. simpl. iFrame "Hspec Hj"; trivial. }
simpl.
iMod (step_Fold _ _ j (CaseCtx _ _ :: K) with "[Hj]") as "Hj"; eauto; eauto.
simpl.
iMod (step_case_inr _ _ j K with "[Hj]") as "Hj"; eauto; eauto.
asimpl.
iMod (step_snd _ _ j (StoreRCtx (LocV _) :: (LetInCtx _) :: K)
with "[Hj]") as "Hj"; eauto; eauto.
simpl.
iMod (step_store _ _ j ((LetInCtx _) :: K)
with "[$Hj Hx]") as "[Hj Hx]"; eauto.
simpl.
iMod (step_LetIn _ _ j K with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_fst _ _ j (InjRCtx :: K) with "[Hj]") as "Hj"; eauto; eauto.
simpl.
iModIntro. iFrame "Hj Hx"; trivial.
Qed.
Lemma steps_CG_pop_fail E ρ j K st :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ FoldV (InjLV UnitV) ∗
j ⤇ fill K (App (CG_pop (Loc st)) Unit)
⊢ |={E}=> j ⤇ fill K (InjL Unit) ∗ st ↦ₛ FoldV (InjLV UnitV).
Proof.
iIntros (HNE) "[#Hspec [Hx Hj]]". unfold CG_pop.
iMod (step_Lam _ _ j K with "[Hj]") as "Hj"; eauto; eauto.
asimpl.
iMod (step_load _ _ j (UnfoldCtx :: CaseCtx _ _ :: K)
_ _ _ with "[$Hj Hx]") as "[Hj Hx]"; eauto.
simpl.
iMod (step_Fold _ _ j (CaseCtx _ _ :: K) with "[$Hj]") as "Hj"; eauto.
iMod (step_case_inl _ _ j K with "[$Hj]") as "Hj"; eauto.
asimpl.
iModIntro. iFrame "Hj Hx"; trivial.
Qed.
Global Opaque CG_pop.
Lemma CG_locked_pop_to_val st l :
to_val (CG_locked_pop st l) = Some (CG_locked_popV st l).
Proof. trivial. Qed.
Lemma CG_locked_pop_of_val st l :
of_val (CG_locked_popV st l) = CG_locked_pop st l.
Proof. trivial. Qed.
Global Opaque CG_locked_popV.
Lemma CG_locked_pop_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_locked_pop st l) (TArrow TUnit (TSum TUnit τ)).
Proof.
intros H1 H2. repeat econstructor.
eapply with_lock_type; auto using CG_pop_type.
Qed.
Lemma CG_locked_pop_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_locked_pop st l).[f] = CG_locked_pop st l.
Proof.
intros H1 H2 f. asimpl. unfold CG_locked_pop.
rewrite with_lock_closed; trivial. apply CG_pop_closed; trivial.
Qed.
Lemma CG_locked_pop_subst (st l : expr) f :
(CG_locked_pop st l).[f] = CG_locked_pop st.[f] l.[f].
Proof. by rewrite with_lock_subst CG_pop_subst. Qed.
Lemma steps_CG_locked_pop_suc E ρ j K st v w l :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ FoldV (InjRV (PairV w v)) ∗ l ↦ₛ (#♭v false)
∗ j ⤇ fill K (App (CG_locked_pop (Loc st) (Loc l)) Unit)
⊢ |={E}=> j ⤇ fill K (InjR (of_val w)) ∗ st ↦ₛ v ∗ l ↦ₛ (#♭v false).
Proof.
iIntros (HNE) "[#Hspec [Hx [Hl Hj]]]". unfold CG_locked_pop.
iMod (steps_with_lock _ _ j K _ _ (st ↦ₛ _) _ (InjRV w) UnitV
with "[$Hj $Hx $Hl]")%I as "Hj"; eauto.
iIntros (K') "[#Hspec Hxj]".
iApply steps_CG_pop_suc; first done. iFrame; trivial.
Qed.
Lemma steps_CG_locked_pop_fail E ρ j K st l :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ FoldV (InjLV UnitV) ∗ l ↦ₛ (#♭v false)
∗ j ⤇ fill K (App (CG_locked_pop (Loc st) (Loc l)) Unit)
⊢ |={E}=> j ⤇ fill K (InjL Unit) ∗ st ↦ₛ FoldV (InjLV UnitV) ∗ l ↦ₛ (#♭v false).
Proof.
iIntros (HNE) "[#Hspec [Hx [Hl Hj]]]". unfold CG_locked_pop.
iMod (steps_with_lock _ _ j K _ _ (st ↦ₛ _) _ (InjLV UnitV) UnitV
with "[$Hj $Hx $Hl]")%I as "Hj"; eauto.
iIntros (K') "[#Hspec Hxj] /=".
iApply steps_CG_pop_fail; first done. iFrame; trivial.
Qed.
Global Opaque CG_locked_pop.
Lemma CG_snap_to_val st l : to_val (CG_snap st l) = Some (CG_snapV st l).
Proof. trivial. Qed.
Lemma CG_snap_of_val st l : of_val (CG_snapV st l) = CG_snap st l.
Proof. trivial. Qed.
Global Opaque CG_snapV.
Lemma CG_snap_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_snap st l) (TArrow TUnit (CG_StackType τ)).
Proof.
intros H1 H2. repeat econstructor.
eapply with_lock_type; trivial. do 2 constructor.
eapply (context_weakening [_]); eauto.
Qed.
Lemma CG_snap_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_snap st l).[f] = CG_snap st l.
Proof.
intros H1 H2 f. asimpl. unfold CG_snap.
rewrite with_lock_closed; trivial.
intros f'. by asimpl; rewrite ?H1.
Qed.
Lemma CG_snap_subst (st l : expr) f :
(CG_snap st l).[f] = CG_snap st.[f] l.[f].
Proof. unfold CG_snap; rewrite ?with_lock_subst. by asimpl. Qed.
Lemma steps_CG_snap E ρ j K st v l :
nclose specN ⊆ E →
spec_ctx ρ ∗ st ↦ₛ v ∗ l ↦ₛ (#♭v false)
∗ j ⤇ fill K (App (CG_snap (Loc st) (Loc l)) Unit)
⊢ |={E}=> j ⤇ (fill K (of_val v)) ∗ st ↦ₛ v ∗ l ↦ₛ (#♭v false).
Proof.
iIntros (HNE) "[#Hspec [Hx [Hl Hj]]]". unfold CG_snap.
iMod (steps_with_lock _ _ j K _ _ (st ↦ₛ v) _ v UnitV
with "[$Hj $Hx $Hl]")%I as "Hj"; eauto.
iIntros (K') "[#Hspec [Hx Hj]]".
iMod (step_Lam _ _ j K' with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_load _ _ j K' with "[$Hj $Hx]") as "[Hj Hx]"; eauto.
by iFrame "#"; iFrame.
Qed.
Global Opaque CG_snap.
(* Coarse-grained iter *)
Lemma CG_iter_folding (f : expr) :
CG_iter f =
Rec (Case (Unfold (Var 1))
Unit
(LetIn
(App f.[ren (+3)] (Fst (Var 0)))
((App (Var 2) (Snd (Var 1)))))).
Proof. trivial. Qed.
Lemma CG_iter_type f Γ τ :
typed Γ f (TArrow τ TUnit) →
typed Γ (CG_iter f) (TArrow (CG_StackType τ) TUnit).
Proof.
intros H1.
econstructor.
eapply (Case_typed _ _ _ _ TUnit);
[| repeat constructor
| repeat econstructor; eapply (context_weakening [_; _; _]); eauto].
replace (TSum TUnit (TProd τ (CG_StackType τ))) with
((TSum TUnit (TProd τ.[ren (+1)] (TVar 0))).[(CG_StackType τ)/])
by (by asimpl).
repeat econstructor.
Qed.
Lemma CG_iter_to_val f : to_val (CG_iter f) = Some (CG_iterV f).
Proof. trivial. Qed.
Lemma CG_iter_of_val f : of_val (CG_iterV f) = CG_iter f.
Proof. trivial. Qed.
Global Opaque CG_iterV.
Lemma CG_iter_closed (f : expr) :
(∀ g, f.[g] = f) → ∀ g, (CG_iter f).[g] = CG_iter f.
Proof. intros Hf g. unfold CG_iter. asimpl. rewrite ?Hf; trivial. Qed.
Lemma CG_iter_subst (f : expr) g : (CG_iter f).[g] = CG_iter f.[g].
Proof. unfold CG_iter; asimpl; trivial. Qed.
Lemma steps_CG_iter E ρ j K f v w :
nclose specN ⊆ E →
spec_ctx ρ
∗ j ⤇ fill K (App (CG_iter (of_val f))
(Fold (InjR (Pair (of_val w) (of_val v)))))
⊢ |={E}=>
j ⤇ fill K
(LetIn (App (of_val f) (of_val w))
(App
(CG_iter (of_val f)).[ren (+1)]
(Snd (Pair (of_val w).[ren (+1)] (of_val v).[ren (+1)])))).
Proof.
iIntros (HNE) "[#Hspec Hj]". unfold CG_iter.
iMod (step_rec _ _ j K with "[$Hj]") as "Hj"; eauto.
rewrite -CG_iter_folding. Opaque CG_iter. asimpl.
iMod (step_Fold _ _ j (CaseCtx _ _ :: K) with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_case_inr _ _ j K with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_fst _ _ j (AppRCtx f :: (LetInCtx _) :: K) with "[$Hj]") as "Hj";
eauto.
Qed.
Transparent CG_iter.
Lemma steps_CG_iter_end E ρ j K f :
nclose specN ⊆ E →
spec_ctx ρ ∗ j ⤇ fill K (App (CG_iter (of_val f)) (Fold (InjL Unit)))
⊢ |={E}=> j ⤇ fill K Unit.
Proof.
iIntros (HNE) "[#Hspec Hj]". unfold CG_iter.
iMod (step_rec _ _ j K with "[$Hj]") as "Hj"; eauto.
rewrite -CG_iter_folding. Opaque CG_iter. asimpl.
iMod (step_Fold _ _ j (CaseCtx _ _ :: K) with "[$Hj]") as "Hj"; eauto.
asimpl.
iMod (step_case_inl _ _ j K with "[$Hj]") as "Hj"; eauto.
Qed.
Global Opaque CG_iter.
Lemma CG_snap_iter_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_snap_iter st l) (TArrow (TArrow τ TUnit) TUnit).
Proof.
intros H1 H2; repeat econstructor.
- eapply CG_iter_type; by constructor.
- eapply CG_snap_type; by eapply (context_weakening [_]).
Qed.
Lemma CG_snap_iter_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_snap_iter st l).[f] = CG_snap_iter st l.
Proof.
intros H1 H2 f. unfold CG_snap_iter. asimpl. rewrite H1 H2.
rewrite CG_snap_closed; auto.
Qed.
Lemma CG_snap_iter_subst (st l : expr) g :
(CG_snap_iter st l).[g] = CG_snap_iter st.[g] l.[g].
Proof.
unfold CG_snap_iter; asimpl.
rewrite CG_snap_subst CG_iter_subst. by asimpl.
Qed.
Lemma CG_stack_body_type st l Γ τ :
typed Γ st (Tref (CG_StackType τ)) →
typed Γ l LockType →
typed Γ (CG_stack_body st l)
(TProd
(TProd (TArrow τ TUnit) (TArrow TUnit (TSum TUnit τ)))
(TArrow (TArrow τ TUnit) TUnit)
).
Proof.
intros H1 H2.
repeat (econstructor; eauto using CG_locked_push_type,
CG_locked_pop_type, CG_snap_iter_type).
Qed.
Opaque CG_snap_iter.
Lemma CG_stack_body_closed (st l : expr) :
(∀ f, st.[f] = st) → (∀ f, l.[f] = l) →
∀ f, (CG_stack_body st l).[f] = CG_stack_body st l.
Proof.
intros H1 H2 f. unfold CG_stack_body. asimpl.
rewrite CG_locked_push_closed; trivial.
rewrite CG_locked_pop_closed; trivial.
by rewrite CG_snap_iter_closed.
Qed.
Lemma CG_stack_type Γ :
typed Γ CG_stack
(TForall
(TProd
(TProd
(TArrow (TVar 0) TUnit)
(TArrow TUnit (TSum TUnit (TVar 0)))
)
(TArrow (TArrow (TVar 0) TUnit) TUnit)
)).
Proof.
repeat econstructor;
eauto using CG_locked_push_type, CG_locked_pop_type,
CG_snap_iter_type, newlock_type, typed.
asimpl. repeat constructor.
Qed.
Lemma CG_stack_closed f : CG_stack.[f] = CG_stack.
Proof.
unfold CG_stack.
asimpl; rewrite ?CG_locked_push_subst ?CG_locked_pop_subst.
asimpl. rewrite ?CG_snap_iter_subst. by asimpl.
Qed.
End CG_Stack.